From 578fadb3a971c593dea3a3b11a5d23483668aa9b Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 12 Nov 2010 15:03:31 -0700 Subject: [PATCH 001/255] Horrible Xvnc trick --- collects/meta/drdr/config.rkt | 1 + collects/meta/drdr/dirstruct.rkt | 4 +++ collects/meta/drdr/plt-build.rkt | 44 +++++++++++++++++++++----------- 3 files changed, 34 insertions(+), 15 deletions(-) diff --git a/collects/meta/drdr/config.rkt b/collects/meta/drdr/config.rkt index 074ea8198e..534844d9eb 100644 --- a/collects/meta/drdr/config.rkt +++ b/collects/meta/drdr/config.rkt @@ -10,6 +10,7 @@ (git-path "/usr/bin/git") (Xvfb-path "/usr/bin/Xvnc") (fluxbox-path "/usr/bin/fluxbox") +(vncviewer-path "/usr/bin/vncviewer") (current-make-install-timeout-seconds (* 90 60)) (current-make-timeout-seconds (* 90 60)) (current-subprocess-timeout-seconds 90) diff --git a/collects/meta/drdr/dirstruct.rkt b/collects/meta/drdr/dirstruct.rkt index 3d182947f4..c31642fb54 100644 --- a/collects/meta/drdr/dirstruct.rkt +++ b/collects/meta/drdr/dirstruct.rkt @@ -31,6 +31,9 @@ (define fluxbox-path (make-parameter "/usr/bin/fluxbox")) +(define vncviewer-path + (make-parameter "/usr/bin/vncviewer")) + (define (plt-repository) (build-path (plt-directory) "repo")) @@ -100,6 +103,7 @@ [drdr-directory (parameter/c path-string?)] [make-path (parameter/c (or/c false/c string?))] [Xvfb-path (parameter/c (or/c false/c string?))] + [vncviewer-path (parameter/c (or/c false/c string?))] [fluxbox-path (parameter/c (or/c false/c string?))] [build? (parameter/c boolean?)] [on-unix? (-> boolean?)] diff --git a/collects/meta/drdr/plt-build.rkt b/collects/meta/drdr/plt-build.rkt index 08848cbccb..7aeec592c5 100644 --- a/collects/meta/drdr/plt-build.rkt +++ b/collects/meta/drdr/plt-build.rkt @@ -277,6 +277,7 @@ (recur-many (sub1 i) r f))))) (define XSERVER-OFFSET 20) +(define PARENT-X-SERVER 19) (define (integrate-revision rev) (define test-dir @@ -314,22 +315,35 @@ (get-scm-commit-msg rev (plt-repository)))) (when (build?) (build-revision rev)) - (recur-many (number-of-cpus) - (lambda (j inner) - (define i (+ j XSERVER-OFFSET)) - (notify! "Starting X server #~a" i) - (safely-delete-directory (format "/tmp/.X~a-lock" i)) - (safely-delete-directory (build-path tmp-dir (format ".X~a-lock" i))) - (safely-delete-directory (format "/tmp/.tX~a-lock" i)) - (safely-delete-directory (build-path tmp-dir (format ".tX~a-lock" i))) - (with-running-program - (Xvfb-path) (list (format ":~a" i) "-ac" "-rfbauth" "/home/jay/.vnc/passwd") - (lambda () - (with-running-program - (fluxbox-path) (list "-display" (format ":~a" i) "-rc" "/home/jay/.fluxbox/init") - inner)))) + + (define (start-x-server i parent inner) + (notify! "Starting X server #~a" i) + (safely-delete-directory (format "/tmp/.X~a-lock" i)) + (safely-delete-directory (build-path tmp-dir (format ".X~a-lock" i))) + (safely-delete-directory (format "/tmp/.tX~a-lock" i)) + (safely-delete-directory (build-path tmp-dir (format ".tX~a-lock" i))) + (with-running-program + (Xvfb-path) (list (format ":~a" i) "-ac" "-rfbauth" "/home/jay/.vnc/passwd") + (lambda () + (with-running-program + (fluxbox-path) (list "-display" (format ":~a" i) "-rc" "/home/jay/.fluxbox/init") + (if parent (lambda () - (test-revision rev))))) + (with-running-program + (vncviewer-path) (list "-display" (format ":~a" parent) (format ":~a" i) + "-passwd" "/home/jay/.vnc/passwd") + inner)) + inner))))) + + (start-x-server + PARENT-X-SERVER #f + (λ () + (recur-many (number-of-cpus) + (lambda (j inner) + (define i (+ j XSERVER-OFFSET)) + (start-x-server i PARENT-X-SERVER inner)) + (lambda () + (test-revision rev))))))) ; Remove the test directory (safely-delete-directory test-dir)))) From 4f36ce9635755ad194ed6c84e37b6f2a712fda38 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 12 Nov 2010 05:42:54 -0500 Subject: [PATCH 002/255] Redo `define-cstruct' with proper errors and more concisely. --- collects/ffi/unsafe.rkt | 100 ++++++++++++++++------------------------ 1 file changed, 40 insertions(+), 60 deletions(-) diff --git a/collects/ffi/unsafe.rkt b/collects/ffi/unsafe.rkt index f3ecaf241e..66fd34a767 100644 --- a/collects/ffi/unsafe.rkt +++ b/collects/ffi/unsafe.rkt @@ -1347,67 +1347,47 @@ (values _TYPE* _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ... list->TYPE list*->TYPE TYPE->list TYPE->list*)))))))) - (define (identifiers? stx) - (andmap identifier? (syntax->list stx))) - (define (_-identifier? id stx) - (and (identifier? id) - (or (regexp-match #rx"^_." (symbol->string (syntax-e id))) - (raise-syntax-error #f "cstruct name must begin with a `_'" - stx id)))) - ;; there is something wrong with the syntax, this function will find what it is - (define (syntax-error stx) - (define (check-rest rest) - (syntax-case rest () - [() (void)] - [else (raise-syntax-error #f "extra arguments given" rest)])) - (define (check-alignment alignment) - (syntax-case alignment () - [(#:alignment alignment-expr rest ...) - (check-rest #'(rest ...))] - [else (raise-syntax-error #f "the last argument can only be #:alignment" alignment)])) - (define (check-slots slots) - (define (check-slot slot) - (syntax-case slot () - [(name field) (void)] - [else (raise-syntax-error #f "a field must be a pair of a name and a ctype such as [x _int]" slot)])) - ;; check that some slots are given - (syntax-case slots () - [([name-id expr-id] ... . rest) - (when (and (identifiers? #'(name-id ...)) - (identifiers? #'(expr-id ...))) - (raise-syntax-error #f "fields must be a parenthesized list of name and a ctype such as ([x _int] [y _int])" slots))]) - (syntax-case slots () - [((slot ...) rest ...) - (begin - (for ([slot-stx (in-list (syntax->list #'(slot ...)))]) - (check-slot slot-stx)) - (check-alignment #'(rest ...)))] - [else (raise-syntax-error #f "fields must be a parenthesized list such as ([x _int] [y _int])" slots)])) - (define (check-name stx) - (syntax-case stx () - [(_ _TYPE rest ...) - (check-slots #'(rest ...))] - [else (raise-syntax-error #f "a name must be provided to cstruct" stx)])) - (check-name stx)) - + (define (err what . xs) + (apply raise-syntax-error #f + (if (list? what) (apply string-append what) what) + stx xs)) (syntax-case stx () - [(_ _TYPE ([slot slot-type] ...)) - (and (_-identifier? #'_TYPE stx) - (identifiers? #'(slot ...))) - (make-syntax #'_TYPE #f #'(slot ...) #'(slot-type ...) #'#f)] - [(_ _TYPE ([slot slot-type] ...) #:alignment alignment-expr) - (and (_-identifier? #'_TYPE stx) - (identifiers? #'(slot ...))) - (make-syntax #'_TYPE #f #'(slot ...) #'(slot-type ...) #'alignment-expr)] - [(_ (_TYPE _SUPER) ([slot slot-type] ...)) - (and (_-identifier? #'_TYPE stx) (identifiers? #'(slot ...))) - (with-syntax ([super (datum->syntax #'_TYPE 'super #'_TYPE)]) - (make-syntax #'_TYPE #t #'(super slot ...) #'(_SUPER slot-type ...) #'#f))] - [(_ (_TYPE _SUPER) ([slot slot-type] ...) #:alignment alignment-expr) - (and (_-identifier? #'_TYPE stx) (identifiers? #'(slot ...))) - (with-syntax ([super (datum->syntax #'_TYPE 'super #'_TYPE)]) - (make-syntax #'_TYPE #t #'(super slot ...) #'(_SUPER slot-type ...) #'alignment-expr))] - [else (syntax-error stx)])) + [(_ type ([slot slot-type] ...) . more) + (let-values ([(_TYPE _SUPER) + (syntax-case #'type () + [(t s) (values #'t #'s)] + [_ (values #'type #f)])] + [(alignment) + (syntax-case #'more () + [() #'#f] + [(#:alignment) (err "missing expression for #:alignment")] + [(#:alignment a) #'a] + [(#:alignment a x . _) (err "unexpected form" #'x)] + [(x . _) (err (if (keyword? (syntax-e #'x)) + "unknown keyword" "unexpected form") + #'x)])]) + (unless (identifier? _TYPE) + (err "bad type, expecting a _name identifier or (_name super-ctype)" + _TYPE)) + (unless (regexp-match? #rx"^_." (symbol->string (syntax-e _TYPE))) + (err "cstruct name must begin with a `_'" _TYPE)) + (for ([s (in-list (syntax->list #'(slot ...)))]) + (unless (identifier? s) + (err "bad field name, expecting an identifier identifier" s))) + (if _SUPER + (make-syntax _TYPE #t + #`(#,(datum->syntax _TYPE 'super _TYPE) slot ...) + #`(#,_SUPER slot-type ...) + alignment) + (make-syntax _TYPE #f #'(slot ...) #`(slot-type ...) alignment)))] + ;; specific errors for bad slot specs, leave the rest for a generic error + [(_ type (bad ...) . more) + (err "bad slot specification, expecting [name ctype]" + (ormap (lambda (s) (syntax-case s () [[n ct] #t] [_ s])) + (syntax->list #'(bad ...))))] + [(_ type bad . more) + (err "bad slot specification, expecting a sequence of [name ctype]" + #'bad)])) ;; helper for the above: keep runtime information on structs (define cstruct-info From c1e1c70dcf4d32c417bbd205a214a29c68d3be29 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 12 Nov 2010 11:30:32 -0500 Subject: [PATCH 003/255] Allow optional arguments with default in `cmdline', updated docs. --- collects/racket/cmdline.rkt | 9 +++++++-- collects/scribblings/reference/cmdline.scrbl | 8 +++++--- 2 files changed, 12 insertions(+), 5 deletions(-) diff --git a/collects/racket/cmdline.rkt b/collects/racket/cmdline.rkt index 2c0371802c..bb6383c734 100644 --- a/collects/racket/cmdline.rkt +++ b/collects/racket/cmdline.rkt @@ -58,7 +58,7 @@ [(argv-expr lst) (extract-arg '#:argv lst #'(current-command-line-arguments))]) (let-values ([(table args) - (let loop ([lst lst][accum null]) + (let loop ([lst lst] [accum null]) (if (null? lst) (loop (syntax->list #'(#:args () (void))) accum) (let ([a (syntax-e (car lst))] @@ -140,6 +140,9 @@ [(arg . rest) (identifier? #'arg) (cons #'arg (loop #'rest))] + [([arg def] . rest) + (identifier? #'arg) + (cons #'[arg def] (loop #'rest))] [arg (identifier? #'arg) (list #'arg)] @@ -151,7 +154,9 @@ (serror "#:args must not be followed by another keyword" (car lst))) (with-syntax ([formals (car pieces)] [formal-names (map (lambda (x) - (symbol->string (syntax-e x))) + (let ([d (syntax->datum x)]) + (symbol->string + (if (pair? d) (car d) d)))) formal-names)] [body (cdr pieces)]) (values (reverse accum) diff --git a/collects/scribblings/reference/cmdline.scrbl b/collects/scribblings/reference/cmdline.scrbl index 147d90b5c6..eddb01647c 100644 --- a/collects/scribblings/reference/cmdline.scrbl +++ b/collects/scribblings/reference/cmdline.scrbl @@ -29,9 +29,11 @@ [finish-clause code:blank (code:line #:args arg-formals body ...+) (code:line #:handlers handlers-exprs)] - [arg-formals id - (id ...) - (id ...+ . id)] + [arg-formals rest-id + (arg ...) + (arg ...+ . rest-id)] + [arg id + [id default-expr]] [handlers-exprs (code:line finish-expr arg-strings-expr) (code:line finish-expr arg-strings-expr help-expr) (code:line finish-expr arg-strings-expr help-expr From 5c1bd77b9e92f29dfb3271f37a0b86ddfddc65fb Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 12 Nov 2010 16:43:33 -0500 Subject: [PATCH 004/255] Add `shuffle' to `racket/list'. --- collects/racket/list.rkt | 5 ++++- collects/scribblings/reference/pairs.scrbl | 10 ++++++++++ collects/tests/racket/list.rktl | 8 ++++++++ 3 files changed, 22 insertions(+), 1 deletion(-) diff --git a/collects/racket/list.rkt b/collects/racket/list.rkt index 657bec147f..50b7155986 100644 --- a/collects/racket/list.rkt +++ b/collects/racket/list.rkt @@ -30,7 +30,8 @@ ;; convenience append-map - filter-not) + filter-not + shuffle) (define (first x) (if (and (pair? x) (list? x)) @@ -327,6 +328,8 @@ (reverse result) (loop (cdr l) (if (f (car l)) result (cons (car l) result)))))) +(define (shuffle l) + (sort l < #:key (lambda (_) (random)) #:cache-keys? #t)) ;; mk-min : (number number -> boolean) symbol (X -> real) (listof X) -> X (define (mk-min cmp name f xs) diff --git a/collects/scribblings/reference/pairs.scrbl b/collects/scribblings/reference/pairs.scrbl index ad003860ae..74e08fa780 100644 --- a/collects/scribblings/reference/pairs.scrbl +++ b/collects/scribblings/reference/pairs.scrbl @@ -949,6 +949,16 @@ returns @scheme[#f]. (filter-not even? '(1 2 3 4 5 6)) ]} + +@defproc[(shuffle [lst list?]) list?]{ + +Returns a list with all elements from @racket[lst], randomly shuffled. + +@mz-examples[#:eval list-eval + (shuffle '(1 2 3 4 5 6)) +]} + + @defproc[(argmin [proc (-> any/c real?)] [lst (and/c pair? list?)]) any/c]{ This returns the first element in the list @scheme[lst] that minimizes diff --git a/collects/tests/racket/list.rktl b/collects/tests/racket/list.rktl index 23d21a62ac..c29a4c4335 100644 --- a/collects/tests/racket/list.rktl +++ b/collects/tests/racket/list.rktl @@ -317,6 +317,14 @@ (test '(1 2 3) am list '(1 2 3)) (test '(1 1 2 2 3 3) am (lambda (x) (list x x)) '(1 2 3))) +;; ---------- shuffle ---------- +(let loop ([l (reverse '(1 2 4 8 16 32))]) + (define (length+sum l) (list (length l) (apply + l))) + (define expected (length+sum l)) + (for ([i (in-range 100)]) + (test expected length+sum (shuffle l))) + (when (pair? l) (loop (cdr l)))) + ;; ---------- argmin & argmax ---------- (let () From dc64b010155fd24aec84ad6a5d26db2102b4dcf4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 12 Nov 2010 15:25:54 -0700 Subject: [PATCH 005/255] tweak JIT generation of fixnum mult with a constant argument --- src/racket/src/jit.c | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/racket/src/jit.c b/src/racket/src/jit.c index 11e4f9d647..b9032bd059 100644 --- a/src/racket/src/jit.c +++ b/src/racket/src/jit.c @@ -5967,13 +5967,14 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj } else if (v == 0) { (void)jit_movi_p(JIT_R0, scheme_make_integer(0)); } else { - (void)jit_movi_p(JIT_R1, scheme_make_integer(v)); - jit_andi_ul(JIT_R2, JIT_R1, (~0x1)); + (void)jit_movi_l(JIT_R2, ((long)scheme_make_integer(v) & (~0x1))); jit_rshi_l(JIT_V1, JIT_R0, 0x1); if (unsafe_fx && !overflow_refslow) jit_mulr_l(JIT_V1, JIT_V1, JIT_R2); - else + else { + (void)jit_movi_p(JIT_R1, scheme_make_integer(v)); /* for slow path */ (void)jit_bomulr_l(refslow, JIT_V1, JIT_R2); + } jit_ori_ul(JIT_R0, JIT_V1, 0x1); } } else if (arith == -2) { From 0ac5ff9be0209d97cb665a67a6bd88f52c4cd745 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 12 Nov 2010 15:26:29 -0700 Subject: [PATCH 006/255] fix doc typo --- collects/scribblings/reference/chaperones.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/reference/chaperones.scrbl b/collects/scribblings/reference/chaperones.scrbl index c01efe7531..ddaf17c332 100644 --- a/collects/scribblings/reference/chaperones.scrbl +++ b/collects/scribblings/reference/chaperones.scrbl @@ -325,7 +325,7 @@ or override impersonator-property values of @scheme[hash].} A @tech{structure type property} (see @secref["structprops"]) that supplies a procedure for extracting an impersonated value from a structure -that represents an impersonator. The property is used for @racket[impersonator-of] +that represents an impersonator. The property is used for @racket[impersonator-of?] as well as @racket[equal?]. The property value must be a procedure of one argument, which is a From 42a4465fb0a795a696cae82e77bb2a3f3d350205 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 12 Nov 2010 15:26:45 -0700 Subject: [PATCH 007/255] fix bytecode compiler bugs in tracking known-flonum arguments --- collects/tests/racket/optimize.rktl | 19 +++++++++++++++ src/racket/src/eval.c | 4 ++-- src/racket/src/fun.c | 37 +++++++++++++++++++++++++---- src/racket/src/schpriv.h | 1 + src/racket/src/syntax.c | 17 +++++++++---- 5 files changed, 68 insertions(+), 10 deletions(-) diff --git a/collects/tests/racket/optimize.rktl b/collects/tests/racket/optimize.rktl index 7a588cad42..69cecde375 100644 --- a/collects/tests/racket/optimize.rktl +++ b/collects/tests/racket/optimize.rktl @@ -1363,6 +1363,25 @@ ((proc 98) x))))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Check that an unboxable flonum argument +;; is not incorrectly inferred: + +(test '(done) + 'unboxing-inference-test + (let () + (define (f x y) + (if (zero? y) + ;; prevents inlining: + '(done) + (if (zero? y) + ;; incorrectly triggered unboxing, + ;; once upon a time: + (fl+ x 1.0) + ;; not a float argument => no unboxing of x: + (f y (sub1 y))))) + (f 1.0 100))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/src/racket/src/eval.c b/src/racket/src/eval.c index 73e1bca4a7..537eeb4b6c 100644 --- a/src/racket/src/eval.c +++ b/src/racket/src/eval.c @@ -2814,14 +2814,14 @@ static void register_flonum_argument_types(Scheme_App_Rec *app, Scheme_App2_Rec if (!map) { map = MALLOC_N_ATOMIC(char, n); memset(map, 1, n); + memset(map, 0, i); } } if (map && !is_flonum) map[i] = 0; } - if (map) - scheme_set_closure_flonum_map(data, map); + scheme_set_closure_flonum_map(data, map); } } } diff --git a/src/racket/src/fun.c b/src/racket/src/fun.c index 9f1b61a844..aea64cc386 100644 --- a/src/racket/src/fun.c +++ b/src/racket/src/fun.c @@ -1143,12 +1143,41 @@ void scheme_set_closure_flonum_map(Scheme_Closure_Data *data, char *flonum_map) cl->flonum_map = flonum_map; } - for (i = data->num_params; i--; ) { - if (flonum_map[i]) break; + if (flonum_map) { + for (i = data->num_params; i--; ) { + if (flonum_map[i]) break; + } + + if (i < 0) { + cl->flonum_map = NULL; + } } +} - if (i < 0) { - cl->flonum_map = NULL; +void scheme_merge_closure_flonum_map(Scheme_Closure_Data *data1, Scheme_Closure_Data *data2) +{ + Closure_Info *cl1 = (Closure_Info *)data1->closure_map; + Closure_Info *cl2 = (Closure_Info *)data2->closure_map; + + if (cl1->has_flomap) { + if (!cl1->flonum_map || !cl2->has_flomap) { + cl2->has_flomap = 1; + cl2->flonum_map = cl1->flonum_map; + } else if (cl2->flonum_map) { + int i; + for (i = data1->num_params; i--; ) { + if (cl1->flonum_map[i] != cl2->flonum_map[i]) { + cl2->flonum_map = NULL; + cl1->flonum_map = NULL; + break; + } + } + } else { + cl1->flonum_map = NULL; + } + } else if (cl2->has_flomap) { + cl1->has_flomap = 1; + cl1->flonum_map = cl2->flonum_map; } } diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index 3073939415..86af9ddf4b 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -2548,6 +2548,7 @@ int scheme_optimize_is_flonum_valued(Optimize_Info *info, int pos); int scheme_is_flonum_expression(Scheme_Object *expr, Optimize_Info *info); char *scheme_get_closure_flonum_map(Scheme_Closure_Data *data, int arg_n, int *ok); void scheme_set_closure_flonum_map(Scheme_Closure_Data *data, char *flonum_map); +void scheme_merge_closure_flonum_map(Scheme_Closure_Data *data1, Scheme_Closure_Data *data2); Scheme_Object *scheme_optimize_clone(int dup_ok, Scheme_Object *obj, Optimize_Info *info, int delta, int closure_depth); Scheme_Object *scheme_optimize_shift(Scheme_Object *obj, int delta, int after_depth); diff --git a/src/racket/src/syntax.c b/src/racket/src/syntax.c index 2d5b625a81..6acb9014ff 100644 --- a/src/racket/src/syntax.c +++ b/src/racket/src/syntax.c @@ -3018,7 +3018,8 @@ static Scheme_Object *make_clones(Scheme_Compiled_Let_Value *retry_start, static int set_code_flags(Scheme_Compiled_Let_Value *retry_start, Scheme_Compiled_Let_Value *pre_body, Scheme_Object *clones, - int set_flags, int mask_flags, int just_tentative) + int set_flags, int mask_flags, int just_tentative, + int merge_flonum) { Scheme_Compiled_Let_Value *clv; Scheme_Object *value, *first; @@ -3035,12 +3036,18 @@ static int set_code_flags(Scheme_Compiled_Let_Value *retry_start, value = clv->value; if (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(value))) { data = (Scheme_Closure_Data *)value; + + first = SCHEME_CAR(clones); + + if (merge_flonum) { + scheme_merge_closure_flonum_map(data, (Scheme_Closure_Data *)SCHEME_CAR(first)); + scheme_merge_closure_flonum_map(data, (Scheme_Closure_Data *)SCHEME_CDR(first)); + scheme_merge_closure_flonum_map(data, (Scheme_Closure_Data *)SCHEME_CAR(first)); + } if (!just_tentative || (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_RESULT_TENTATIVE)) { flags = (flags & SCHEME_CLOSURE_DATA_FLAGS(data)); - first = SCHEME_CAR(clones); - data = (Scheme_Closure_Data *)SCHEME_CDR(first); SCHEME_CLOSURE_DATA_FLAGS(data) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data) & mask_flags); data = (Scheme_Closure_Data *)SCHEME_CAR(first); @@ -3611,6 +3618,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i (void)set_code_flags(retry_start, pre_body, clones, CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE, 0xFFFF, + 0, 0); /* Re-optimize loop: */ clv = retry_start; @@ -3690,11 +3698,12 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i clv = (Scheme_Compiled_Let_Value *)clv->body; } /* Check flags loop: */ - flags = set_code_flags(retry_start, pre_body, clones, 0, 0xFFFF, 0); + flags = set_code_flags(retry_start, pre_body, clones, 0, 0xFFFF, 0, 0); /* Reset-flags loop: */ (void)set_code_flags(retry_start, pre_body, clones, (flags & (CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS)), ~(CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE), + 1, 1); } retry_start = NULL; From c1ce863a70369f7d1794c6e5dd1943c21ee36cfe Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 12 Nov 2010 20:18:03 -0700 Subject: [PATCH 008/255] experiment with explicit flush in 2htdp/world --- collects/2htdp/private/world.rkt | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/collects/2htdp/private/world.rkt b/collects/2htdp/private/world.rkt index 6a1d772bd0..9c275df1ba 100644 --- a/collects/2htdp/private/world.rkt +++ b/collects/2htdp/private/world.rkt @@ -211,9 +211,15 @@ (let ([s (send visible find-first-snip)] [c (send visible get-canvas)]) (when s (send visible delete s)) - (send visible insert (send pict copy) 0 0)) - (send visible lock #t) - (send visible end-edit-sequence)) + (send visible insert (send pict copy) 0 0) + (send visible lock #t) + (send visible end-edit-sequence) + ;; The following flush trades streaming performance (where updates + ;; could be skipped if they're replaced fast enough) for + ;; responsiveness (where too many updates might not get + ;; through if the canvas is mostly in suspended-refresh + ;; mode for scene changes): + (send c flush))) ;; ---------------------------------------------------------------------- ;; callbacks From a07f2266c080aa80734b0a6d2ca1b5734947cf65 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 12 Nov 2010 20:18:22 -0700 Subject: [PATCH 009/255] fix gl-config% depth default --- collects/racket/draw/private/gl-config.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/racket/draw/private/gl-config.rkt b/collects/racket/draw/private/gl-config.rkt index 5ab3971435..7b3f080bff 100644 --- a/collects/racket/draw/private/gl-config.rkt +++ b/collects/racket/draw/private/gl-config.rkt @@ -25,7 +25,7 @@ (def/public (set-accum-size [(integer-in 0 256) s]) (set! accum-size s)) - (define depth-size 0) + (define depth-size 1) (define/public (get-depth-size) depth-size) (def/public (set-depth-size [(integer-in 0 256) s]) (set! depth-size s)) From 75bc9bd7182bc828a070611ef36284d85d0088a6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 12 Nov 2010 20:36:54 -0700 Subject: [PATCH 010/255] use low-priority callback for gears increment so events are handled --- collects/sgl/examples/gears.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/sgl/examples/gears.rkt b/collects/sgl/examples/gears.rkt index cba4b9b31e..71d6f88a49 100644 --- a/collects/sgl/examples/gears.rkt +++ b/collects/sgl/examples/gears.rkt @@ -335,7 +335,7 @@ (gl-flush))) (when step? (set! step? #f) - (queue-callback (lambda x (send this run)))))) + (queue-callback (lambda x (send this run)) #f)))) (super-instantiate () (style '(gl no-autoclear))))) (define (f) From 1c6f745ac162c91532c75e2bb0a0922c4b3fefab Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 12 Nov 2010 20:39:58 -0700 Subject: [PATCH 011/255] adjust canvas refresh strategy yet again - there seems to be no need to auto-resume flushes on a canvas, which can create flicker if the auto-resume timeout turns out to be too short --- collects/mred/private/wx/cocoa/canvas.rkt | 6 ++++-- collects/mred/private/wx/cocoa/dc.rkt | 17 ++++++--------- collects/mred/private/wx/common/delay.rkt | 26 ++++++++++++++++------- 3 files changed, 29 insertions(+), 20 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index e791fc55d8..7488e4905d 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -272,9 +272,11 @@ ;; are defined by `canvas-mixin' from ../common/canvas-mixin (define/public (queue-paint) (void)) (define/public (request-canvas-flush-delay) - (request-flush-delay (get-cocoa-window))) + (unless is-gl? + (request-flush-delay (get-cocoa-window)))) (define/public (cancel-canvas-flush-delay req) - (cancel-flush-delay req)) + (unless is-gl? + (cancel-flush-delay req))) (define/public (queue-canvas-refresh-event thunk) (queue-window-refresh-event this thunk)) diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index b6c04bf087..b739fa88bd 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -26,6 +26,7 @@ (init [(cnvs canvas)]) (define canvas cnvs) + (inherit end-delay) (super-new) (define gl #f) @@ -59,21 +60,18 @@ (values (unbox xb) (unbox yb)))) (define/override (queue-backing-flush) - ;; With Cocoa window-level delay doesn't stop - ;; displays; it blocks flushes to the screen. - ;; So leave the delay in place, and `end-delay' - ;; after displaying to the window (after which - ;; we'll be ready to flush the window), which - ;; is at then end of `do-backing-flush'. + ;; Re-enable expose events so that the queued + ;; backing flush will be handled: + (end-delay) (send canvas queue-backing-flush)) (define/override (flush) (send canvas flush)) (define/override (request-delay) - (request-flush-delay (send canvas get-flush-window))) + (send canvas request-canvas-flush-delay)) (define/override (cancel-delay req) - (cancel-flush-delay req)))) + (send canvas cancel-canvas-flush-delay req)))) (define (do-backing-flush canvas dc ctx dx dy) (tellv ctx saveGraphicsState) @@ -99,6 +97,5 @@ (cairo_fill cr) (cairo_set_source cr s) (cairo_pattern_destroy s)) - (cairo_destroy cr)))) - (send dc end-delay))) + (cairo_destroy cr)))))) (tellv ctx restoreGraphicsState))) diff --git a/collects/mred/private/wx/common/delay.rkt b/collects/mred/private/wx/common/delay.rkt index 7898a2d31f..ef8d704432 100644 --- a/collects/mred/private/wx/common/delay.rkt +++ b/collects/mred/private/wx/common/delay.rkt @@ -6,19 +6,28 @@ (protect-out do-request-flush-delay do-cancel-flush-delay)) +;; Auto-cancel schedules a cancel of a request flush +;; on event boundaries. It makes sense if you don't +;; trust a program to un-delay important refreshes, +;; but auto-cancel is currently disabled because +;; bad refresh-delay effects are confined to the enclosing +;; window on all platforms. +(define AUTO-CANCEL-DELAY? #f) + (define (do-request-flush-delay win disable enable) (atomically (let ([req (box win)]) (and (disable win) (begin - (add-event-boundary-sometimes-callback! - req - (lambda (v) - ;; in atomic mode - (when (unbox req) - (set-box! req #f) - (enable win)))) + (when AUTO-CANCEL-DELAY? + (add-event-boundary-sometimes-callback! + req + (lambda (v) + ;; in atomic mode + (when (unbox req) + (set-box! req #f) + (enable win))))) req))))) (define (do-cancel-flush-delay req enable) @@ -27,4 +36,5 @@ (when win (set-box! req #f) (enable win) - (remove-event-boundary-callback! req))))) + (when AUTO-CANCEL-DELAY? + (remove-event-boundary-callback! req)))))) From c3e0a7af139ab44e1bc7f46a4de9de5a582f98ea Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 12 Nov 2010 20:47:07 -0700 Subject: [PATCH 012/255] manual tests for refresh behavior --- collects/meta/props | 2 + collects/tests/gracket/flush-stress.rkt | 50 +++++++++++++++++++++ collects/tests/gracket/unflushed-circle.rkt | 43 ++++++++++++++++++ 3 files changed, 95 insertions(+) create mode 100644 collects/tests/gracket/flush-stress.rkt create mode 100644 collects/tests/gracket/unflushed-circle.rkt diff --git a/collects/meta/props b/collects/meta/props index 8c421d0941..d94a147965 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1463,6 +1463,7 @@ path/s is either such a string or a list of them. "collects/tests/gracket/dc.rktl" drdr:command-line (gracket "-f" *) "collects/tests/gracket/draw.rkt" drdr:command-line (mzc *) "collects/tests/gracket/editor.rktl" drdr:command-line (gracket "-f" *) +"collects/tests/gracket/flush-stress.rkt" drdr:command-line #f "collects/tests/gracket/gui-main.rktl" drdr:command-line (gracket "-f" *) "collects/tests/gracket/gui.rktl" drdr:command-line (gracket "-f" *) "collects/tests/gracket/item.rkt" drdr:command-line (mzc *) @@ -1473,6 +1474,7 @@ path/s is either such a string or a list of them. "collects/tests/gracket/random.rktl" drdr:command-line #f "collects/tests/gracket/showkey.rkt" drdr:command-line #f "collects/tests/gracket/sixlib.rktl" drdr:command-line #f +"collects/tests/gracket/unflushed-circle.rkt" drdr:command-line #f "collects/tests/gracket/test-editor-admin.rkt" drdr:command-line (gracket-text "-t" *) "collects/tests/gracket/testing.rktl" drdr:command-line (gracket "-f" *) "collects/tests/gracket/text-scale.rktl" drdr:command-line #f diff --git a/collects/tests/gracket/flush-stress.rkt b/collects/tests/gracket/flush-stress.rkt new file mode 100644 index 0000000000..cddbaff663 --- /dev/null +++ b/collects/tests/gracket/flush-stress.rkt @@ -0,0 +1,50 @@ +#lang racket/gui + +(define SIZE 600) + +(define f (new frame% + [label "Color Bars"] + [width SIZE] + [height SIZE])) + +(define c (new canvas% [parent f])) + +(send f show #t) + +;; If sync is turned off, then expect the drawing +;; to flicker horribly: +(define sync? #t) + +;; If flush-on-sync is disabled, the expect refresh +;; to starve, so that the image moves very rarely, if +;; at all: +(define flush-on-sync? #t) + +(define (start-drawing dc) + (when sync? + (send dc suspend-flush))) + +(define (end-drawing dc) + (when sync? + (send dc resume-flush) + (when flush-on-sync? + (send dc flush)))) + +(define (go) + (let ([dc (send c get-dc)]) + (for ([d (in-naturals)]) + (start-drawing dc) + (send dc erase) + ;; Draw somthing slow that changes with d + (for ([n (in-range 0 SIZE)]) + (send dc set-pen + (make-object color% + (remainder (+ n d) 256) + (remainder (* 2 (+ n d)) 256) + (remainder (* 3 (+ n d)) 256)) + 1 + 'solid) + (send dc draw-line n 0 n SIZE)) + (end-drawing dc)))) + +(thread go) diff --git a/collects/tests/gracket/unflushed-circle.rkt b/collects/tests/gracket/unflushed-circle.rkt new file mode 100644 index 0000000000..7376ed6212 --- /dev/null +++ b/collects/tests/gracket/unflushed-circle.rkt @@ -0,0 +1,43 @@ +#lang racket/gui +(require racket/math) + +;; This test creates a background that draws a circle in changing +;; colors. It draws in a background thread --- on in response to +;; `on-paint', and with no flushing controls --- but it should nevertheless +;; refresh onscreen frequently through an automatic flush. + +(define f (new frame% + [label "Snake"] + [width 400] + [height 400])) + +(define c (new canvas% [parent f])) + +(send f show #t) + +(define prev-count 0) +(define next-time (+ (current-inexact-milliseconds) 1000)) + +(define (go) + (let loop ([n 0]) + (when ((current-inexact-milliseconds) . > . next-time) + (printf "~s\n" (- n prev-count)) + (set! prev-count n) + (set! next-time (+ (current-inexact-milliseconds) 1000))) + (let ([p (make-polar 175 (* pi (/ n 100)))] + [dc (send c get-dc)]) + (send dc set-brush + (make-object color% + (remainder n 256) + (remainder (* 2 n) 256) + (remainder (* 3 n) 256)) + 'solid) + (send dc draw-rectangle + (+ 180 (real-part p)) + (+ 180 (imag-part p)) + 20 + 20) + (loop (add1 n))))) + +(thread go) + From 885fa11bfeaa559c9f3ea5d59092b9a405350874 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 13 Nov 2010 01:25:21 -0500 Subject: [PATCH 013/255] Change the library download procedure. Instead of downloading to the build directory and then copy files from there to the target, download directly to the target. This way no downloading is necessary when people use a fresh build directory. --- collects/meta/build/build | 6 +- collects/meta/dist-specs.rkt | 3 +- src/get-libs.rkt | 194 ++++++++++++++++++----------------- src/gracket/Makefile.in | 7 +- src/worksp/build.bat | 4 +- 5 files changed, 107 insertions(+), 107 deletions(-) diff --git a/collects/meta/build/build b/collects/meta/build/build index 10f7f21200..547be96757 100755 --- a/collects/meta/build/build +++ b/collects/meta/build/build @@ -1355,9 +1355,9 @@ DO_WIN32_BUILD() { build_w32step VSNET "mzstart" build_w32step VSNET "mrstart" - _cd "$PLTHOME" - build_w32step RKT "get-libs (gui)" src/get-libs.rkt core src/gracket lib - build_w32step RKT "get-libs (gui)" src/get-libs.rkt gui src/gracket lib + _cd "$PLTHOME/lib" + build_w32step RKT "get-libs (gui)" src/get-libs.rkt core + build_w32step RKT "get-libs (gui)" src/get-libs.rkt gui separator "win32: Building libraries" _cd "$PLTHOME" diff --git a/collects/meta/dist-specs.rkt b/collects/meta/dist-specs.rkt index acf8eb8b24..c47fe9828a 100644 --- a/collects/meta/dist-specs.rkt +++ b/collects/meta/dist-specs.rkt @@ -316,8 +316,7 @@ package: := ;; Utility for pulling out the names of libraries get-libs: := (lambda (p) - (let* ([xs (parameterize ([current-command-line-arguments - '#("--no-op" "" "" "")]) + (let* ([xs (parameterize ([current-command-line-arguments '#("nothing")]) (dynamic-require (build-path racket/ "src" "get-libs.rkt") 'all-files+sizes))] [xs (or (assq p xs) (error 'get-libs "unknown package, ~s" p))] diff --git a/src/get-libs.rkt b/src/get-libs.rkt index 368fee40b8..e3c9f42c0a 100644 --- a/src/get-libs.rkt +++ b/src/get-libs.rkt @@ -5,15 +5,16 @@ ;; This program avoids racket/port and net/url, because it is loaded ;; without using bytecode. -(define mode 'download) -(define touch #f) - (define url-host "download.racket-lang.org") (define url-path "/libs/1/") (define url-base (string-append "http://" url-host url-path)) (provide all-files+sizes) (define all-files+sizes + ;; alist mapping package to + ;; alist mapping architecture to + ;; a list of entries, each has filename and size + ;; and optionally a path that it would install to and the installed size `(;; Core Libraries [core [win32/i386 @@ -35,7 +36,7 @@ ["libpixman-1.0.dylib" 459304] ["libgthread-2.0.0.dylib" 24592] ["libpng14.14.dylib" 182992] - ["PSMTabBarControl.tgz" 89039]] + ["PSMTabBarControl.tgz" 89039 "PSMTabBarControl.framework" 247760]] [x86_64-macosx ["libcairo.2.dylib" 944552] ["libintl.8.dylib" 61016] @@ -49,7 +50,7 @@ ["libpixman-1.0.dylib" 499440] ["libgthread-2.0.0.dylib" 21728] ["libpng14.14.dylib" 192224] - ["PSMTabBarControl.tgz" 105765]] + ["PSMTabBarControl.tgz" 105765 "PSMTabBarControl.framework" 316512]] [ppc-macosx ["libcairo.2.dylib" 2716096] ["libintl.8.dylib" 133156] @@ -63,7 +64,7 @@ ["libpixman-1.0.dylib" 1366816] ["libgthread-2.0.0.dylib" 25416] ["libpng14.14.dylib" 505920] - ["PSMTabBarControl.tgz" 95862]] + ["PSMTabBarControl.tgz" 95862 "PSMTabBarControl.framework" 229493]] [win32/i386 ["libjpeg-7.dll" 233192] ["libcairo-2.dll" 921369] @@ -91,16 +92,9 @@ ["gtkrc" 1181]) '())]])) -(define-values (package src-dir dest-dir) - (command-line - #:once-any - [("--download") "download mode (the default)" (set! mode 'download)] - [("--install") "install mode" (set! mode 'install)] - [("--no-op") "do nothing (for internal use)" (set! mode #f)] - #:once-each - [("--touch") file "touch `' on download success" (set! touch file)] - #:args [package src-dir dest-dir] - (values (string->symbol package) src-dir dest-dir))) +(define-values [package dest-dir] + (command-line #:args [package [dest-dir (current-directory)]] + (values (string->symbol package) dest-dir))) (define (unixize p) (let-values ([(base name dir?) (split-path p)]) @@ -108,17 +102,15 @@ (string-append (unixize base) "/" (path->string name)) (path->string name)))) -(define (needed-files+sizes) - (let* ([files+sizes - (cdr (or (assq package all-files+sizes) - (error 'get-libs "bad package: ~s, expecting one of ~s" - package (map car all-files+sizes))))] - [arch (unixize (system-library-subpath))] - [arch (string->symbol (regexp-replace #rx"/3m$" arch ""))]) - (cond [(assq arch files+sizes) => cdr] - [else '()]))) +(define architecture (string->symbol (unixize (system-library-subpath #f)))) -(define explained? #f) +(define (needed-files+sizes) + (let ([files+sizes + (cdr (or (assq package all-files+sizes) + (error 'get-libs "bad package: ~s, expecting one of ~s" + package (map car all-files+sizes))))]) + (cond [(assq architecture files+sizes) => cdr] + [else '()]))) (define (purify-port port) (let ([m (regexp-match-peek-positions #rx#"^HTTP/.*?(?:\r\n\r\n|\n\n|\r\r)" @@ -138,75 +130,89 @@ ;; Must be EOF [else (void)]))))) -(define (download-if-needed dest-dir file size) - (define dest (build-path dest-dir file)) - (if (and (file-exists? dest) (= (file-size dest) size)) - (printf " ~a is ready\n" file) - (let* ([sub (unixize (system-library-subpath #f))] - [src (format "~a~a/~a" url-path sub file)]) - (unless explained? - (set! explained? #t) - (printf ">> Downloading files from\n>> ~a~a\n" url-base sub) - (printf ">> If you don't want automatic download, download each file\n") - (printf ">> yourself from there to\n") - (printf ">> ~a\n" (path->complete-path dest-dir))) - (printf " ~a downloading..." file) - (flush-output) - (define-values [i o] (tcp-connect url-host 80)) - (fprintf o "GET ~a HTTP/1.0\r\n" src) - (fprintf o "Host: ~a\r\n" url-host) - (fprintf o "\r\n") - (flush-output o) - (tcp-abandon-port o) - (purify-port i) - (define tmp (build-path dest-dir (format "~a.download" file))) - (call-with-output-file tmp #:exists 'truncate/replace - (lambda (out) (copy-port i out))) - (rename-file-or-directory tmp dest #t) - (let ([sz (file-size dest)]) - (unless (= size sz) - (eprintf "\n") - (raise-user-error - 'get-libs "size of ~a is ~a; doesn't match expected size ~a" - dest sz size))) - (printf "done\n")))) +(define (download file size) + (define src (format "~a~a/~a" url-path architecture file)) + (define-values [i o] (tcp-connect url-host 80)) + (fprintf o "GET ~a HTTP/1.0\r\nHost: ~a\r\n\r\n" src url-host) + (flush-output o) (tcp-abandon-port o) + (purify-port i) + (define tmp (format "~a.download" file)) + (call-with-output-file tmp #:exists 'truncate/replace + (lambda (out) (copy-port i out))) + (rename-file-or-directory tmp file #t) + (let ([sz (file-size file)]) + (unless (= size sz) + (eprintf "\n") + (raise-user-error 'get-libs + "size of ~a is ~a; doesn't match expected size ~a" + file sz size)))) -(define (same-content? f1 f2) - ;; approximate: - (and (file-exists? f1) (file-exists? f2) (= (file-size f1) (file-size f2)))) +(define (unpack-tgz tgz) + (printf " unpacking...") (flush-output) + (define-values [p pout pin perr] + (subprocess + (current-output-port) (current-input-port) (current-error-port) + (find-executable-path "tar") "zxf" tgz)) + (subprocess-wait p) + (delete-file tgz)) -(define (install-file src dest) - (if (regexp-match? #rx"[.]tgz" (path->string src)) - ;; Unpack tar file: - (unpack-tgz src dest) - ;; Plain copy: - (unless (same-content? src dest) - (printf "Updating ~a\n" dest) - (when (file-exists? dest) (delete-file dest)) - (copy-file src dest)))) +(define (install file) + (cond [(regexp-match? #rx"[.]tgz" file) (unpack-tgz file)] + [else (eprintf "\n") + (raise-user-error 'get-libs "don't know how to install file: ~a" + file)])) -(define (unpack-tgz src* dest) - (define src (path->string (path->complete-path src*))) - (parameterize ([current-directory - (let-values ([(base name dir?) (split-path dest)]) base)]) - (define-values [p pout pin perr] - (subprocess - (current-output-port) (current-input-port) (current-error-port) - (find-executable-path "tar") "zxf" src)) - (subprocess-wait p))) +(define (delete-path path) + (if (directory-exists? path) + (begin (parameterize ([current-directory path]) + (for-each delete-path (directory-list))) + (delete-directory path)) + (delete-file path))) -(case mode - [(#f) (void)] - [(download) - (unless (directory-exists? dest-dir) (make-directory dest-dir)) - (for ([file+size (in-list (needed-files+sizes))]) - (download-if-needed dest-dir (car file+size) (cadr file+size))) - (when touch - (define ok (build-path dest-dir touch)) - (when (file-exists? ok) (delete-file ok)) - (unless (file-exists? ok) (with-output-to-file ok void)))] - [(install) - (for ([file+size (in-list (needed-files+sizes))]) - (define file (car file+size)) - (install-file (build-path src-dir "libs" file) - (build-path dest-dir file)))]) +(define (directory-size dir) + (parameterize ([current-directory dir]) + (for/fold ([sum 0]) ([path (in-list (directory-list))]) + (+ sum (path-size path))))) + +(define (path-size path) + (cond [(file-exists? path) (file-size path)] + [(directory-exists? path) (directory-size path)] + [else 0])) + +(define got-path? ; approximate, using size + (case-lambda [(path size unpacked-path unpacked-size) + (got-path? unpacked-path unpacked-size)] + [(path size) + (equal? size (path-size path))])) + +(unless (eq? package 'nothing) + (unless (directory-exists? dest-dir) (make-directory dest-dir)) + (parameterize ([current-directory dest-dir]) + (define needed (needed-files+sizes)) + (define really-needed + (filter (lambda (n) (not (apply got-path? n))) needed)) + (printf (if (null? needed) + ">> No ~a libraries to download for ~a\n" + ">> Getting ~a libraries for ~a\n") + package architecture) + (cond + [(null? needed) (void)] + [(null? really-needed) + (printf ">> All files present, no downloads needed.\n")] + [else + (printf ">> Downloading files from\n>> ~a~a\n" url-base architecture) + (printf ">> If you don't want automatic download, download each file\n") + (printf ">> yourself from there to\n") + (printf ">> ~a\n" (path->complete-path (current-directory))) + (for ([file+size (in-list needed)]) + (define file (car file+size)) + (define size (cadr file+size)) + (printf " ~a" file) + (if (member file+size really-needed) + (begin (printf " downloading...") (flush-output) + (download file size) + (when (pair? (cddr file+size)) + (delete-path (caddr file+size)) + (install file)) + (printf " done.\n")) + (printf " already exists.\n")))]))) diff --git a/src/gracket/Makefile.in b/src/gracket/Makefile.in index 06435d2f41..dcabb718bd 100644 --- a/src/gracket/Makefile.in +++ b/src/gracket/Makefile.in @@ -75,11 +75,9 @@ bin: $(MAKE) @MAIN_VARIANT@ 3m: - $(MAKE) libs/gui-ready$(DOWNLOAD_BIN_VERSION) cd gc2; $(MAKE) 3m cgc: - $(MAKE) libs/gui-ready$(DOWNLOAD_BIN_VERSION) $(MAKE) $(LINKRESULT) both: @@ -126,9 +124,6 @@ grmain_ee.@LTO@ : gracket.@LTO@ ee-main: $(MAKE) grmain_ee.@LTO@ -libs/gui-ready$(DOWNLOAD_BIN_VERSION): - $(RACKET) -c "$(srcdir)/../get-libs.rkt" --touch gui-ready$(DOWNLOAD_BIN_VERSION) gui "$(srcdir)" libs - clean: rm -f *.@LTO@ *.d core gracket gracket3m rm -f gc2/*.@LTO@ gc2/xsrc/* gc2/macxsrc/* gc2/*.d gc2/*.dd @@ -163,7 +158,7 @@ install-post-collects: $(MAKE) install-@WXVARIANT@-post-collects install-common: - $(RACKET) -c "$(srcdir)/../get-libs.rkt" --install gui . "$(DESTDIR)$(libpltdir)" + $(RACKET) -c "$(srcdir)/../get-libs.rkt" gui "$(DESTDIR)$(libpltdir)" # X11 ---------------------------------------- diff --git a/src/worksp/build.bat b/src/worksp/build.bat index 9fb9b5846a..c9f5c3defd 100644 --- a/src/worksp/build.bat +++ b/src/worksp/build.bat @@ -8,8 +8,8 @@ cd gc2 ..\..\..\racketcgc -cu make.rkt cd .. -..\..\racket -cu ..\get-libs.rkt core ..\racket ..\..\lib -..\..\racket -cu ..\get-libs.rkt gui ..\gracket ..\..\lib +..\..\racket -cu ..\get-libs.rkt core ..\..\lib +..\..\racket -cu ..\get-libs.rkt gui ..\..\lib cd mzstart devenv mzstart.sln /Build Release From 4d2e0e448657a6d109cbf5cbfd68ccb0d8ed0903 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 13 Nov 2010 09:39:51 -0500 Subject: [PATCH 014/255] Fix bug --- src/get-libs.rkt | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/get-libs.rkt b/src/get-libs.rkt index e3c9f42c0a..bfbe14d8ee 100644 --- a/src/get-libs.rkt +++ b/src/get-libs.rkt @@ -163,11 +163,11 @@ file)])) (define (delete-path path) - (if (directory-exists? path) - (begin (parameterize ([current-directory path]) - (for-each delete-path (directory-list))) - (delete-directory path)) - (delete-file path))) + (cond [(directory-exists? path) + (parameterize ([current-directory path]) + (for-each delete-path (directory-list))) + (delete-directory path)] + [(or (file-exists? path) (link-exists? path)) (delete-file path)])) (define (directory-size dir) (parameterize ([current-directory dir]) From d2fe39da339c06c3f7edfe57ea53e5543101957b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 13 Nov 2010 09:54:14 -0700 Subject: [PATCH 015/255] win32: canvas refresh repair --- .../mred/private/wx/common/canvas-mixin.rkt | 2 +- collects/mred/private/wx/win32/canvas.rkt | 53 ++++++++++++------- 2 files changed, 36 insertions(+), 19 deletions(-) diff --git a/collects/mred/private/wx/common/canvas-mixin.rkt b/collects/mred/private/wx/common/canvas-mixin.rkt index 1dbeb28e70..07c4364f6f 100644 --- a/collects/mred/private/wx/common/canvas-mixin.rkt +++ b/collects/mred/private/wx/common/canvas-mixin.rkt @@ -168,7 +168,7 @@ (define flush-box #f) - ;; Periodic flush is needed for Windows and Gtk, where + ;; Periodic flush is needed for Windows, where ;; updates otherwise happen only via the eventspace's queue (define/override (schedule-periodic-backing-flush) (unless flush-box diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index e871aeb2f5..cfaf727abf 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -157,19 +157,20 @@ [hdc (BeginPaint w ps)]) (if for-gl? (queue-paint) - (unless (positive? paint-suspended) - (let* ([hbrush (if no-autoclear? - #f - (if transparent? - background-hbrush - (CreateSolidBrush bg-colorref)))]) - (when hbrush - (let ([r (GetClientRect canvas-hwnd)]) - (FillRect hdc r hbrush)) - (unless transparent? - (DeleteObject hbrush))) - (unless (do-canvas-backing-flush hdc) - (queue-paint))))) + (if (positive? paint-suspended) + (set! suspended-refresh? #t) + (let* ([hbrush (if no-autoclear? + #f + (if transparent? + background-hbrush + (CreateSolidBrush bg-colorref)))]) + (when hbrush + (let ([r (GetClientRect canvas-hwnd)]) + (FillRect hdc r hbrush)) + (unless transparent? + (DeleteObject hbrush))) + (unless (do-canvas-backing-flush hdc) + (queue-paint))))) (EndPaint hdc ps)) 0] [(= msg WM_NCPAINT) @@ -271,22 +272,38 @@ (define/public (do-canvas-backing-flush hdc) (if hdc (do-backing-flush this dc hdc) - (let ([hdc (GetDC canvas-hwnd)]) - (do-backing-flush this dc hdc) - (ReleaseDC canvas-hwnd hdc) - (ValidateRect canvas-hwnd #f)))) + (if (positive? paint-suspended) + ;; suspended => try again later + (schedule-periodic-backing-flush) + ;; not suspended + (let ([hdc (GetDC canvas-hwnd)]) + (do-backing-flush this dc hdc) + (ReleaseDC canvas-hwnd hdc) + ;; We'd like to validate the region that + ;; we just updated, so we can potentially + ;; avoid a redundant refresh. For some reason, + ;; vadilation can cancel an update that hasn't + ;; happened, yet; this problem needs further + ;; invesitigation. + #; + (ValidateRect canvas-hwnd #f))))) (define/public (make-compatible-bitmap w h) (send dc make-backing-bitmap w h)) (define paint-suspended 0) + (define suspended-refresh? #f) (define/public (suspend-paint-handling) (atomically (set! paint-suspended (add1 paint-suspended)))) (define/public (resume-paint-handling) (atomically (unless (zero? paint-suspended) - (set! paint-suspended (sub1 paint-suspended))))) + (set! paint-suspended (sub1 paint-suspended)) + (when (and (zero? paint-suspended) + suspended-refresh?) + (set! suspended-refresh? #f) + (InvalidateRect canvas-hwnd #f #f))))) (define no-autoclear? (memq 'no-autoclear style)) (define transparent? (memq 'transparent style)) From 85c2a333a5a62aba8d72f0372cc6653feb1c6be4 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 13 Nov 2010 13:18:23 -0500 Subject: [PATCH 016/255] fix path to get-libs.rkt --- collects/meta/build/build | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/meta/build/build b/collects/meta/build/build index 547be96757..ec6bd46855 100755 --- a/collects/meta/build/build +++ b/collects/meta/build/build @@ -1356,8 +1356,8 @@ DO_WIN32_BUILD() { build_w32step VSNET "mrstart" _cd "$PLTHOME/lib" - build_w32step RKT "get-libs (gui)" src/get-libs.rkt core - build_w32step RKT "get-libs (gui)" src/get-libs.rkt gui + build_w32step RKT "get-libs (gui)" ../src/get-libs.rkt core + build_w32step RKT "get-libs (gui)" ../src/get-libs.rkt gui separator "win32: Building libraries" _cd "$PLTHOME" From 616647cb178374231a8157813a8c9725cd1892a8 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 14 Nov 2010 06:48:02 -0600 Subject: [PATCH 017/255] drr: remove bad keybindings for next-tab and prev-tag --- collects/drracket/private/rep.rkt | 2 -- 1 file changed, 2 deletions(-) diff --git a/collects/drracket/private/rep.rkt b/collects/drracket/private/rep.rkt index ba5bdf44bb..4c4fedc842 100644 --- a/collects/drracket/private/rep.rkt +++ b/collects/drracket/private/rep.rkt @@ -303,8 +303,6 @@ TODO (send drs-bindings-keymap map-function "f1" "search-help-desk") (send drs-bindings-keymap map-function "c:tab" "next-tab") (send drs-bindings-keymap map-function "c:s:tab" "prev-tab") - (send drs-bindings-keymap map-function "d:s:right" "next-tab") - (send drs-bindings-keymap map-function "d:s:left" "prev-tab") (send drs-bindings-keymap map-function "c:pagedown" "next-tab") (send drs-bindings-keymap map-function "c:pageup" "prev-tab") From 279315b582115b7af4ad4821ca5bfb097c53f83b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 14 Nov 2010 11:38:28 -0700 Subject: [PATCH 018/255] cocoa: fix ffi-use bug --- collects/mred/private/wx/cocoa/finfo.rkt | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/mred/private/wx/cocoa/finfo.rkt b/collects/mred/private/wx/cocoa/finfo.rkt index b4090a9fe8..dad503cb09 100644 --- a/collects/mred/private/wx/cocoa/finfo.rkt +++ b/collects/mred/private/wx/cocoa/finfo.rkt @@ -112,7 +112,7 @@ v #f #f #f)]) (unless (zero? r) - (error 'file-creator-and-file "lookup failed (~a): ~e" + (error 'file-creator-and-type "lookup failed (~a): ~e" r path)))) @@ -122,7 +122,7 @@ (unless (path-string? path) (raise-type-error 'file-creator-and-type "path string" path)) (let ([info (let ([fs (path->fsref path)] - [v (cast (malloc 256) _pointer _FSCatalogInfo-pointer)]) + [v (cast (malloc 256) _pointer (_gcable _FSCatalogInfo-pointer))]) (get-info v fs path) (FSCatalogInfo-finderInfo v))]) (values (int->str (FileInfo-fileCreator info)) @@ -135,7 +135,7 @@ (unless (and (bytes? type) (= 4 (bytes-length type))) (raise-type-error 'file-creator-and-type "bytes string of length 4" type)) (let ([fs (path->fsref path)] - [v (cast (malloc 256) _pointer _FSCatalogInfo-pointer)]) + [v (cast (malloc 256) _pointer (_gcable _FSCatalogInfo-pointer))]) (get-info v fs path) (let ([info (FSCatalogInfo-finderInfo v)]) (set-FileInfo-fileCreator! info (str->int creator)) @@ -144,7 +144,7 @@ kFSCatInfoFinderInfo v)]) (unless (zero? r) - (error 'file-creator-and-file "change failed (~a): ~e" + (error 'file-creator-and-type "change failed (~a): ~e" r path)))) (void)])) From a8b318da7a05d4cb523d3ad1d37a17ea8a510dcd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 14 Nov 2010 11:39:04 -0700 Subject: [PATCH 019/255] fix ffi issue with pointer vs. gcpointer - don't put a non-gcpointer into a pointer array during ffi call setup - fix GCness of pointers to structs inside of structs --- collects/scribblings/foreign/types.scrbl | 15 ++--- src/foreign/foreign.c | 66 ++++++++++++-------- src/foreign/foreign.rktc | 77 +++++++++++++++--------- 3 files changed, 97 insertions(+), 61 deletions(-) diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index dd6691d986..565e97690d 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -814,7 +814,9 @@ The resulting bindings are as follows: an argument for each type.} @item{@schemevarfont{id}@schemeidfont{-}@scheme[field-id] : an accessor - function for each @scheme[field-id].} + function for each @scheme[field-id]; if the field has a cstruct type, then + the result of the accessor is a pointer to the field within the + enclosing structure, rather than a copy of the field.} @item{@schemeidfont{set-}@schemevarfont{id}@schemeidfont{-}@scheme[field-id]@schemeidfont{!} : a mutator function for each @scheme[field-id].} @@ -860,12 +862,11 @@ addition for the new fields. This adjustment of the constructor is, again, in analogy to using a supertype with @scheme[define-struct]. Note that structs are allocated as atomic blocks, which means that the -garbage collector ignores their content. Currently, there is no safe -way to store pointers to GC-managed objects in structs (even if you -keep a reference to avoid collecting the referenced objects, a the 3m -variant's GC will invalidate the pointer's value). Thus, only -non-pointer values and pointers to memory that is outside the GC's -control can be placed into struct fields. +garbage collector ignores their content. Thus, struct fields can hold +only non-pointer values, pointers to memory outside the GC's control, +and otherwise-reachable pointers to immobile GC-managed values (such +as those allocated with @racket[malloc] and @racket['internal] or +@racket['internal-atomic]). As an example, consider the following C code: diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index 5d7f2f8691..d14cb099c0 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -713,7 +713,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) #define FOREIGN_string_ucs_4 (18) /* Type Name: string/ucs-4 (string_ucs_4) - * LibFfi type: ffi_type_pointer + * LibFfi type: ffi_type_gcpointer * C type: mzchar* * Predicate: SCHEME_FALSEP_OR_CHAR_STRINGP() * Scheme->C: ucs4_string_or_null_to_ucs4_pointer() @@ -723,7 +723,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) #define FOREIGN_string_utf_16 (19) /* Type Name: string/utf-16 (string_utf_16) - * LibFfi type: ffi_type_pointer + * LibFfi type: ffi_type_gcpointer * C type: unsigned short* * Predicate: SCHEME_FALSEP_OR_CHAR_STRINGP() * Scheme->C: ucs4_string_or_null_to_utf16_pointer() @@ -736,7 +736,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) #define FOREIGN_bytes (20) /* Type Name: bytes - * LibFfi type: ffi_type_pointer + * LibFfi type: ffi_type_gcpointer * C type: char* * Predicate: SCHEME_FALSEP()||SCHEME_BYTE_STRINGP() * Scheme->C: SCHEME_FALSEP()?NULL:SCHEME_BYTE_STR_VAL() @@ -746,7 +746,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) #define FOREIGN_path (21) /* Type Name: path - * LibFfi type: ffi_type_pointer + * LibFfi type: ffi_type_gcpointer * C type: char* * Predicate: SCHEME_FALSEP()||SCHEME_PATH_STRINGP() * Scheme->C: SCHEME_FALSEP()?NULL:SCHEME_PATH_VAL(TO_PATH()) @@ -843,6 +843,11 @@ typedef union _ForeignAny { /* This is a tag that is used to identify user-made struct types. */ #define FOREIGN_struct (27) +static int is_gcable_pointer(Scheme_Object *o) { + return !SCHEME_CPTRP(o) + || !(SCHEME_CPTR_FLAGS(o) & 0x1); +} + /*****************************************************************************/ /* Type objects */ @@ -1218,6 +1223,9 @@ END_XFORM_SKIP; #define scheme_make_foreign_external_cpointer(x) \ ((x==NULL)?scheme_false:scheme_make_external_cptr(x,NULL)) +#define scheme_make_foreign_offset_external_cpointer(x, delta) \ + ((delta == 0) ? scheme_make_foreign_external_cpointer(x) : scheme_make_offset_external_cptr(x,delta,NULL)) + #define MYNAME "cpointer?" static Scheme_Object *foreign_cpointer_p(int argc, Scheme_Object *argv[]) { @@ -1258,23 +1266,23 @@ void *scheme_extract_pointer(Scheme_Object *v) { * memory location -- deal with it via a C2SCHEME macro wrapper that is used * for both the function definition and calls */ #ifdef SCHEME_BIG_ENDIAN -#define C2SCHEME(typ,src,delta,argsloc) c_to_scheme(typ,src,delta,argsloc) +#define C2SCHEME(typ,src,delta,argsloc,gcsrc) c_to_scheme(typ,src,delta,argsloc,gcsrc) #define REF_CTYPE(ctype) (((sizeof(ctype)Scheme", "C-type", 0, 1, &type); if (CTYPE_USERP(type)) { - res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc); + res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc, gcsrc); if (SCHEME_FALSEP(CTYPE_USER_C2S(type))) return res; else @@ -1309,7 +1317,10 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, case FOREIGN_scheme: return REF_CTYPE(Scheme_Object*); case FOREIGN_fpointer: return (REF_CTYPE(void*)); case FOREIGN_struct: - return scheme_make_foreign_offset_cpointer(src, delta); + if (gcsrc) + return scheme_make_foreign_offset_cpointer(src, delta); + else + return scheme_make_foreign_offset_external_cpointer(src, delta); default: scheme_signal_error("corrupt foreign type: %V", type); } return NULL; /* hush the compiler */ @@ -1556,7 +1567,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) { mzchar* tmp; tmp = (mzchar*)(ucs4_string_or_null_to_ucs4_pointer(val)); - if (basetype_p == NULL || tmp == NULL) { + if (basetype_p == NULL || tmp == NULL || 0) { (((mzchar**)W_OFFSET(dst,delta))[0]) = tmp; return NULL; } else { @@ -1577,7 +1588,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) { unsigned short* tmp; tmp = (unsigned short*)(ucs4_string_or_null_to_utf16_pointer(val)); - if (basetype_p == NULL || tmp == NULL) { + if (basetype_p == NULL || tmp == NULL || 0) { (((unsigned short**)W_OFFSET(dst,delta))[0]) = tmp; return NULL; } else { @@ -1598,7 +1609,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, if (SCHEME_FALSEP(val)||SCHEME_BYTE_STRINGP(val)) { char* tmp; tmp = (char*)(SCHEME_FALSEP(val)?NULL:SCHEME_BYTE_STR_VAL(val)); - if (basetype_p == NULL || tmp == NULL) { + if (basetype_p == NULL || tmp == NULL || 0) { (((char**)W_OFFSET(dst,delta))[0]) = tmp; return NULL; } else { @@ -1619,7 +1630,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, if (SCHEME_FALSEP(val)||SCHEME_PATH_STRINGP(val)) { char* tmp; tmp = (char*)(SCHEME_FALSEP(val)?NULL:SCHEME_PATH_VAL(TO_PATH(val))); - if (basetype_p == NULL || tmp == NULL) { + if (basetype_p == NULL || tmp == NULL || 0) { (((char**)W_OFFSET(dst,delta))[0]) = tmp; return NULL; } else { @@ -1640,7 +1651,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, if (SCHEME_SYMBOLP(val)) { char* tmp; tmp = (char*)(SCHEME_SYM_VAL(val)); - if (basetype_p == NULL || tmp == NULL) { + if (basetype_p == NULL || tmp == NULL || !is_gcable_pointer(val)) { (((char**)W_OFFSET(dst,delta))[0]) = tmp; return NULL; } else { @@ -1663,7 +1674,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, tmp = (void*)(SCHEME_FFIANYPTR_VAL(val)); toff = SCHEME_FFIANYPTR_OFFSET(val); if (_offset) *_offset = toff; - if (basetype_p == NULL || (tmp == NULL && toff == 0)) { + if (basetype_p == NULL || (tmp == NULL && toff == 0) || !is_gcable_pointer(val)) { (((void**)W_OFFSET(dst,delta))[0]) = (_offset ? tmp : (void*)W_OFFSET(tmp, toff)); return NULL; } else { @@ -1686,7 +1697,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, tmp = (void*)(SCHEME_FFIANYPTR_VAL(val)); toff = SCHEME_FFIANYPTR_OFFSET(val); if (_offset) *_offset = toff; - if (basetype_p == NULL || (tmp == NULL && toff == 0)) { + if (basetype_p == NULL || (tmp == NULL && toff == 0) || 0) { (((void**)W_OFFSET(dst,delta))[0]) = (_offset ? tmp : (void*)W_OFFSET(tmp, toff)); return NULL; } else { @@ -1707,7 +1718,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, if (1) { Scheme_Object* tmp; tmp = (Scheme_Object*)(val); - if (basetype_p == NULL || tmp == NULL) { + if (basetype_p == NULL || tmp == NULL || 0) { (((Scheme_Object**)W_OFFSET(dst,delta))[0]) = tmp; return NULL; } else { @@ -2274,12 +2285,14 @@ static Scheme_Object *abs_sym; static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[]) { int size=0; void *ptr; Scheme_Object *base; - long delta; + long delta; int gcsrc=1; if (!SCHEME_FFIANYPTRP(argv[0])) scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); ptr = SCHEME_FFIANYPTR_VAL(argv[0]); delta = SCHEME_FFIANYPTR_OFFSET(argv[0]); + if (!is_gcable_pointer(argv[0])) + gcsrc = 0; if ((ptr == NULL) && (delta == 0)) scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); if (NULL == (base = get_ctype_base(argv[1]))) @@ -2314,7 +2327,7 @@ static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[]) scheme_signal_error(MYNAME": cannot multiply fpointer type by offset"); delta += (size * SCHEME_INT_VAL(argv[2])); } - return C2SCHEME(argv[1], ptr, delta, 0); + return C2SCHEME(argv[1], ptr, delta, 0, gcsrc); } #undef MYNAME @@ -2541,6 +2554,9 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) /* ... set the ivals pointer (pointer type doesn't matter) and avalues */ ivals[i].x_pointer = avalues[i]; avalues[i] = &(ivals[i]); + } else if (offsets[i]) { + /* struct argument has an offset */ + avalues[i] = (char *)avalues[i] + offsets[i]; } /* Otherwise it was a struct pointer, and avalues[i] is already fine. */ /* Add offset, if any: */ @@ -2569,7 +2585,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) } break; } - return C2SCHEME(otype, p, 0, 1); + return C2SCHEME(otype, p, 0, 1, 1); } /* see below */ @@ -2696,7 +2712,7 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata) if (data->sync && !SCHEME_RPAIRP(data->sync)) scheme_start_in_scheduler(); for (i=0, p=data->itypes; iproc, argc, argv); @@ -3345,28 +3361,28 @@ void scheme_init_foreign(Scheme_Env *env) t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); - t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); + t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4); scheme_add_global("_string/ucs-4", (Scheme_Object*)t, menv); s = scheme_intern_symbol("string/utf-16"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); - t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); + t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16); scheme_add_global("_string/utf-16", (Scheme_Object*)t, menv); s = scheme_intern_symbol("bytes"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); - t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); + t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_bytes); scheme_add_global("_bytes", (Scheme_Object*)t, menv); s = scheme_intern_symbol("path"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); - t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); + t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_path); scheme_add_global("_path", (Scheme_Object*)t, menv); s = scheme_intern_symbol("symbol"); diff --git a/src/foreign/foreign.rktc b/src/foreign/foreign.rktc index 3fff7490b1..47ceb4d0c2 100755 --- a/src/foreign/foreign.rktc +++ b/src/foreign/foreign.rktc @@ -664,14 +664,14 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) * meaningless to use NULL. */ @(defctype 'string/ucs-4 - 'ftype "pointer" + 'ftype "gcpointer" 'ctype "mzchar*" 'pred "SCHEME_FALSEP_OR_CHAR_STRINGP" 's->c "ucs4_string_or_null_to_ucs4_pointer" 'c->s "scheme_make_char_string_without_copying") @(defctype 'string/utf-16 - 'ftype "pointer" + 'ftype "gcpointer" 'ctype "unsigned short*" 'pred "SCHEME_FALSEP_OR_CHAR_STRINGP" 's->c "ucs4_string_or_null_to_utf16_pointer" @@ -681,7 +681,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) * (note: these are not like char* which is just a pointer) */ @(defctype 'bytes - 'ftype "pointer" + 'ftype "gcpointer" 'ctype "char*" 'pred (lambda (x aux) @list{SCHEME_FALSEP(@x)||SCHEME_BYTE_STRINGP(@x)}) @@ -692,7 +692,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) scheme_make_byte_string_without_copying(@x)})) @(defctype 'path - 'ftype "pointer" + 'ftype "gcpointer" 'ctype "char*" 'pred (lambda (x aux) @list{SCHEME_FALSEP(@x)||SCHEME_PATH_STRINGP(@x)}) @@ -756,6 +756,11 @@ typedef union _ForeignAny { @; last makes sure this is the last one value that gets used #define FOREIGN_struct (@(type-counter 'last)) +static int is_gcable_pointer(Scheme_Object *o) { + return !SCHEME_CPTRP(o) + || !(SCHEME_CPTR_FLAGS(o) & 0x1); +} + /*****************************************************************************/ /* Type objects */ @@ -1014,6 +1019,9 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym) #define scheme_make_foreign_external_cpointer(x) \ ((x==NULL)?scheme_false:scheme_make_external_cptr(x,NULL)) +#define scheme_make_foreign_offset_external_cpointer(x, delta) \ + ((delta == 0) ? scheme_make_foreign_external_cpointer(x) : scheme_make_offset_external_cptr(x,delta,NULL)) + @cdefine[cpointer? 1]{ return SCHEME_FFIANYPTRP(argv[0]) ? scheme_true : scheme_false; } @@ -1045,23 +1053,23 @@ void *scheme_extract_pointer(Scheme_Object *v) { * memory location -- deal with it via a C2SCHEME macro wrapper that is used * for both the function definition and calls */ #ifdef SCHEME_BIG_ENDIAN -#define C2SCHEME(typ,src,delta,argsloc) c_to_scheme(typ,src,delta,argsloc) +#define C2SCHEME(typ,src,delta,argsloc,gcsrc) c_to_scheme(typ,src,delta,argsloc,gcsrc) #define REF_CTYPE(ctype) (((sizeof(ctype)Scheme", "C-type", 0, 1, &type); if (CTYPE_USERP(type)) { - res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc); + res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc, gcsrc); if (SCHEME_FALSEP(CTYPE_USER_C2S(type))) return res; else @@ -1076,7 +1084,10 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, (if (procedure? c->s) (c->s x) (list c->s"("x")"))) "scheme_void")}) case FOREIGN_struct: - return scheme_make_foreign_offset_cpointer(src, delta); + if (gcsrc) + return scheme_make_foreign_offset_cpointer(src, delta); + else + return scheme_make_foreign_offset_external_cpointer(src, delta); default: scheme_signal_error("corrupt foreign type: %V", type); } @hush @@ -1150,23 +1161,26 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, if (_offset) *_offset = toff;@; @"\n" }]@; @(if ptr? - @list{if (basetype_p == NULL || @; - @(if offset - @list{(tmp == NULL && toff == 0)} - @list{tmp == NULL})) { - @x = @(if offset - @list{(_offset ? tmp : @; - (@ctype)W_OFFSET(tmp, toff))} - "tmp"); - return NULL; - } else { - *basetype_p = FOREIGN_@cname; - return @(if offset - @list{_offset ? tmp : @; - (@ctype)W_OFFSET(tmp, toff)} + @list{if (basetype_p == NULL || @; + @(if offset + @list{(tmp == NULL && toff == 0)} + @list{tmp == NULL}) || @; + @(if (equal? ftype "pointer") + @list{!is_gcable_pointer(val)} + @list{0})) { + @x = @(if offset + @list{(_offset ? tmp : @; + (@ctype)W_OFFSET(tmp, toff))} "tmp"); - }} - @list{@x = tmp@";" return NULL@";"}) + return NULL; + } else { + *basetype_p = FOREIGN_@cname; + return @(if offset + @list{_offset ? tmp : @; + (@ctype)W_OFFSET(tmp, toff)} + "tmp"); + }} + @list{@x = tmp@";" return NULL@";"}) } else { @wrong-type["val" stype]; @hush @@ -1651,12 +1665,14 @@ static Scheme_Object *do_memop(const char *who, int mode, /* WARNING: there are *NO* checks at all, this is raw C level code. */ @cdefine[ptr-ref 2 4]{ int size=0; void *ptr; Scheme_Object *base; - long delta; + long delta; int gcsrc=1; if (!SCHEME_FFIANYPTRP(argv[0])) scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); ptr = SCHEME_FFIANYPTR_VAL(argv[0]); delta = SCHEME_FFIANYPTR_OFFSET(argv[0]); + if (!is_gcable_pointer(argv[0])) + gcsrc = 0; if ((ptr == NULL) && (delta == 0)) scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); if (NULL == (base = get_ctype_base(argv[1]))) @@ -1691,7 +1707,7 @@ static Scheme_Object *do_memop(const char *who, int mode, scheme_signal_error(MYNAME": cannot multiply fpointer type by offset"); delta += (size * SCHEME_INT_VAL(argv[2])); } - return C2SCHEME(argv[1], ptr, delta, 0); + return C2SCHEME(argv[1], ptr, delta, 0, gcsrc); } /* (ptr-set! cpointer type [['abs] n] value) -> void */ @@ -1909,6 +1925,9 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) /* ... set the ivals pointer (pointer type doesn't matter) and avalues */ ivals[i].x_pointer = avalues[i]; avalues[i] = &(ivals[i]); + } else if (offsets[i]) { + /* struct argument has an offset */ + avalues[i] = (char *)avalues[i] + offsets[i]; } /* Otherwise it was a struct pointer, and avalues[i] is already fine. */ /* Add offset, if any: */ @@ -1937,7 +1956,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) } break; } - return C2SCHEME(otype, p, 0, 1); + return C2SCHEME(otype, p, 0, 1, 1); } /* see below */ @@ -2061,7 +2080,7 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata) if (data->sync && !SCHEME_RPAIRP(data->sync)) scheme_start_in_scheduler(); for (i=0, p=data->itypes; iproc, argc, argv); From 16b75b1f0044d3352bb2ba0e8f7031b8279cf4c0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 14 Nov 2010 15:46:41 -0700 Subject: [PATCH 020/255] cocoa: avoid explicit NSTabViewDelegate --- not in pre-10.6, seems to crash in 64-bit mode, and not necessary to declare Closes PR 11418 --- collects/mred/private/wx/cocoa/README.txt | 2 +- collects/mred/private/wx/cocoa/tab-panel.rkt | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/mred/private/wx/cocoa/README.txt b/collects/mred/private/wx/cocoa/README.txt index b989a69751..df66a5c0a3 100644 --- a/collects/mred/private/wx/cocoa/README.txt +++ b/collects/mred/private/wx/cocoa/README.txt @@ -3,7 +3,7 @@ Allocation rules: * Use `as-objc-allocation' when creating a Cocoa object. When the resulting reference becomes unreachable, the Cocoa object will be - releaset. + released. * Use `with-autorelease' in atomic mode around calls that autorelease and where the release should take effect immediate. Do not create diff --git a/collects/mred/private/wx/cocoa/tab-panel.rkt b/collects/mred/private/wx/cocoa/tab-panel.rkt index 62a22c5eba..d67e669e69 100644 --- a/collects/mred/private/wx/cocoa/tab-panel.rkt +++ b/collects/mred/private/wx/cocoa/tab-panel.rkt @@ -28,7 +28,6 @@ (define-objc-class MyTabView NSTabView #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) - #:protocols (NSTabViewDelegate) [wxb] (-a _void (tabView: [_id cocoa] didSelectTabViewItem: [_id item-cocoa]) (queue-window*-event wxb (lambda (wx) (send wx do-callback))))) @@ -50,7 +49,8 @@ (define tabv-cocoa (as-objc-allocation (tell (tell MyTabView alloc) init))) (define cocoa (if (not (memq 'border style)) - (tell (tell NSView alloc) init) + (as-objc-allocation + (tell (tell NSView alloc) init)) tabv-cocoa)) (define control-cocoa From c8eb07221d7b51234b5cc5a9a74aaf8c4da46cb9 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Sun, 14 Nov 2010 18:40:41 -0700 Subject: [PATCH 021/255] use uppercase --- collects/string-constants/english-string-constants.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/string-constants/english-string-constants.rkt b/collects/string-constants/english-string-constants.rkt index 41580aeff3..a2f11e19f1 100644 --- a/collects/string-constants/english-string-constants.rkt +++ b/collects/string-constants/english-string-constants.rkt @@ -448,8 +448,8 @@ please adhere to these guidelines: (show-interactions-on-execute "Automatically open interactions window when running a program") (switch-to-module-language-automatically "Automatically switch to the module language when opening a module") (interactions-beside-definitions "Put the interactions window beside the definitions window") ;; in preferences, below the checkbox one line above this one - (show-line-numbers "Show line numbers") - (hide-line-numbers "Hide line numbers") + (show-line-numbers "Show Line Numbers") + (hide-line-numbers "Hide Line Numbers") (limit-interactions-size "Limit interactions size") (background-color "Background Color") (default-text-color "Default text") ;; used for configuring colors, but doesn't need the word "color" From cd4e5e7410f154cd4cb3b97e1c4aaab2bde6d78e Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Sun, 14 Nov 2010 19:33:12 -0700 Subject: [PATCH 022/255] move line numbers option from general to editing->general --- collects/drracket/private/main.rkt | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/collects/drracket/private/main.rkt b/collects/drracket/private/main.rkt index 74bb8e7837..b8bfe6096a 100644 --- a/collects/drracket/private/main.rkt +++ b/collects/drracket/private/main.rkt @@ -316,17 +316,7 @@ (make-check-box 'drracket:open-in-tabs (string-constant open-files-in-tabs) editor-panel) - (make-check-box 'drracket:show-line-numbers? - (string-constant show-line-numbers) - editor-panel - (lambda (value) - (define (drracket:frame? frame) - (and (is-a? frame top-level-window<%>) - (is-a? frame drracket:unit:frame%))) - ;; is it a hack to use `get-top-level-windows' ? - (define frames (filter drracket:frame? (get-top-level-windows))) - (when (not (null? frames)) - (send (car frames) show-line-numbers! value)))) + (make-check-box 'drracket:show-interactions-on-execute (string-constant show-interactions-on-execute) @@ -346,7 +336,17 @@ (preferences:add-to-editor-checkbox-panel (λ (editor-panel) - (void) + (make-check-box 'drracket:show-line-numbers? + (string-constant show-line-numbers) + editor-panel + (lambda (value) + (define (drracket:frame? frame) + (and (is-a? frame top-level-window<%>) + (is-a? frame drracket:unit:frame%))) + ;; is it a hack to use `get-top-level-windows' ? + (define frames (filter drracket:frame? (get-top-level-windows))) + (when (not (null? frames)) + (send (car frames) show-line-numbers! value)))) ;; come back to this one. #; From ee62bae74be7c59479a19ac4b81fed1c03df90b9 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Sun, 14 Nov 2010 19:44:42 -0700 Subject: [PATCH 023/255] save/restore dc state while drawing line numbers --- collects/framework/private/text.rkt | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 1fed712030..63d514e045 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -3756,6 +3756,17 @@ designates the character that triggers autocompletion (and (>= what low) (<= what high))) + (define-struct saved-dc-state (pen font foreground-color)) + (define (save-dc-state dc) + (saved-dc-state (send dc get-pen) + (send dc get-font) + (send dc get-text-foreground))) + + (define (restore-dc-state dc dc-state) + (send dc set-pen (saved-dc-state-pen dc-state)) + (send dc set-font (saved-dc-state-font dc-state)) + (send dc set-text-foreground (saved-dc-state-foreground-color dc-state))) + ;; set the dc stuff to values we want (define (setup-dc dc) (send dc set-pen "black" 1 'solid) @@ -3859,6 +3870,7 @@ designates the character that triggers autocompletion (define (draw-separator dc top bottom dx dy x) (send dc draw-line (+ dx x) (+ dy top) (+ dx x) (+ dy bottom))) + ;; `line-numbers-space' will get mutated in the `on-paint' method (define line-numbers-space 0) (define/override (find-position x y . args) ;; adjust x position to account for line numbers @@ -3867,6 +3879,7 @@ designates the character that triggers autocompletion (super find-position x y . args))) (define (draw-line-numbers dc left top right bottom dx dy) + (define saved-dc (save-dc-state dc)) (setup-dc dc) (define start-line (box 0)) (define end-line (box 0)) @@ -3874,7 +3887,8 @@ designates the character that triggers autocompletion ;; draw it! (draw-numbers dc top bottom dx dy (unbox start-line) (add1 (unbox end-line))) - (draw-separator dc top bottom dx dy (text-width dc (number-space)))) + (draw-separator dc top bottom dx dy (text-width dc (number-space))) + (restore-dc-state dc saved-dc)) (define (text-width dc stuff) (define-values (font-width font-height baseline space) @@ -3897,14 +3911,17 @@ designates the character that triggers autocompletion ;; will probably go away when 'margin's are added to editors ;; ;; save old origin and push it to the right a little bit - ;; TODO: maybe allow the line numbers to be drawn on the right hand side? + ;; TODO: maybe allow the line numbers to be drawn on the right hand side + ;; of the editor? (define-values (x y) (send dc get-origin)) (set! old-origin-x x) (set! old-origin-y y) (set! old-clipping (send dc get-clipping-region)) + (define saved-dc (save-dc-state dc)) (setup-dc dc) (define-values (font-width font-height baseline space) (send dc get-text-extent (number-space))) + (restore-dc-state dc saved-dc) (define clipped (make-object region% dc)) (define all (make-object region% dc)) (define copy (make-object region% dc)) From 8946d71d66cc3bbcb9e988dc542d30a98de4caaf Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 14 Nov 2010 20:40:07 -0500 Subject: [PATCH 024/255] Use the expected installed name instead of the downloaded name when applicable. --- collects/meta/dist-specs.rkt | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/collects/meta/dist-specs.rkt b/collects/meta/dist-specs.rkt index c47fe9828a..51fd7a2158 100644 --- a/collects/meta/dist-specs.rkt +++ b/collects/meta/dist-specs.rkt @@ -321,7 +321,10 @@ get-libs: := 'all-files+sizes))] [xs (or (assq p xs) (error 'get-libs "unknown package, ~s" p))] [xs (append-map cdr (cdr xs))] - [xs (remove-duplicates (map car xs))]) + [xs (map (lambda (x) + (if (>= (length xs) 3) (list-ref xs 2) (car xs))) + xs)] + [xs (remove-duplicates xs)]) `(lib: ,@xs))) ;; ============================================================================ From 6ae159e8beb9204047a0d465239b15a5934c440d Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 15 Nov 2010 00:04:11 -0500 Subject: [PATCH 025/255] typo --- collects/meta/dist-specs.rkt | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/collects/meta/dist-specs.rkt b/collects/meta/dist-specs.rkt index 51fd7a2158..ece9509c83 100644 --- a/collects/meta/dist-specs.rkt +++ b/collects/meta/dist-specs.rkt @@ -321,8 +321,7 @@ get-libs: := 'all-files+sizes))] [xs (or (assq p xs) (error 'get-libs "unknown package, ~s" p))] [xs (append-map cdr (cdr xs))] - [xs (map (lambda (x) - (if (>= (length xs) 3) (list-ref xs 2) (car xs))) + [xs (map (lambda (x) (if (>= (length x) 3) (list-ref x 2) (car x))) xs)] [xs (remove-duplicates xs)]) `(lib: ,@xs))) From 6c844ec41555d3ef381024d43993d16da85db5fc Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 14 Nov 2010 18:10:00 -0700 Subject: [PATCH 026/255] cocoa: adjust button shape for large fonts --- collects/mred/private/wx/cocoa/button.rkt | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt index 48e97919a6..94cf0f6a72 100644 --- a/collects/mred/private/wx/cocoa/button.rkt +++ b/collects/mred/private/wx/cocoa/button.rkt @@ -66,12 +66,18 @@ (string? label)) (when font (let ([n (send font get-point-size)]) + ;; If the font is small, adjust the control size: (when (n . < . sys-font-size) (tellv (tell cocoa cell) setControlSize: #:type _int (if (n . < . (- sys-font-size 2)) NSMiniControlSize - NSSmallControlSize))))) + NSSmallControlSize)) + (tellv cocoa sizeToFit)) + ;; If the font is big, use a scalable control shape: + (when (n . > . (+ sys-font-size 2)) + (tellv cocoa setBezelStyle: #:type _int NSRegularSquareBezelStyle) + (tellv cocoa sizeToFit)))) (let ([frame (tell #:type _NSRect cocoa frame)]) (tellv cocoa setFrame: #:type _NSRect (make-NSRect (NSRect-origin frame) From f050f28d2b10832630dcd933e53bc13b602b477a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 15 Nov 2010 19:46:41 -0700 Subject: [PATCH 027/255] cocoa: fix put-file extension handling when no extensions are supplied --- collects/mred/private/wx/cocoa/filedialog.rkt | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/collects/mred/private/wx/cocoa/filedialog.rkt b/collects/mred/private/wx/cocoa/filedialog.rkt index 22d161ac46..d73cc60d0a 100644 --- a/collects/mred/private/wx/cocoa/filedialog.rkt +++ b/collects/mred/private/wx/cocoa/filedialog.rkt @@ -41,11 +41,11 @@ (let ([a (tell NSArray arrayWithObjects: #:type (_list i _NSString) extensions count: #:type _NSUInteger (length extensions))]) - (tellv ns setAllowedFileTypes: a)))) - (let ([others? (ormap (lambda (e) - (equal? (cadr e) "*.*")) - filters)]) - (tellv ns setAllowsOtherFileTypes: #:type _BOOL others?)) + (tellv ns setAllowedFileTypes: a)) + (let ([others? (ormap (lambda (e) + (equal? (cadr e) "*.*")) + filters)]) + (tellv ns setAllowsOtherFileTypes: #:type _BOOL others?)))) (cond [(memq 'multi style) From 58188ad0c67b61d6241a0b57d73c7757b6be4dd8 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Mon, 15 Nov 2010 22:31:51 -0700 Subject: [PATCH 028/255] add queue-count --- collects/data/queue.rkt | 12 ++++++++++-- collects/data/scribblings/queue.scrbl | 13 +++++++++++++ collects/tests/data/queue.rkt | 15 +++++++++++++++ 3 files changed, 38 insertions(+), 2 deletions(-) diff --git a/collects/data/queue.rkt b/collects/data/queue.rkt index 6c733178d1..cec99343e9 100644 --- a/collects/data/queue.rkt +++ b/collects/data/queue.rkt @@ -1,6 +1,6 @@ #lang racket/base -;; A Queue contains a linked list with mutable cdrs, hoding two pointers +;; A Queue contains a linked list with mutable cdrs, holding two pointers ;; to the head and the tail -- where items are pulled from the head and ;; pushed on the tail. It is not thread safe: mutating a queue from ;; different threads can break it. @@ -31,6 +31,13 @@ (set-queue-head! q (link-tail old)) (link-value old))) +(define (queue-count queue) + (let loop ([link (queue-head queue)] + [count 0]) + (if (not link) + count + (loop (link-tail link) (add1 count))))) + ;; --- contracts --- (require racket/contract) @@ -48,6 +55,7 @@ [nonempty-queue/c flat-contract?] [queue? (-> any/c boolean?)] [make-queue (-> queue/c)] - [queue-empty? (-> queue/c boolean?)]) + [queue-empty? (-> queue/c boolean?)] + [queue-count (-> queue/c integer?)]) (provide enqueue! dequeue!) diff --git a/collects/data/scribblings/queue.scrbl b/collects/data/scribblings/queue.scrbl index b6f8ecd850..2849090fbf 100644 --- a/collects/data/scribblings/queue.scrbl +++ b/collects/data/scribblings/queue.scrbl @@ -34,6 +34,19 @@ thread-unsafe way. (dequeue! q)] } +@defproc[(queue-count [queue queue/c]) integer?]{ + Returns the number of elements in the queue. + + @defexamples[#:eval qeval + (define queue (make-queue)) + (queue-count queue) + (enqueue! queue 5) + (enqueue! queue 12) + (queue-count queue) + (dequeue! queue) + (queue-count queue)] +} + @defproc[(queue-empty? [q queue/c]) boolean?]{ Recognizes whether a queue is empty or not. diff --git a/collects/tests/data/queue.rkt b/collects/tests/data/queue.rkt index 1174f1fef2..1b8eeb318e 100644 --- a/collects/tests/data/queue.rkt +++ b/collects/tests/data/queue.rkt @@ -34,6 +34,21 @@ (dequeue! q) (dequeue! q) (check-true (queue-empty? q))))) + (test-suite "count" + (test-case "count empty" + (let* ([queue (make-queue)]) + (check-equal? (queue-count queue) 0))) + (test-case "count enqueue once" + (let* ([queue (make-queue)]) + (enqueue! queue 5) + (check-equal? (queue-count queue) 1))) + (test-case "count enqueue thrice dequeue once" + (let* ([queue (make-queue)]) + (enqueue! queue 5) + (enqueue! queue 9) + (enqueue! queue 12) + (dequeue! queue) + (check-equal? (queue-count queue) 2)))) (test-suite "dequeue!" (test-case "make-queue" (check-exn exn:fail? (lambda () (dequeue! (make-queue))))) From 7b612090698a07aadff573a09a4de8ab861ab708 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 16 Nov 2010 12:35:10 -0500 Subject: [PATCH 029/255] Updated version of sigplanconf.cls --- collects/scribble/sigplan/sigplanconf.cls | 928 +++++++++++----------- 1 file changed, 455 insertions(+), 473 deletions(-) diff --git a/collects/scribble/sigplan/sigplanconf.cls b/collects/scribble/sigplan/sigplanconf.cls index a5891f7561..318a5b6a76 100644 --- a/collects/scribble/sigplan/sigplanconf.cls +++ b/collects/scribble/sigplan/sigplanconf.cls @@ -20,18 +20,18 @@ \NeedsTeXFormat{LaTeX2e}[1995/12/01] -\ProvidesClass{sigplanconf}[2009/04/29 v1.9 ACM SIGPLAN Proceedings] +\ProvidesClass{sigplanconf}[2007/03/13 v1.5 ACM SIGPLAN Proceedings] % The following few pages contain LaTeX programming extensions adapted % from the ZzTeX macro package. - + % Token Hackery % ----- ------- \def \@expandaftertwice {\expandafter\expandafter\expandafter} \def \@expandafterthrice {\expandafter\expandafter\expandafter\expandafter - \expandafter\expandafter\expandafter} + \expandafter\expandafter\expandafter} % This macro discards the next token. @@ -49,17 +49,17 @@ % Usage: \expandafter\@defof \meaning\macro\@mark \def \@defof #1:->#2\@mark{#2} - + % Control Sequence Names % ------- -------- ----- \def \@name #1{% {\tokens} - \csname \expandafter\@discardtok \string#1\endcsname} + \csname \expandafter\@discardtok \string#1\endcsname} \def \@withname #1#2{% {\command}{\tokens} - \expandafter#1\csname \expandafter\@discardtok \string#2\endcsname} - + \expandafter#1\csname \expandafter\@discardtok \string#2\endcsname} + % Flags (Booleans) % ----- ---------- @@ -70,7 +70,7 @@ \def \@false {FL} \def \@setflag #1=#2{\edef #1{#2}}% \flag = boolean - + % IF and Predicates % -- --- ---------- @@ -99,7 +99,7 @@ \def \@oddp #1{\ifodd #1\@true \else \@false \fi} \def \@evenp #1{\ifodd #1\@false \else \@true \fi} \def \@rangep #1#2#3{\if \@orp{\@lssp{#1}{#2}}{\@gtrp{#1}{#3}}\@false \else - \@true \fi} + \@true \fi} \def \@tensp #1{\@rangep{#1}{10}{19}} \def \@dimeqlp #1#2{\ifdim #1 = #2\@true \else \@false \fi} @@ -124,25 +124,25 @@ \long\def \@xtokeqlp #1#2{\expandafter\ifx #1#2\@true \else \@false \fi} \long\def \@definedp #1{% - \expandafter\ifx \csname \expandafter\@discardtok \string#1\endcsname - \relax \@false \else \@true \fi} + \expandafter\ifx \csname \expandafter\@discardtok \string#1\endcsname + \relax \@false \else \@true \fi} \long\def \@undefinedp #1{% - \expandafter\ifx \csname \expandafter\@discardtok \string#1\endcsname - \relax \@true \else \@false \fi} + \expandafter\ifx \csname \expandafter\@discardtok \string#1\endcsname + \relax \@true \else \@false \fi} \def \@emptydefp #1{\ifx #1\@empty \@true \else \@false \fi}% {\name} \let \@emptylistp = \@emptydefp \long\def \@emptyargp #1{% {#n} - \@empargp #1\@empargq\@mark} + \@empargp #1\@empargq\@mark} \long\def \@empargp #1#2\@mark{% - \ifx #1\@empargq \@true \else \@false \fi} + \ifx #1\@empargq \@true \else \@false \fi} \def \@empargq {\@empargq} \def \@emptytoksp #1{% {\tokenreg} - \expandafter\@emptoksp \the#1\@mark} + \expandafter\@emptoksp \the#1\@mark} \long\def \@emptoksp #1\@mark{\@emptyargp{#1}} @@ -163,30 +163,30 @@ \def \@notp #1{\if #1\@false \else \@true \fi} \def \@andp #1#2{\if #1% - \if #2\@true \else \@false \fi - \else - \@false - \fi} + \if #2\@true \else \@false \fi + \else + \@false + \fi} \def \@orp #1#2{\if #1% - \@true - \else - \if #2\@true \else \@false \fi - \fi} - -\def \@xorp #1#2{\if #1% - \if #2\@false \else \@true \fi + \@true \else \if #2\@true \else \@false \fi \fi} +\def \@xorp #1#2{\if #1% + \if #2\@false \else \@true \fi + \else + \if #2\@true \else \@false \fi + \fi} + % Arithmetic % ---------- \def \@increment #1{\advance #1 by 1\relax}% {\count} \def \@decrement #1{\advance #1 by -1\relax}% {\count} - + % Options % ------- @@ -207,16 +207,16 @@ % Note that all the dangerous article class options are trapped. \DeclareOption{9pt}{\@setflag \@ninepoint = \@true - \@setflag \@explicitsize = \@true} + \@setflag \@explicitsize = \@true} \DeclareOption{10pt}{\PassOptionsToClass{10pt}{article}% - \@setflag \@ninepoint = \@false - \@setflag \@tenpoint = \@true - \@setflag \@explicitsize = \@true} + \@setflag \@ninepoint = \@false + \@setflag \@tenpoint = \@true + \@setflag \@explicitsize = \@true} \DeclareOption{11pt}{\PassOptionsToClass{11pt}{article}% - \@setflag \@ninepoint = \@false - \@setflag \@explicitsize = \@true} + \@setflag \@ninepoint = \@false + \@setflag \@explicitsize = \@true} \DeclareOption{12pt}{\@unsupportedoption{12pt}} @@ -252,7 +252,7 @@ \DeclareOption{numberedpars}{\@numheaddepth = 4} -%%%\DeclareOption{onecolumn}{\@setflag \@onecolumn = \@true} +\DeclareOption{onecolumn}{\@setflag \@onecolumn = \@true} \DeclareOption{preprint}{\@setflag \@preprint = \@true} @@ -271,34 +271,34 @@ \ProcessOptions \if \@onecolumn - \if \@notp{\@explicitsize}% - \@setflag \@ninepoint = \@false - \PassOptionsToClass{11pt}{article}% - \fi - \PassOptionsToClass{twoside,onecolumn}{article} + \if \@notp{\@explicitsize}% + \@setflag \@ninepoint = \@false + \PassOptionsToClass{11pt}{article}% + \fi + \PassOptionsToClass{twoside,onecolumn}{article} \else - \PassOptionsToClass{twoside,twocolumn}{article} + \PassOptionsToClass{twoside,twocolumn}{article} \fi \LoadClass{article} \def \@unsupportedoption #1{% - \ClassError{proc}{The standard '#1' option is not supported.}} + \ClassError{proc}{The standard '#1' option is not supported.}} % This can be used with the 'reprint' option to get the final folios. \def \setpagenumber #1{% - \setcounter{page}{#1}} + \setcounter{page}{#1}} \AtEndDocument{\label{sigplanconf@finalpage}} - + % Utilities % --------- \newcommand{\setvspace}[2]{% - #1 = #2 - \advance #1 by -1\parskip} - + #1 = #2 + \advance #1 by -1\parskip} + % Document Parameters % -------- ---------- @@ -313,11 +313,11 @@ \setlength{\headsep}{0pt} \if \@onecolumn - \setlength{\evensidemargin}{.75in} - \setlength{\oddsidemargin}{.75in} + \setlength{\evensidemargin}{.75in} + \setlength{\oddsidemargin}{.75in} \else - \setlength{\evensidemargin}{.75in} - \setlength{\oddsidemargin}{.75in} + \setlength{\evensidemargin}{.75in} + \setlength{\oddsidemargin}{.75in} \fi % Text area: @@ -326,9 +326,9 @@ \setlength{\standardtextwidth}{42pc} \if \@onecolumn - \setlength{\textwidth}{40.5pc} + \setlength{\textwidth}{20pc} \else - \setlength{\textwidth}{\standardtextwidth} + \setlength{\textwidth}{\standardtextwidth} \fi \setlength{\topskip}{8pt} @@ -342,11 +342,11 @@ % Paragraphs: \if \@blockstyle - \setlength{\parskip}{5pt plus .1pt minus .5pt} - \setlength{\parindent}{0pt} + \setlength{\parskip}{5pt plus .1pt minus .5pt} + \setlength{\parindent}{0pt} \else - \setlength{\parskip}{0pt} - \setlength{\parindent}{12pt} + \setlength{\parskip}{0pt} + \setlength{\parindent}{12pt} \fi \setlength{\lineskip}{.5pt} @@ -376,10 +376,10 @@ \setlength{\footnotesep}{9pt} \renewcommand{\footnoterule}{% - \hrule width .5\columnwidth height .33pt depth 0pt} + \hrule width .5\columnwidth height .33pt depth 0pt} \renewcommand{\@makefntext}[1]{% - \noindent \@makefnmark \hspace{1pt}#1} + \noindent \@makefnmark \hspace{1pt}#1} % Floats: @@ -409,48 +409,48 @@ % Miscellaneous: \errorcontextlines = 5 - + % Fonts % ----- \if \@times - \renewcommand{\rmdefault}{ptm}% - \if \@mathtime - \usepackage[mtbold,noTS1]{mathtime}% - \else + \renewcommand{\rmdefault}{ptm}% + \if \@mathtime + \usepackage[mtbold,noTS1]{mathtime}% + \else %%% \usepackage{mathptm}% - \fi + \fi \else - \relax + \relax \fi \if \@ninepoint \renewcommand{\normalsize}{% - \@setfontsize{\normalsize}{9pt}{10pt}% - \setlength{\abovedisplayskip}{5pt plus 1pt minus .5pt}% - \setlength{\belowdisplayskip}{\abovedisplayskip}% - \setlength{\abovedisplayshortskip}{3pt plus 1pt minus 2pt}% - \setlength{\belowdisplayshortskip}{\abovedisplayshortskip}} + \@setfontsize{\normalsize}{9pt}{10pt}% + \setlength{\abovedisplayskip}{5pt plus 1pt minus .5pt}% + \setlength{\belowdisplayskip}{\abovedisplayskip}% + \setlength{\abovedisplayshortskip}{3pt plus 1pt minus 2pt}% + \setlength{\belowdisplayshortskip}{\abovedisplayshortskip}} \renewcommand{\tiny}{\@setfontsize{\tiny}{5pt}{6pt}} \renewcommand{\scriptsize}{\@setfontsize{\scriptsize}{7pt}{8pt}} \renewcommand{\small}{% - \@setfontsize{\small}{8pt}{9pt}% - \setlength{\abovedisplayskip}{4pt plus 1pt minus 1pt}% - \setlength{\belowdisplayskip}{\abovedisplayskip}% - \setlength{\abovedisplayshortskip}{2pt plus 1pt}% - \setlength{\belowdisplayshortskip}{\abovedisplayshortskip}} + \@setfontsize{\small}{8pt}{9pt}% + \setlength{\abovedisplayskip}{4pt plus 1pt minus 1pt}% + \setlength{\belowdisplayskip}{\abovedisplayskip}% + \setlength{\abovedisplayshortskip}{2pt plus 1pt}% + \setlength{\belowdisplayshortskip}{\abovedisplayshortskip}} \renewcommand{\footnotesize}{% - \@setfontsize{\footnotesize}{8pt}{9pt}% - \setlength{\abovedisplayskip}{4pt plus 1pt minus .5pt}% - \setlength{\belowdisplayskip}{\abovedisplayskip}% - \setlength{\abovedisplayshortskip}{2pt plus 1pt}% - \setlength{\belowdisplayshortskip}{\abovedisplayshortskip}} + \@setfontsize{\footnotesize}{8pt}{9pt}% + \setlength{\abovedisplayskip}{4pt plus 1pt minus .5pt}% + \setlength{\belowdisplayskip}{\abovedisplayskip}% + \setlength{\abovedisplayshortskip}{2pt plus 1pt}% + \setlength{\belowdisplayshortskip}{\abovedisplayshortskip}} \renewcommand{\large}{\@setfontsize{\large}{11pt}{13pt}} @@ -471,52 +471,53 @@ \relax \fi\fi - + % Abstract % -------- \renewenvironment{abstract}{% - \section*{Abstract}% - \normalsize}{% - } - + \section*{Abstract}% + \normalsize}{% + } + % Bibliography % ------------ \renewenvironment{thebibliography}[1] - {\section*{\refname - \@mkboth{\MakeUppercase\refname}{\MakeUppercase\refname}}% - \list{\@biblabel{\@arabic\c@enumiv}}% - {\settowidth\labelwidth{\@biblabel{#1}}% - \leftmargin\labelwidth - \advance\leftmargin\labelsep - \@openbib@code - \usecounter{enumiv}% - \let\p@enumiv\@empty - \renewcommand\theenumiv{\@arabic\c@enumiv}}% - \bibfont - \softraggedright%%%\sloppy - \clubpenalty4000 - \@clubpenalty \clubpenalty - \widowpenalty4000% - \sfcode`\.\@m} - {\def\@noitemerr - {\@latex@warning{Empty `thebibliography' environment}}% - \endlist} + {\section*{\refname + \@mkboth{\MakeUppercase\refname}{\MakeUppercase\refname}}% + \list{\@biblabel{\@arabic\c@enumiv}}% + {\settowidth\labelwidth{\@biblabel{#1}}% + \leftmargin\labelwidth + \advance\leftmargin\labelsep + \@openbib@code + \usecounter{enumiv}% + \let\p@enumiv\@empty + \renewcommand\theenumiv{\@arabic\c@enumiv}}% + \bibfont + \softraggedright%%%\sloppy + \clubpenalty4000 + \@clubpenalty \clubpenalty + \widowpenalty4000% + \sfcode`\.\@m} + {\def\@noitemerr + {\@latex@warning{Empty `thebibliography' environment}}% + \endlist} \if \@natbib \usepackage{natbib} \setlength{\bibsep}{3pt plus .5pt minus .25pt} -\bibpunct{[}{]}{,}{A}{}{,} +\bibpunct{(}{)}{;}{A}{}{,} +\let \ncite = \cite \let \cite = \citep \fi \def \bibfont {\small} - + % Categories % ---------- @@ -524,25 +525,25 @@ \@setflag \@firstcategory = \@true \newcommand{\category}[3]{% - \if \@firstcategory - \paragraph*{Categories and Subject Descriptors}% - \@setflag \@firstcategory = \@false - \else - \unskip ;\hspace{.75em}% - \fi - \@ifnextchar [{\@category{#1}{#2}{#3}}{\@category{#1}{#2}{#3}[]}} + \if \@firstcategory + \paragraph*{Categories and Subject Descriptors}% + \@setflag \@firstcategory = \@false + \else + \unskip ;\hspace{.75em}% + \fi + \@ifnextchar [{\@category{#1}{#2}{#3}}{\@category{#1}{#2}{#3}[]}} \def \@category #1#2#3[#4]{% - {\let \and = \relax - #1 [\textit{#2}]% - \if \@emptyargp{#4}% - \if \@notp{\@emptyargp{#3}}: #3\fi - \else - :\space - \if \@notp{\@emptyargp{#3}}#3---\fi - \textrm{#4}% - \fi}} - + {\let \and = \relax + #1 [\textit{#2}]% + \if \@emptyargp{#4}% + \if \@notp{\@emptyargp{#3}}: #3\fi + \else + :\space + \if \@notp{\@emptyargp{#3}}#3---\fi + \textrm{#4}% + \fi}} + % Copyright Notice % --------- ------ @@ -550,125 +551,120 @@ \def \ftype@copyrightbox {8} \def \@toappear {} \def \@permission {} -\def \@reprintprice {} \def \@copyrightspace {% - \@float{copyrightbox}[b]% - \vbox to 1in{% - \vfill - \parbox[b]{20pc}{% - \scriptsize - \if \@preprint - [Copyright notice will appear here - once 'preprint' option is removed.]\par - \else - \@toappear - \fi - \if \@reprint - \noindent Reprinted from \@conferencename, - \@proceedings, - \@conferenceinfo, - pp.~\number\thepage--\pageref{sigplanconf@finalpage}.\par - \fi}}% - \end@float} + \@float{copyrightbox}[b]% + \vbox to 1in{% + \vfill + \parbox[b]{20pc}{% + \scriptsize + \if \@preprint + [Copyright notice will appear here + once 'preprint' option is removed.]\par + \else + \@toappear + \fi + \if \@reprint + \noindent Reprinted from \@conferencename, + \@proceedings, + \@conferenceinfo, + pp.~\number\thepage--\pageref{sigplanconf@finalpage}.\par + \fi}}% + \end@float} \long\def \toappear #1{% - \def \@toappear {#1}} + \def \@toappear {#1}} \toappear{% - \noindent \@permission \par - \vspace{2pt} - \noindent \textsl{\@conferencename}\quad \@conferenceinfo \par - \noindent Copyright \copyright\ \@copyrightyear\ ACM \@copyrightdata - \dots \@reprintprice\par} - -\newcommand{\reprintprice}[1]{% - \gdef \@reprintprice {#1}} -\reprintprice{\$10.00} + \noindent \@permission \par + \vspace{2pt} + \noindent \textsl{\@conferencename}\quad \@conferenceinfo \par + \noindent Copyright \copyright\ \@copyrightyear\ ACM \@copyrightdata + \dots \$5.00\par} \newcommand{\permission}[1]{% - \gdef \@permission {#1}} + \gdef \@permission {#1}} \permission{% - Permission to make digital or hard copies of all or - part of this work for personal or classroom use is granted without - fee provided that copies are not made or distributed for profit or - commercial advantage and that copies bear this notice and the full - citation on the first page. To copy otherwise, to republish, to - post on servers or to redistribute to lists, requires prior specific - permission and/or a fee.} + Permission to make digital or hard copies of all or + part of this work for personal or classroom use is granted without + fee provided that copies are not made or distributed for profit or + commercial advantage and that copies bear this notice and the full + citation on the first page. To copy otherwise, to republish, to + post on servers or to redistribute to lists, requires prior specific + permission and/or a fee.} % Here we have some alternate permission statements and copyright lines: \newcommand{\ACMCanadapermission}{% - \permission{% - Copyright \@copyrightyear\ Association for Computing Machinery. - ACM acknowledges that - this contribution was authored or co-authored by an affiliate of the - National Research Council of Canada (NRC). - As such, the Crown in Right of - Canada retains an equal interest in the copyright, however granting - nonexclusive, royalty-free right to publish or reproduce this article, - or to allow others to do so, provided that clear attribution - is also given to the authors and the NRC.}} + \permission{% + Copyright \@copyrightyear\ Association for Computing Machinery. + ACM acknowledges that + this contribution was authored or co-authored by an affiliate of the + National Research Council of Canada (NRC). + As such, the Crown in Right of + Canada retains an equal interest in the copyright, however granting + nonexclusive, royalty-free right to publish or reproduce this article, + or to allow others to do so, provided that clear attribution + is also given to the authors and the NRC.}} \newcommand{\ACMUSpermission}{% - \permission{% - Copyright \@copyrightyear\ Association for - Computing Machinery. ACM acknowledges that - this contribution was authored or co-authored - by a contractor or affiliate - of the U.S. Government. As such, the Government retains a nonexclusive, - royalty-free right to publish or reproduce this article, - or to allow others to do so, for Government purposes only.}} + \permission{% + Copyright \@copyrightyear\ Association for + Computing Machinery. ACM acknowledges that + this contribution was authored or co-authored + by a contractor or affiliate + of the U.S. Government. As such, the Government retains a nonexclusive, + royalty-free right to publish or reproduce this article, + or to allow others to do so, for Government purposes only.}} \newcommand{\authorpermission}{% - \permission{% - Copyright is held by the author/owner(s).} - \toappear{% - \noindent \@permission \par - \vspace{2pt} - \noindent \textsl{\@conferencename}\quad \@conferenceinfo \par - ACM \@copyrightdata.}} + \permission{% + Copyright is held by the author/owner(s).} + \toappear{% + \noindent \@permission \par + \vspace{2pt} + \noindent \textsl{\@conferencename}\quad \@conferenceinfo \par + ACM \@copyrightdata.}} \newcommand{\Sunpermission}{% - \permission{% - Copyright is held by Sun Microsystems, Inc.}% - \toappear{% - \noindent \@permission \par - \vspace{2pt} - \noindent \textsl{\@conferencename}\quad \@conferenceinfo \par - ACM \@copyrightdata.}} + \permission{% + Copyright is held by Sun Microsystems, Inc.}% + \toappear{% + \noindent \@permission \par + \vspace{2pt} + \noindent \textsl{\@conferencename}\quad \@conferenceinfo \par + ACM \@copyrightdata.}} \newcommand{\USpublicpermission}{% - \permission{% - This paper is authored by an employee(s) of the United States - Government and is in the public domain.}% - \toappear{% - \noindent \@permission \par - \vspace{2pt} - \noindent \textsl{\@conferencename}\quad \@conferenceinfo \par - ACM \@copyrightdata.}} - + \permission{% + This paper is authored by an employee(s) of the United States + Government and is in the public domain.}% + \toappear{% + \noindent \@permission \par + \vspace{2pt} + \noindent \textsl{\@conferencename}\quad \@conferenceinfo \par + ACM \@copyrightdata.}} + % Enunciations % ------------ \def \@begintheorem #1#2{% {name}{number} - \trivlist - \item[\hskip \labelsep \textsc{#1 #2.}]% - \itshape\selectfont - \ignorespaces} + \trivlist + \item[\hskip \labelsep \textsc{#1 #2.}]% + \itshape\selectfont + \ignorespaces} \def \@opargbegintheorem #1#2#3{% {name}{number}{title} - \trivlist - \item[% - \hskip\labelsep \textsc{#1\ #2}% - \if \@notp{\@emptyargp{#3}}\nut (#3).\fi]% - \itshape\selectfont - \ignorespaces} - + \trivlist + \item[% + \hskip\labelsep \textsc{#1\ #2}% + \if \@notp{\@emptyargp{#3}}\nut (#3).\fi]% + \itshape\selectfont + \ignorespaces} + % Figures % ------- @@ -676,24 +672,24 @@ \@setflag \@caprule = \@true \long\def \@makecaption #1#2{% - \addvspace{4pt} - \if \@caprule - \hrule width \hsize height .33pt - \vspace{4pt} - \fi - \setbox \@tempboxa = \hbox{\@setfigurenumber{#1.}\nut #2}% - \if \@dimgtrp{\wd\@tempboxa}{\hsize}% - \noindent \@setfigurenumber{#1.}\nut #2\par - \else - \centerline{\box\@tempboxa}% - \fi} + \addvspace{4pt} + \if \@caprule + \hrule width \hsize height .33pt + \vspace{4pt} + \fi + \setbox \@tempboxa = \hbox{\@setfigurenumber{#1.}\nut #2}% + \if \@dimgtrp{\wd\@tempboxa}{\hsize}% + \noindent \@setfigurenumber{#1.}\nut #2\par + \else + \centerline{\box\@tempboxa}% + \fi} \newcommand{\nocaptionrule}{% - \@setflag \@caprule = \@false} + \@setflag \@caprule = \@false} \def \@setfigurenumber #1{% - {\rmfamily \bfseries \selectfont #1}} - + {\rmfamily \bfseries \selectfont #1}} + % Hierarchy % --------- @@ -705,68 +701,68 @@ \newskip{\@sectionbelowskip} \if \@blockstyle - \setlength{\@sectionbelowskip}{0.1pt}% + \setlength{\@sectionbelowskip}{0.1pt}% \else - \setlength{\@sectionbelowskip}{4pt}% + \setlength{\@sectionbelowskip}{4pt}% \fi \renewcommand{\section}{% - \@startsection - {section}% - {1}% - {0pt}% - {-\@sectionaboveskip}% - {\@sectionbelowskip}% - {\large \bfseries \raggedright}} + \@startsection + {section}% + {1}% + {0pt}% + {-\@sectionaboveskip}% + {\@sectionbelowskip}% + {\large \bfseries \raggedright}} \newskip{\@subsectionaboveskip} \setvspace{\@subsectionaboveskip}{8pt plus 2pt minus 2pt} \newskip{\@subsectionbelowskip} \if \@blockstyle - \setlength{\@subsectionbelowskip}{0.1pt}% + \setlength{\@subsectionbelowskip}{0.1pt}% \else - \setlength{\@subsectionbelowskip}{4pt}% + \setlength{\@subsectionbelowskip}{4pt}% \fi \renewcommand{\subsection}{% - \@startsection% - {subsection}% - {2}% - {0pt}% - {-\@subsectionaboveskip}% - {\@subsectionbelowskip}% - {\normalsize \bfseries \raggedright}} + \@startsection% + {subsection}% + {2}% + {0pt}% + {-\@subsectionaboveskip}% + {\@subsectionbelowskip}% + {\normalsize \bfseries \raggedright}} \renewcommand{\subsubsection}{% - \@startsection% - {subsubsection}% - {3}% - {0pt}% - {-\@subsectionaboveskip} - {\@subsectionbelowskip}% - {\normalsize \bfseries \raggedright}} + \@startsection% + {subsubsection}% + {3}% + {0pt}% + {-\@subsectionaboveskip} + {\@subsectionbelowskip}% + {\normalsize \bfseries \raggedright}} \newskip{\@paragraphaboveskip} \setvspace{\@paragraphaboveskip}{6pt plus 2pt minus 2pt} \renewcommand{\paragraph}{% - \@startsection% - {paragraph}% - {4}% - {0pt}% - {\@paragraphaboveskip} - {-1em}% - {\normalsize \bfseries \if \@times \itshape \fi}} + \@startsection% + {paragraph}% + {4}% + {0pt}% + {\@paragraphaboveskip} + {-1em}% + {\normalsize \bfseries \if \@times \itshape \fi}} \renewcommand{\subparagraph}{% - \@startsection% - {subparagraph}% - {4}% - {0pt}% - {\@paragraphaboveskip} - {-1em}% - {\normalsize \itshape}} + \@startsection% + {subparagraph}% + {4}% + {0pt}% + {\@paragraphaboveskip} + {-1em}% + {\normalsize \itshape}} % Standard headings: @@ -775,7 +771,7 @@ \newcommand{\keywords}{\paragraph*{Keywords}} \newcommand{\terms}{\paragraph*{General Terms}} - + % Identification % -------------- @@ -788,22 +784,22 @@ \newcommand{\conferenceinfo}[2]{% - \gdef \@conferencename {#1}% - \gdef \@conferenceinfo {#2}} + \gdef \@conferencename {#1}% + \gdef \@conferenceinfo {#2}} \newcommand{\copyrightyear}[1]{% - \gdef \@copyrightyear {#1}} + \gdef \@copyrightyear {#1}} \let \CopyrightYear = \copyrightyear \newcommand{\copyrightdata}[1]{% - \gdef \@copyrightdata {#1}} + \gdef \@copyrightdata {#1}} \let \crdata = \copyrightdata \newcommand{\proceedings}[1]{% - \gdef \@proceedings {#1}} - + \gdef \@proceedings {#1}} + % Lists % ----- @@ -816,11 +812,11 @@ \setlength{\topsep}{\standardvspace} \if \@blockstyle - \setlength{\itemsep}{1pt} - \setlength{\parsep}{3pt} + \setlength{\itemsep}{1pt} + \setlength{\parsep}{3pt} \else - \setlength{\itemsep}{1pt} - \setlength{\parsep}{3pt} + \setlength{\itemsep}{1pt} + \setlength{\parsep}{3pt} \fi \renewcommand{\labelitemi}{{\small \centeroncapheight{\textbullet}}} @@ -829,8 +825,8 @@ \renewcommand{\labelitemiv}{{\Large \textperiodcentered}} \renewcommand{\@listi}{% - \leftmargin = \leftmargini - \listparindent = 0pt} + \leftmargin = \leftmargini + \listparindent = 0pt} %%% \itemsep = 1pt %%% \parsep = 3pt} %%% \listparindent = \parindent} @@ -838,54 +834,54 @@ \let \@listI = \@listi \renewcommand{\@listii}{% - \leftmargin = \leftmarginii - \topsep = 1pt - \labelwidth = \leftmarginii - \advance \labelwidth by -\labelsep - \listparindent = \parindent} + \leftmargin = \leftmarginii + \topsep = 1pt + \labelwidth = \leftmarginii + \advance \labelwidth by -\labelsep + \listparindent = \parindent} \renewcommand{\@listiii}{% - \leftmargin = \leftmarginiii - \labelwidth = \leftmarginiii - \advance \labelwidth by -\labelsep - \listparindent = \parindent} + \leftmargin = \leftmarginiii + \labelwidth = \leftmarginiii + \advance \labelwidth by -\labelsep + \listparindent = \parindent} \renewcommand{\@listiv}{% - \leftmargin = \leftmarginiv - \labelwidth = \leftmarginiv - \advance \labelwidth by -\labelsep - \listparindent = \parindent} - + \leftmargin = \leftmarginiv + \labelwidth = \leftmarginiv + \advance \labelwidth by -\labelsep + \listparindent = \parindent} + % Mathematics % ----------- \def \theequation {\arabic{equation}} - + % Miscellaneous % ------------- \newcommand{\balancecolumns}{% - \vfill\eject - \global\@colht = \textheight - \global\ht\@cclv = \textheight} + \vfill\eject + \global\@colht = \textheight + \global\ht\@cclv = \textheight} \newcommand{\nut}{\hspace{.5em}} \newcommand{\softraggedright}{% - \let \\ = \@centercr - \leftskip = 0pt - \rightskip = 0pt plus 10pt} - + \let \\ = \@centercr + \leftskip = 0pt + \rightskip = 0pt plus 10pt} + % Program Code % ------- ---- \newcommand{\mono}[1]{% - {\@tempdima = \fontdimen2\font - \texttt{\spaceskip = 1.1\@tempdima #1}}} - + {\@tempdima = \fontdimen2\font + \texttt{\spaceskip = 1.1\@tempdima #1}}} + % Running Heads and Feet % ------- ----- --- ---- @@ -893,26 +889,26 @@ \def \@preprintfooter {} \newcommand{\preprintfooter}[1]{% - \gdef \@preprintfooter {#1}} + \gdef \@preprintfooter {#1}} \if \@preprint \def \ps@plain {% - \let \@mkboth = \@gobbletwo - \let \@evenhead = \@empty - \def \@evenfoot {\scriptsize \textit{\@preprintfooter}\hfil \thepage \hfil - \textit{\@formatyear}}% - \let \@oddhead = \@empty - \let \@oddfoot = \@evenfoot} + \let \@mkboth = \@gobbletwo + \let \@evenhead = \@empty + \def \@evenfoot {\scriptsize \textit{\@preprintfooter}\hfil \thepage \hfil + \textit{\@formatyear}}% + \let \@oddhead = \@empty + \let \@oddfoot = \@evenfoot} \else\if \@reprint \def \ps@plain {% - \let \@mkboth = \@gobbletwo - \let \@evenhead = \@empty - \def \@evenfoot {\scriptsize \hfil \thepage \hfil}% - \let \@oddhead = \@empty - \let \@oddfoot = \@evenfoot} + \let \@mkboth = \@gobbletwo + \let \@evenhead = \@empty + \def \@evenfoot {\scriptsize \hfil \thepage \hfil}% + \let \@oddhead = \@empty + \let \@oddfoot = \@evenfoot} \else @@ -923,15 +919,15 @@ \fi\fi \def \@formatyear {% - \number\year/\number\month/\number\day} - + \number\year/\number\month/\number\day} + % Special Characters % ------- ---------- \DeclareRobustCommand{\euro}{% - \protect{\rlap{=}}{\sf \kern .1em C}} - + \protect{\rlap{=}}{\sf \kern .1em C}} + % Title Page % ----- ---- @@ -949,207 +945,202 @@ \def \@titlebanner {} \renewcommand{\title}[1]{% - \gdef \@titletext {#1}} + \gdef \@titletext {#1}} \newcommand{\subtitle}[1]{% - \gdef \@subtitletext {#1}} + \gdef \@subtitletext {#1}} \newcommand{\authorinfo}[3]{% {names}{affiliation}{email/URL} - \global\@increment \@authorcount - \@withname\gdef {\@authorname\romannumeral\@authorcount}{#1}% - \@withname\gdef {\@authoraffil\romannumeral\@authorcount}{#2}% - \@withname\gdef {\@authoremail\romannumeral\@authorcount}{#3}} + \global\@increment \@authorcount + \@withname\gdef {\@authorname\romannumeral\@authorcount}{#1}% + \@withname\gdef {\@authoraffil\romannumeral\@authorcount}{#2}% + \@withname\gdef {\@authoremail\romannumeral\@authorcount}{#3}} \renewcommand{\author}[1]{% - \@latex@error{The \string\author\space command is obsolete; - use \string\authorinfo}{}} + \@latex@error{The \string\author\space command is obsolete; + use \string\authorinfo}{}} \newcommand{\titlebanner}[1]{% - \gdef \@titlebanner {#1}} + \gdef \@titlebanner {#1}} \renewcommand{\maketitle}{% - \pagestyle{plain}% - \if \@onecolumn - {\hsize = \standardtextwidth - \@maketitle}% - \else - \twocolumn[\@maketitle]% - \fi - \@placetitlenotes - \if \@copyrightwanted \@copyrightspace \fi} + \pagestyle{plain}% + \if \@onecolumn + {\hsize = \standardtextwidth + \@maketitle}% + \else + \twocolumn[\@maketitle]% + \fi + \@placetitlenotes + \if \@copyrightwanted \@copyrightspace \fi} \def \@maketitle {% - \begin{center} - \@settitlebanner - \let \thanks = \titlenote - {\leftskip = 0pt plus 0.25\linewidth - \rightskip = 0pt plus 0.25 \linewidth - \parfillskip = 0pt - \spaceskip = .7em - \noindent \LARGE \bfseries \@titletext \par} - \vskip 6pt - \noindent \Large \@subtitletext \par - \vskip 12pt - \ifcase \@authorcount - \@latex@error{No authors were specified for this paper}{}\or - \@titleauthors{i}{}{}\or - \@titleauthors{i}{ii}{}\or - \@titleauthors{i}{ii}{iii}\or - \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{}{}\or - \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{}\or - \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}\or - \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% - \@titleauthors{vii}{}{}\or - \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% - \@titleauthors{vii}{viii}{}\or - \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% - \@titleauthors{vii}{viii}{ix}\or - \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% - \@titleauthors{vii}{viii}{ix}\@titleauthors{x}{}{}\or - \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% - \@titleauthors{vii}{viii}{ix}\@titleauthors{x}{xi}{}\or - \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% - \@titleauthors{vii}{viii}{ix}\@titleauthors{x}{xi}{xii}% - \else - \@latex@error{Cannot handle more than 12 authors}{}% - \fi - \vspace{1.75pc} - \end{center}} + \begin{center} + \@settitlebanner + \let \thanks = \titlenote + \noindent \LARGE \bfseries \@titletext \par + \vskip 6pt + \noindent \Large \@subtitletext \par + \vskip 12pt + \ifcase \@authorcount + \@latex@error{No authors were specified for this paper}{}\or + \@titleauthors{i}{}{}\or + \@titleauthors{i}{ii}{}\or + \@titleauthors{i}{ii}{iii}\or + \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{}{}\or + \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{}\or + \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}\or + \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% + \@titleauthors{vii}{}{}\or + \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% + \@titleauthors{vii}{viii}{}\or + \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% + \@titleauthors{vii}{viii}{ix}\or + \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% + \@titleauthors{vii}{viii}{ix}\@titleauthors{x}{}{}\or + \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% + \@titleauthors{vii}{viii}{ix}\@titleauthors{x}{xi}{}\or + \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% + \@titleauthors{vii}{viii}{ix}\@titleauthors{x}{xi}{xii}% + \else + \@latex@error{Cannot handle more than 12 authors}{}% + \fi + \vspace{1.75pc} + \end{center}} \def \@settitlebanner {% - \if \@andp{\@preprint}{\@notp{\@emptydefp{\@titlebanner}}}% - \vbox to 0pt{% - \vskip -32pt - \noindent \textbf{\@titlebanner}\par - \vss}% - \nointerlineskip - \fi} + \if \@andp{\@preprint}{\@notp{\@emptydefp{\@titlebanner}}}% + \vbox to 0pt{% + \vskip -32pt + \noindent \textbf{\@titlebanner}\par + \vss}% + \nointerlineskip + \fi} \def \@titleauthors #1#2#3{% - \if \@andp{\@emptyargp{#2}}{\@emptyargp{#3}}% - \noindent \@setauthor{40pc}{#1}{\@false}\par - \else\if \@emptyargp{#3}% - \noindent \@setauthor{17pc}{#1}{\@false}\hspace{3pc}% - \@setauthor{17pc}{#2}{\@false}\par - \else - \noindent \@setauthor{12.5pc}{#1}{\@false}\hspace{2pc}% - \@setauthor{12.5pc}{#2}{\@false}\hspace{2pc}% - \@setauthor{12.5pc}{#3}{\@true}\par - \relax - \fi\fi - \vspace{20pt}} + \if \@andp{\@emptyargp{#2}}{\@emptyargp{#3}}% + \noindent \@setauthor{40pc}{#1}{\@false}\par + \else\if \@emptyargp{#3}% + \noindent \@setauthor{17pc}{#1}{\@false}\hspace{3pc}% + \@setauthor{17pc}{#2}{\@false}\par + \else + \noindent \@setauthor{12.5pc}{#1}{\@false}\hspace{2pc}% + \@setauthor{12.5pc}{#2}{\@false}\hspace{2pc}% + \@setauthor{12.5pc}{#3}{\@true}\par + \relax + \fi\fi + \vspace{20pt}} \def \@setauthor #1#2#3{% {width}{text}{unused} - \vtop{% - \def \and {% - \hspace{16pt}} - \hsize = #1 - \normalfont - \centering - \large \@name{\@authorname#2}\par - \vspace{5pt} - \normalsize \@name{\@authoraffil#2}\par - \vspace{2pt} - \textsf{\@name{\@authoremail#2}}\par}} + \vtop{% + \def \and {% + \hspace{16pt}} + \hsize = #1 + \normalfont + \centering + \large \@name{\@authorname#2}\par + \vspace{5pt} + \normalsize \@name{\@authoraffil#2}\par + \vspace{2pt} + \textsf{\@name{\@authoremail#2}}\par}} \def \@maybetitlenote #1{% - \if \@andp{#1}{\@gtrp{\@authorcount}{3}}% - \titlenote{See page~\pageref{@addauthors} for additional authors.}% - \fi} + \if \@andp{#1}{\@gtrp{\@authorcount}{3}}% + \titlenote{See page~\pageref{@addauthors} for additional authors.}% + \fi} \newtoks{\@fnmark} \newcommand{\titlenote}[1]{% - \global\@increment \@titlenotecount - \ifcase \@titlenotecount \relax \or - \@fnmark = {\ast}\or - \@fnmark = {\dagger}\or - \@fnmark = {\ddagger}\or - \@fnmark = {\S}\or - \@fnmark = {\P}\or - \@fnmark = {\ast\ast}% - \fi - \,$^{\the\@fnmark}$% - \edef \reserved@a {\noexpand\@appendtotext{% - \noexpand\@titlefootnote{\the\@fnmark}}}% - \reserved@a{#1}} + \global\@increment \@titlenotecount + \ifcase \@titlenotecount \relax \or + \@fnmark = {\ast}\or + \@fnmark = {\dagger}\or + \@fnmark = {\ddagger}\or + \@fnmark = {\S}\or + \@fnmark = {\P}\or + \@fnmark = {\ast\ast}% + \fi +% \,$^{\the\@fnmark}$% + \edef \reserved@a {\noexpand\@appendtotext{% + \noexpand\@titlefootnote{\the\@fnmark}}}% + \reserved@a{#1}} \def \@appendtotext #1#2{% - \global\@titlenotetext = \expandafter{\the\@titlenotetext #1{#2}}} + \global\@titlenotetext = \expandafter{\the\@titlenotetext #1{#2}}} \newcount{\@authori} \iffalse \def \additionalauthors {% - \if \@gtrp{\@authorcount}{3}% - \section{Additional Authors}% - \label{@addauthors}% - \noindent - \@authori = 4 - {\let \\ = ,% - \loop - \textbf{\@name{\@authorname\romannumeral\@authori}}, - \@name{\@authoraffil\romannumeral\@authori}, - email: \@name{\@authoremail\romannumeral\@authori}.% - \@increment \@authori - \if \@notp{\@gtrp{\@authori}{\@authorcount}} \repeat}% - \par - \fi - \global\@setflag \@addauthorsdone = \@true} + \if \@gtrp{\@authorcount}{3}% + \section{Additional Authors}% + \label{@addauthors}% + \noindent + \@authori = 4 + {\let \\ = ,% + \loop + \textbf{\@name{\@authorname\romannumeral\@authori}}, + \@name{\@authoraffil\romannumeral\@authori}, + email: \@name{\@authoremail\romannumeral\@authori}.% + \@increment \@authori + \if \@notp{\@gtrp{\@authori}{\@authorcount}} \repeat}% + \par + \fi + \global\@setflag \@addauthorsdone = \@true} \fi \let \addauthorsection = \additionalauthors \def \@placetitlenotes { - \the\@titlenotetext} - + \the\@titlenotetext} + % Utilities % --------- \newcommand{\centeroncapheight}[1]{% - {\setbox\@tempboxa = \hbox{#1}% - \@measurecapheight{\@tempdima}% % Calculate ht(CAP) - ht(text) - \advance \@tempdima by -\ht\@tempboxa % ------------------ - \divide \@tempdima by 2 % 2 - \raise \@tempdima \box\@tempboxa}} + {\setbox\@tempboxa = \hbox{#1}% + \@measurecapheight{\@tempdima}% % Calculate ht(CAP) - ht(text) + \advance \@tempdima by -\ht\@tempboxa % ------------------ + \divide \@tempdima by 2 % 2 + \raise \@tempdima \box\@tempboxa}} \newbox{\@measbox} \def \@measurecapheight #1{% {\dimen} - \setbox\@measbox = \hbox{ABCDEFGHIJKLMNOPQRSTUVWXYZ}% - #1 = \ht\@measbox} + \setbox\@measbox = \hbox{ABCDEFGHIJKLMNOPQRSTUVWXYZ}% + #1 = \ht\@measbox} \long\def \@titlefootnote #1#2{% - \insert\footins{% - \reset@font\footnotesize - \interlinepenalty\interfootnotelinepenalty - \splittopskip\footnotesep - \splitmaxdepth \dp\strutbox \floatingpenalty \@MM - \hsize\columnwidth \@parboxrestore + \insert\footins{% + \reset@font\footnotesize + \interlinepenalty\interfootnotelinepenalty + \splittopskip\footnotesep + \splitmaxdepth \dp\strutbox \floatingpenalty \@MM + \hsize\columnwidth \@parboxrestore %%% \protected@edef\@currentlabel{% %%% \csname p@footnote\endcsname\@thefnmark}% - \color@begingroup - \def \@makefnmark {$^{#1}$}% - \@makefntext{% - \rule\z@\footnotesep\ignorespaces#2\@finalstrut\strutbox}% - \color@endgroup}} - + \color@begingroup + \def \@makefnmark {$^{#1}$}% + \@makefntext{% + \rule\z@\footnotesep\ignorespaces#2\@finalstrut\strutbox}% + \color@endgroup}} + % LaTeX Modifications % ----- ------------- \def \@seccntformat #1{% - \@name{\the#1}% - \@expandaftertwice\@seccntformata \csname the#1\endcsname.\@mark - \quad} + \@name{\the#1}% + \@expandaftertwice\@seccntformata \csname the#1\endcsname.\@mark + \quad} \def \@seccntformata #1.#2\@mark{% - \if \@emptyargp{#2}.\fi} - + \if \@emptyargp{#2}.\fi} + % Revision History % -------- ------- -% SNC = Stephen Chong (chong@seas.harvard.edu) % Date Person Ver. Change % ---- ------ ---- ------ @@ -1205,18 +1196,9 @@ % 2006.08.24 PCA 1.4 Fix bug in \maketitle case command. -% 2007.03.13 PCA 1.5 The title banner only displays with the +% 2007.03.13 PCA 1.5 The title banner only display with the % 'preprint' option. % 2007.06.06 PCA 1.6 Use \bibfont in \thebibliography. % Add 'natbib' option to load and configure % the natbib package. - -% 2007.11.20 PCA 1.7 Balance line lengths in centered article -% title (thanks to Norman Ramsey). - -% 2009.01.26 PCA 1.8 Change natbib \bibpunct values. - -% 2009.04.29 SNC 1.9 Added \reprintprice to allow the -% specification of the price of a reprint, and -% set it to default to \$10.00 From 01c8c281f3894f8d559541442cf5e66654f4338e Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 16 Nov 2010 12:35:37 -0500 Subject: [PATCH 030/255] Supress duplicate author lists. --- collects/scriblib/autobib.rkt | 34 ++++++++++++++++++---------------- 1 file changed, 18 insertions(+), 16 deletions(-) diff --git a/collects/scriblib/autobib.rkt b/collects/scriblib/autobib.rkt index 649ec6437f..8971c0c296 100644 --- a/collects/scriblib/autobib.rkt +++ b/collects/scriblib/autobib.rkt @@ -1,5 +1,6 @@ #lang at-exp racket/base (require scribble/manual + racket/list scribble/core scribble/decode scribble/html-properties @@ -64,24 +65,25 @@ ")"))) (define (add-cites group bib-entries) + (define groups (for/fold ([h (hash)]) ([b (reverse bib-entries)]) + (hash-update h (author-element-names (auto-bib-author b)) + (lambda (cur) (cons b cur)) null))) (make-element #f - (list 'nbsp - "(" - (let loop ([keys bib-entries]) - (if (null? (cdr keys)) - (make-element - #f - (list - (add-cite group (car keys) 'autobib-author #f) - " " - (add-cite group (car keys) 'autobib-date #t))) - (make-element - #f - (list (loop (list (car keys))) - "; " - (loop (cdr keys)))))) - ")"))) + (append + (list 'nbsp "(") + (add-between + (for/list ([(k v) groups]) + (make-element + #f + (list* + (add-cite group (car v) 'autobib-author #f) + " " + (add-between + (for/list ([b v]) (add-cite group b 'autobib-date #t)) + ", ")))) + "; ") + (list ")")))) (define (extract-bib-key b) (author-element-names (auto-bib-author b))) From 2dbbd1b58e558b029a170258f944d61a253573c3 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 16 Nov 2010 12:36:26 -0500 Subject: [PATCH 031/255] Add @onecolumn option to scribble/sigplan --- collects/scribble/sigplan.rkt | 4 ++-- collects/scribble/sigplan/lang.rkt | 8 ++++++-- collects/scribblings/scribble/sigplan.scrbl | 15 +++++++++++++-- 3 files changed, 21 insertions(+), 6 deletions(-) diff --git a/collects/scribble/sigplan.rkt b/collects/scribble/sigplan.rkt index e6e5bcc8b6..a144ac294b 100644 --- a/collects/scribble/sigplan.rkt +++ b/collects/scribble/sigplan.rkt @@ -35,7 +35,7 @@ (->* () () #:rest (listof pre-content?) content?)]) -(provide preprint 10pt nocopyright +(provide preprint 10pt nocopyright onecolumn include-abstract) (define-syntax-rule (defopts name ...) @@ -45,7 +45,7 @@ stx)) ... (provide name ...))) -(defopts preprint 10pt nocopyright) +(defopts preprint 10pt nocopyright onecolumn) (define sigplan-extras (let ([abs (lambda (s) diff --git a/collects/scribble/sigplan/lang.rkt b/collects/scribble/sigplan/lang.rkt index f2aa6ef0e9..4c03b3eb5a 100644 --- a/collects/scribble/sigplan/lang.rkt +++ b/collects/scribble/sigplan/lang.rkt @@ -17,9 +17,10 @@ [(_ id . body) (let ([preprint? #f] [10pt? #f] + [onecolumn? #f] [nocopyright? #f]) (let loop ([stuff #'body]) - (syntax-case* stuff (preprint 10pt nocopyright) (lambda (a b) (eq? (syntax-e a) (syntax-e b))) + (syntax-case* stuff (onecolumn preprint 10pt nocopyright) (lambda (a b) (eq? (syntax-e a) (syntax-e b))) [(ws . body) ;; Skip intraline whitespace to find options: (and (string? (syntax-e #'ws)) @@ -28,6 +29,9 @@ [(preprint . body) (set! preprint? "preprint") (loop #'body)] + [(onecolumn . body) + (set! onecolumn? "onecolumn") + (loop #'body)] [(nocopyright . body) (set! nocopyright? "nocopyrightspace") (loop #'body)] @@ -35,7 +39,7 @@ (set! 10pt? "10pt") (loop #'body)] [body - #`(#%module-begin id (post-process #,preprint? #,10pt? #,nocopyright?) () . body)])))])) + #`(#%module-begin id (post-process #,preprint? #,10pt? #,nocopyright? #,onecolumn?) () . body)])))])) (define ((post-process . opts) doc) (let ([options diff --git a/collects/scribblings/scribble/sigplan.scrbl b/collects/scribblings/scribble/sigplan.scrbl index 2b4f14e826..8b265fd1b7 100644 --- a/collects/scribblings/scribble/sigplan.scrbl +++ b/collects/scribblings/scribble/sigplan.scrbl @@ -39,8 +39,19 @@ same line as @hash-lang[], with only whitespace between #lang scribble/sigplan @nocopyright }|} -The @racket[10pt], @racket[preprint], and @racket[nocopyright] options can be -used together and may appear in any order. +@defidform[onecolumn]{ + +Enables the @tt{onecolumn} option. Use @racket[onecolumn] only on the +same line as @hash-lang[], with only whitespace between +@racketmodname[scribble/sigplan] and @racket[onecolumn]: + +@codeblock{ + #lang scribble/sigplan @onecolumn +}} + +The @racket[10pt], @racket[preprint], @racket[nocopyright], and +@racket[onecolumn] options can be used together and may appear in any +order. } From d50eac2effe61bcd7e3fa9584b5dab652b54938f Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 16 Nov 2010 13:27:50 -0500 Subject: [PATCH 032/255] Sort bib entries by year when authors are equal. Works only when just the year is specified. --- collects/scriblib/autobib.rkt | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/collects/scriblib/autobib.rkt b/collects/scriblib/autobib.rkt index 8971c0c296..0aa4d3fa61 100644 --- a/collects/scriblib/autobib.rkt +++ b/collects/scriblib/autobib.rkt @@ -88,12 +88,21 @@ (define (extract-bib-key b) (author-element-names (auto-bib-author b))) +(define (extract-bib-year b) + (string->number (auto-bib-date b))) + + (define (gen-bib tag group) - (let* ([author Date: Tue, 16 Nov 2010 14:02:47 -0500 Subject: [PATCH 033/255] Fix docs. --- collects/scribblings/scribble/sigplan.scrbl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/scribblings/scribble/sigplan.scrbl b/collects/scribblings/scribble/sigplan.scrbl index 8b265fd1b7..37a206bb31 100644 --- a/collects/scribblings/scribble/sigplan.scrbl +++ b/collects/scribblings/scribble/sigplan.scrbl @@ -45,9 +45,9 @@ Enables the @tt{onecolumn} option. Use @racket[onecolumn] only on the same line as @hash-lang[], with only whitespace between @racketmodname[scribble/sigplan] and @racket[onecolumn]: -@codeblock{ +@codeblock|{ #lang scribble/sigplan @onecolumn -}} +}|} The @racket[10pt], @racket[preprint], @racket[nocopyright], and @racket[onecolumn] options can be used together and may appear in any From afa8e6c86bb41e890dd31299b62258e3c08990a8 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 16 Nov 2010 14:36:04 -0500 Subject: [PATCH 034/255] Add `get-user-custodian' to the sandbox. --- collects/racket/sandbox.rkt | 3 +++ collects/scribblings/reference/sandbox.scrbl | 13 +++++++++++++ 2 files changed, 16 insertions(+) diff --git a/collects/racket/sandbox.rkt b/collects/racket/sandbox.rkt index 0a7979de20..5cad282900 100644 --- a/collects/racket/sandbox.rkt +++ b/collects/racket/sandbox.rkt @@ -32,6 +32,7 @@ evaluator-alive? kill-evaluator break-evaluator + get-user-custodian set-eval-limits set-eval-handler put-input @@ -621,6 +622,7 @@ (define-evaluator-messenger evaluator-alive? 'alive?) (define-evaluator-messenger kill-evaluator 'kill) (define-evaluator-messenger break-evaluator 'break) +(define-evaluator-messenger get-user-custodian 'user-cust) (define-evaluator-messenger (set-eval-limits secs mb) 'limits) (define-evaluator-messenger (set-eval-handler handler) 'handler) (define-evaluator-messenger (put-input . xs) 'input) @@ -819,6 +821,7 @@ [(alive?) (and user-thread (not (thread-dead? user-thread)))] [(kill) (terminate+kill! 'evaluator-killed #f)] [(break) (user-break)] + [(user-cust) user-cust] [(limits) (set! limits (evaluator-message-args expr))] [(handler) (set! eval-handler (car (evaluator-message-args expr)))] [(input) (apply input-putter (evaluator-message-args expr))] diff --git a/collects/scribblings/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl index 55f926f5c5..dfdee6878f 100644 --- a/collects/scribblings/reference/sandbox.scrbl +++ b/collects/scribblings/reference/sandbox.scrbl @@ -730,6 +730,19 @@ Ctrl-C was typed when the evaluator is currently executing, which propagates the break to the evaluator's context.} +@defproc[(get-user-custodian [evaluator (any/c . -> . any)]) void?]{ + +Retrieves the @racket[evaluator]'s toplevel custodian. This returns a +value that is different from @racket[(evaluator '(current-custodian))] +or @racket[call-in-sandbox-context evaluator current-custodian] --- each +sandbox interaction is wrapped in its own custodian, which is what these +would return. + +(One use for this custodian is with @racket[current-memory-use], where +the per-interaction sub-custodians will not be charged with the memory +for the whole sandbox.)} + + @defproc[(set-eval-limits [evaluator (any/c . -> . any)] [secs (or/c exact-nonnegative-integer? #f)] [mb (or/c exact-nonnegative-integer? #f)]) From 7cf81b566847eee70123963f020292352744b21f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 16 Nov 2010 14:42:59 -0500 Subject: [PATCH 035/255] Clarify that `current-memory-use' gets a result calculated by the last GC, and will return 0 if no GCs happened. --- collects/scribblings/reference/memory.scrbl | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/collects/scribblings/reference/memory.scrbl b/collects/scribblings/reference/memory.scrbl index 1f22d6ad4e..42e53e73f0 100644 --- a/collects/scribblings/reference/memory.scrbl +++ b/collects/scribblings/reference/memory.scrbl @@ -170,11 +170,15 @@ this procedure is never called.} @defproc[(current-memory-use [cust custodian? #f]) exact-nonnegative-integer?]{ Returns an estimate of the number of bytes of memory occupied by -reachable data from @racket[cust]. (The estimate is calculated -@italic{without} performing an immediate garbage collection; -performing a collection generally decreases the number returned by -@racket[current-memory-use].) If @racket[cust] is not provided, the -estimate is a total reachable from any custodians. +reachable data from @racket[cust]. This estimate is calculated by the +last garbage colection, and can be 0 if none occured (or if none occured +since the given custodian was created). @racket[current-memory-use] by +itself does @italic{not} perform a collection; doing one before the call +will generally decrease the result (or increase it from 0 if no +collections happened yet). + +If @racket[cust] is not provided, the estimate is a total reachable from +any custodians. When Racket is compiled without support for memory accounting, the estimate is the same (i.e., all memory) for any individual custodian; @@ -184,4 +188,3 @@ see also @racket[custodian-memory-accounting-available?].} Dumps information about memory usage to the (low-level) standard output port.} - From d2b1bf73e098256ecb47fd38dabd5cca7164bc67 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 16 Nov 2010 14:58:52 -0500 Subject: [PATCH 036/255] A little better prose style --- collects/scribblings/reference/memory.scrbl | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/scribblings/reference/memory.scrbl b/collects/scribblings/reference/memory.scrbl index 42e53e73f0..bfd2496cc4 100644 --- a/collects/scribblings/reference/memory.scrbl +++ b/collects/scribblings/reference/memory.scrbl @@ -172,10 +172,10 @@ this procedure is never called.} Returns an estimate of the number of bytes of memory occupied by reachable data from @racket[cust]. This estimate is calculated by the last garbage colection, and can be 0 if none occured (or if none occured -since the given custodian was created). @racket[current-memory-use] by -itself does @italic{not} perform a collection; doing one before the call -will generally decrease the result (or increase it from 0 if no -collections happened yet). +since the given custodian was created). The @racket[current-memory-use] +function does @italic{not} perform a collection by itself; doing one +before the call will generally decrease the result (or increase it from +0 if no collections happened yet). If @racket[cust] is not provided, the estimate is a total reachable from any custodians. From b8bbed6eb452712940e15b5ff7dbcdd3986c9e28 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 16 Nov 2010 14:59:48 -0500 Subject: [PATCH 037/255] Throw an error when translating an unknown enum integer to a symbol. Also, add a keyword argument that can be used to get the old behavior back. Also, improve the way the `_enum' and `_bitmask' functions are wrapped. --- collects/ffi/unsafe.rkt | 57 +++++++++++------------- collects/scribblings/foreign/types.scrbl | 11 ++++- 2 files changed, 34 insertions(+), 34 deletions(-) diff --git a/collects/ffi/unsafe.rkt b/collects/ffi/unsafe.rkt index 66fd34a767..4cef8d2674 100644 --- a/collects/ffi/unsafe.rkt +++ b/collects/ffi/unsafe.rkt @@ -759,22 +759,20 @@ ;; Call this with a name (symbol) and a list of symbols, where a symbol can be ;; followed by a '= and an integer to have a similar effect of C's enum. -(define (_enum* name symbols . base?) - (define basetype (if (pair? base?) (car base?) _ufixint)) +(define (_enum name symbols [basetype _ufixint] #:unknown [unknown _enum]) (define sym->int '()) (define int->sym '()) (define s->c (if name (string->symbol (format "enum:~a->int" name)) 'enum->int)) + (define c->s + (if name (string->symbol (format "enum:int->~a" name)) 'int->enum)) (let loop ([i 0] [symbols symbols]) (unless (null? symbols) - (let-values ([(i rest) - (if (and (pair? (cdr symbols)) - (eq? '= (cadr symbols)) - (pair? (cddr symbols))) - (values (caddr symbols) - (cdddr symbols)) - (values i - (cdr symbols)))]) + (let-values ([(i rest) (if (and (pair? (cdr symbols)) + (eq? '= (cadr symbols)) + (pair? (cddr symbols))) + (values (caddr symbols) (cdddr symbols)) + (values i (cdr symbols)))]) (set! sym->int (cons (cons (car symbols) i) sym->int)) (set! int->sym (cons (cons i (car symbols)) int->sym)) (loop (add1 i) rest)))) @@ -784,26 +782,26 @@ (if a (cdr a) (raise-type-error s->c (format "~a" (or name "enum")) x)))) - (lambda (x) (cond [(assq x int->sym) => cdr] [else #f])))) + (lambda (x) + (cond [(assq x int->sym) => cdr] + [(eq? unknown _enum) + (error c->s "expected a known ~a, got: ~s" basetype x)] + [(procedure? unknown) (unknown x)] + [else unknown])))) ;; Macro wrapper -- no need for a name -(provide _enum) -(define-syntax (_enum stx) +(provide (rename-out [_enum* _enum])) +(define-syntax (_enum* stx) (syntax-case stx () - [(_ syms) - (with-syntax ([name (syntax-local-name)]) - #'(_enum* 'name syms))] - [(_ syms basetype) - (with-syntax ([name (syntax-local-name)]) - #'(_enum* 'name syms basetype))] - [id (identifier? #'id) - #'(lambda (syms . base?) (apply _enum* #f syms base?))])) + [(_ x ...) + (with-syntax ([name (syntax-local-name)]) #'(_enum 'name x ...))] + [id (identifier? #'id) #'_enum])) ;; Call this with a name (symbol) and a list of (symbol int) or symbols like ;; the above with '= -- but the numbers have to be specified in some way. The ;; generated type will convert a list of these symbols into the logical-or of ;; their values and back. -(define (_bitmask* name orig-symbols->integers . base?) +(define (_bitmask name orig-symbols->integers . base?) (define basetype (if (pair? base?) (car base?) _uint)) (define s->c (if name (string->symbol (format "bitmask:~a->int" name)) 'bitmask->int)) @@ -843,17 +841,12 @@ l))))))))) ;; Macro wrapper -- no need for a name -(provide _bitmask) -(define-syntax (_bitmask stx) +(provide (rename-out [_bitmask* _bitmask])) +(define-syntax (_bitmask* stx) (syntax-case stx () - [(_ syms) - (with-syntax ([name (syntax-local-name)]) - #'(_bitmask* 'name syms))] - [(_ syms basetype) - (with-syntax ([name (syntax-local-name)]) - #'(_bitmask* 'name syms basetype))] - [id (identifier? #'id) - #'(lambda (syms . base?) (apply _bitmask* #f syms base?))])) + [(_ x ...) + (with-syntax ([name (syntax-local-name)]) #'(_bitmask 'name x ...))] + [id (identifier? #'id) #'_bitmask])) ;; ---------------------------------------------------------------------------- ;; Custom function type macros diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index 565e97690d..1f0c632aa3 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -989,7 +989,9 @@ Although the constructors below are describes as procedures, they are implemented as syntax, so that error messages can report a type name where the syntactic context implies one. -@defproc[(_enum [symbols list?] [basetype ctype? _ufixint]) +@defproc[(_enum [symbols list?] + [basetype ctype? _ufixint] + [#:unknown unknown any/c (lambda (x) (error ....))]) ctype?]{ Takes a list of symbols and generates an enumeration type. The @@ -1002,7 +1004,12 @@ example, the list @scheme['(x y = 10 z)] maps @scheme['x] to @scheme[0], @scheme['y] to @scheme[10], and @scheme['z] to @scheme[11]. -The @scheme[basetype] argument specifies the base type to use.} +The @scheme[basetype] argument specifies the base type to use. + +The @scheme[unknown] argument specifies the result of converting an +unknown integer from the foreign side: it can be a one-argument function +to be applied on the integer, or a value to return instead. The default +is to throw an exception.} @defproc[(_bitmask [symbols (or symbol? list?)] [basetype ctype? _uint]) ctype?]{ From 73be67942d5eeb57668b6ec25ca2adb82880d7f4 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Tue, 16 Nov 2010 12:02:14 -0700 Subject: [PATCH 038/255] add queue->list --- collects/data/queue.rkt | 20 +++++++++++++++++++- collects/data/scribblings/queue.scrbl | 12 ++++++++++++ collects/tests/data/queue.rkt | 12 +++++++++++- 3 files changed, 42 insertions(+), 2 deletions(-) diff --git a/collects/data/queue.rkt b/collects/data/queue.rkt index cec99343e9..e6f652a4c9 100644 --- a/collects/data/queue.rkt +++ b/collects/data/queue.rkt @@ -31,6 +31,23 @@ (set-queue-head! q (link-tail old)) (link-value old))) +(define (queue->list queue) + (let loop ([link (queue-head queue)] + [out '()]) + (if (not link) + (reverse out) + (loop (link-tail link) (cons (link-value link) out))))) + +;; queue->vector could be implemented as (list->vector (queue->list q)) +;; but this is somewhat slow. a direct translation between queue's and +;; vector's should be fast so the ideal situation is not to use a list +;; as an intermediate data structure. +;; maybe add the elements to a gvector and use gvector->vector? + +;; could use (length (queue->list q)) here but that would double +;; the time it takes to get the count +;; probably if `queue->vector' gets implemented it would be better to +;; do (vector-length (queue->vector q)) (define (queue-count queue) (let loop ([link (queue-head queue)] [count 0]) @@ -56,6 +73,7 @@ [queue? (-> any/c boolean?)] [make-queue (-> queue/c)] [queue-empty? (-> queue/c boolean?)] - [queue-count (-> queue/c integer?)]) + [queue-count (-> queue/c integer?)] + [queue->list (-> queue/c (listof any/c))]) (provide enqueue! dequeue!) diff --git a/collects/data/scribblings/queue.scrbl b/collects/data/scribblings/queue.scrbl index 2849090fbf..3cbd61ecfc 100644 --- a/collects/data/scribblings/queue.scrbl +++ b/collects/data/scribblings/queue.scrbl @@ -34,6 +34,18 @@ thread-unsafe way. (dequeue! q)] } +@defproc[(queue->list [queue queue/c]) (listof any/c)]{ + Returns an immutable list containing the elements of the queue + in the order the elements were added. + + @defexamples[#:eval qeval + (define queue (make-queue)) + (enqueue! queue 8) + (enqueue! queue 9) + (enqueue! queue 0) + (queue->list queue)] +} + @defproc[(queue-count [queue queue/c]) integer?]{ Returns the number of elements in the queue. diff --git a/collects/tests/data/queue.rkt b/collects/tests/data/queue.rkt index 1b8eeb318e..92f50de692 100644 --- a/collects/tests/data/queue.rkt +++ b/collects/tests/data/queue.rkt @@ -63,4 +63,14 @@ (enqueue! q 2) (check-equal? (dequeue! q) 1) (check-equal? (dequeue! q) 2) - (check-exn exn:fail? (lambda () (dequeue! q)))))))) + (check-exn exn:fail? (lambda () (dequeue! q)))))) + (test-suite "queue misc" + (test-case "queue to empty list" + (let ([queue (make-queue)]) + (check-equal? (queue->list queue) '()))) + (test-case "queue length" + (let ([queue (make-queue)]) + (enqueue! queue 1) + (enqueue! queue 2) + (enqueue! queue 3) + (check-equal? (queue->list queue) '(1 2 3))))))) From 7b24eaf58e3e8be020c41e7c6389abc9360cf220 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Tue, 16 Nov 2010 14:36:31 -0700 Subject: [PATCH 039/255] rename queue-count to queue-length --- collects/data/queue.rkt | 6 +++--- collects/data/scribblings/queue.scrbl | 8 ++++---- collects/tests/data/queue.rkt | 14 +++++++------- 3 files changed, 14 insertions(+), 14 deletions(-) diff --git a/collects/data/queue.rkt b/collects/data/queue.rkt index e6f652a4c9..d8e54568b2 100644 --- a/collects/data/queue.rkt +++ b/collects/data/queue.rkt @@ -45,10 +45,10 @@ ;; maybe add the elements to a gvector and use gvector->vector? ;; could use (length (queue->list q)) here but that would double -;; the time it takes to get the count +;; the time it takes to get the length ;; probably if `queue->vector' gets implemented it would be better to ;; do (vector-length (queue->vector q)) -(define (queue-count queue) +(define (queue-length queue) (let loop ([link (queue-head queue)] [count 0]) (if (not link) @@ -73,7 +73,7 @@ [queue? (-> any/c boolean?)] [make-queue (-> queue/c)] [queue-empty? (-> queue/c boolean?)] - [queue-count (-> queue/c integer?)] + [queue-length (-> queue/c integer?)] [queue->list (-> queue/c (listof any/c))]) (provide enqueue! dequeue!) diff --git a/collects/data/scribblings/queue.scrbl b/collects/data/scribblings/queue.scrbl index 3cbd61ecfc..670c1b0329 100644 --- a/collects/data/scribblings/queue.scrbl +++ b/collects/data/scribblings/queue.scrbl @@ -46,17 +46,17 @@ thread-unsafe way. (queue->list queue)] } -@defproc[(queue-count [queue queue/c]) integer?]{ +@defproc[(queue-length [queue queue/c]) integer?]{ Returns the number of elements in the queue. @defexamples[#:eval qeval (define queue (make-queue)) - (queue-count queue) + (queue-length queue) (enqueue! queue 5) (enqueue! queue 12) - (queue-count queue) + (queue-length queue) (dequeue! queue) - (queue-count queue)] + (queue-length queue)] } @defproc[(queue-empty? [q queue/c]) boolean?]{ diff --git a/collects/tests/data/queue.rkt b/collects/tests/data/queue.rkt index 92f50de692..551b6089da 100644 --- a/collects/tests/data/queue.rkt +++ b/collects/tests/data/queue.rkt @@ -34,21 +34,21 @@ (dequeue! q) (dequeue! q) (check-true (queue-empty? q))))) - (test-suite "count" - (test-case "count empty" + (test-suite "length" + (test-case "length empty" (let* ([queue (make-queue)]) - (check-equal? (queue-count queue) 0))) - (test-case "count enqueue once" + (check-equal? (queue-length queue) 0))) + (test-case "length enqueue once" (let* ([queue (make-queue)]) (enqueue! queue 5) - (check-equal? (queue-count queue) 1))) - (test-case "count enqueue thrice dequeue once" + (check-equal? (queue-length queue) 1))) + (test-case "length enqueue thrice dequeue once" (let* ([queue (make-queue)]) (enqueue! queue 5) (enqueue! queue 9) (enqueue! queue 12) (dequeue! queue) - (check-equal? (queue-count queue) 2)))) + (check-equal? (queue-length queue) 2)))) (test-suite "dequeue!" (test-case "make-queue" (check-exn exn:fail? (lambda () (dequeue! (make-queue))))) From 584287483b0aae37174cfa8cc65589203bff2cdd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 16 Nov 2010 17:08:14 -0700 Subject: [PATCH 040/255] cocoa: avoid another 10.6-only method Closes PR 11440 --- collects/mred/private/wx/cocoa/filedialog.rkt | 4 +++- collects/mred/private/wx/cocoa/menu.rkt | 2 +- collects/mred/private/wx/cocoa/utils.rkt | 13 +++++++++---- 3 files changed, 13 insertions(+), 6 deletions(-) diff --git a/collects/mred/private/wx/cocoa/filedialog.rkt b/collects/mred/private/wx/cocoa/filedialog.rkt index d73cc60d0a..7ffc630d31 100644 --- a/collects/mred/private/wx/cocoa/filedialog.rkt +++ b/collects/mred/private/wx/cocoa/filedialog.rkt @@ -74,7 +74,9 @@ ;; all other eventspaces and threads. It would be nice to improve ;; on this, but it's good enough. (atomically - (let ([front (get-front)]) + (let ([front (get-front)] + [parent (and (version-10.6-or-later?) + parent)]) (when parent (tellv ns beginSheetModalForWindow: (send parent get-cocoa-window) completionHandler: #f)) diff --git a/collects/mred/private/wx/cocoa/menu.rkt b/collects/mred/private/wx/cocoa/menu.rkt index a7b8bd318e..0162bc21c8 100644 --- a/collects/mred/private/wx/cocoa/menu.rkt +++ b/collects/mred/private/wx/cocoa/menu.rkt @@ -63,7 +63,7 @@ (create-menu "menu") (let ([b (box #f)]) (set! popup-box b) - (if #t ;; use the 10.5 code, for now + (if (not (version-10.6-or-later?)) ;; For 10.5 and earlier: (let ([p (tell #:type _NSPoint v convertPoint: #:type _NSPoint (make-NSPoint x y) diff --git a/collects/mred/private/wx/cocoa/utils.rkt b/collects/mred/private/wx/cocoa/utils.rkt index 02d1a0b069..fff2a03204 100644 --- a/collects/mred/private/wx/cocoa/utils.rkt +++ b/collects/mred/private/wx/cocoa/utils.rkt @@ -21,7 +21,8 @@ clean-menu-label ->wxb ->wx - old-cocoa?) + old-cocoa? + version-10.6-or-later?) define-mz) (define cocoa-lib (ffi-lib (format "/System/Library/Frameworks/Cocoa.framework/Cocoa"))) @@ -79,6 +80,10 @@ (and wxb (weak-box-value wxb))) -;; FIXME: need a better test: -(define old-cocoa? (equal? (path->string (system-library-subpath #f)) - "ppc-macosx")) +(define-appkit NSAppKitVersionNumber _double) + +(define old-cocoa? + ; earlier than 10.5? + (NSAppKitVersionNumber . < . 949)) +(define (version-10.6-or-later?) + (NSAppKitVersionNumber . >= . 1038)) From b2edac3179a6a6a84c72d77d4a78223089bab67e Mon Sep 17 00:00:00 2001 From: John Clements Date: Tue, 16 Nov 2010 16:54:56 -0800 Subject: [PATCH 041/255] edited async-apply description --- collects/scribblings/foreign/types.scrbl | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index 1f0c632aa3..22afd30bae 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -401,19 +401,22 @@ procedure with the generated procedure type can be applied in a foreign thread (i.e., an OS-level thread other than the one used to run Racket). The call in the foreign thread is transferred to the OS-level thread that runs Racket, but the Racket-level thread (in the -sense of @racket[thread]) is unspecified; the job of -@scheme[async-apply] is to arrange for the callback procedure to be -run in a suitable Racket thread. The @scheme[async-apply] function is +sense of @racket[thread]) is unspecified; the job of the provided +@scheme[async-apply] procedure is to arrange for the callback procedure to be +run in a suitable Racket thread. The given @scheme[async-apply] procedure is applied to a thunk that encapsulates the specific callback invocation, and the foreign OS-level thread blocks until the thunk is called and completes; the thunk must be called exactly once, and the callback -invocation must return normally. The @scheme[async-apply] procedure +invocation must return normally. The given @scheme[async-apply] procedure itself is called in atomic mode (see @scheme[atomic?] above). If the callback is known to complete quickly, requires no synchronization, and works independent of the Racket thread in which it runs, then -@scheme[async-apply] can apply the thunk directly. Otherwise, -@racket[async-apply] must arrange for the thunk to be applied in a -suitable Racket thread sometime after @racket[async-apply] itself +it is safe for the given +@scheme[async-apply] procedure to apply the thunk directly. Otherwise, +the given @racket[async-apply] procedure +must arrange for the thunk to be applied in a +suitable Racket thread sometime after the given +@racket[async-apply] procedure itself returns; if the thunk raises an exception or synchronizes within an unsuitable Racket-level thread, it can deadlock or otherwise damage the Racket process. Foreign-thread detection to trigger From 1762a9a8726e7ad9f4aea94b3b426772de0a04ca Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 16 Nov 2010 20:14:54 -0700 Subject: [PATCH 042/255] fix `set!' of `define-for-syntax'ed varable in `let-syntax' RHS --- collects/tests/racket/syntax.rktl | 19 ++++++++++++++++++- src/racket/src/env.c | 5 ++++- 2 files changed, 22 insertions(+), 2 deletions(-) diff --git a/collects/tests/racket/syntax.rktl b/collects/tests/racket/syntax.rktl index 5508dc767b..9e1090275c 100644 --- a/collects/tests/racket/syntax.rktl +++ b/collects/tests/racket/syntax.rktl @@ -1353,7 +1353,24 @@ (syntax-case stx () [(_ v) (datum->syntax stx (kw/f #:x #'v opt))])) (kw/g 7)))) - + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Check mutation of local define-for-syntax in let-syntax: + +(module set-local-dfs racket/base + (require (for-syntax racket/base)) + (provide ten) + + (define-for-syntax tl-var 9) + + (define ten + (let-syntax ([x1 (lambda (stx) + (set! tl-var (add1 tl-var)) + (datum->syntax stx tl-var))]) + (x1)))) + +(test 10 dynamic-require ''set-local-dfs 'ten) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/src/racket/src/env.c b/src/racket/src/env.c index 68fc08596e..f82162c125 100644 --- a/src/racket/src/env.c +++ b/src/racket/src/env.c @@ -3112,7 +3112,10 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, modpos, SCHEME_INT_VAL(mod_defn_phase)); } - if (!modname && (flags & (SCHEME_SETTING | SCHEME_REFERENCING)) && genv->module) { + if (!modname + && (flags & (SCHEME_SETTING | SCHEME_REFERENCING)) + && genv->module + && !(flags & SCHEME_RESOLVE_MODIDS)) { /* Need to return a variable reference in this case, too. */ return scheme_hash_module_variable(env->genv, genv->module->self_modidx, find_global_id, genv->module->insp, From c5d56b4a4afbed7e6d25dc8fd303737b3aa6e5b2 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Tue, 16 Nov 2010 18:10:14 -0700 Subject: [PATCH 043/255] typo, gvector instead of vector --- collects/data/gvector.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/data/gvector.rkt b/collects/data/gvector.rkt index 07de71a87a..837d7a2865 100644 --- a/collects/data/gvector.rkt +++ b/collects/data/gvector.rkt @@ -119,7 +119,7 @@ (in-dict-values gv)) (define-sequence-syntax in-gvector* - (lambda () #'in-vector) + (lambda () #'in-gvector) (lambda (stx) (syntax-case stx () [[(var) (in-gv gv-expr)] From 27b32464c5606b304e5b9b8a752b7cf00e39564a Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Tue, 16 Nov 2010 18:11:30 -0700 Subject: [PATCH 044/255] add test for sequence used as an expression --- collects/tests/data/gvector.rkt | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/collects/tests/data/gvector.rkt b/collects/tests/data/gvector.rkt index 1b2591d32f..cf60fc1302 100644 --- a/collects/tests/data/gvector.rkt +++ b/collects/tests/data/gvector.rkt @@ -68,6 +68,12 @@ (for/list ([x (in-gvector gv)]) x)) '(1 2 3)) +(test-equal? "in-gvector expression form" + (let* ([gv (gvector 1 2 3)] + [gv-sequence (in-gvector gv)]) + (for/list ([x gv-sequence]) x)) + '(1 2 3)) + (test-equal? "gvector as sequence" (let ([gv (gvector 1 2 3)]) (for/list ([x gv]) x)) From 5f2d18c1f9e4e3f8e818839b3f5ccd0991dafb53 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Tue, 16 Nov 2010 23:09:06 -0700 Subject: [PATCH 045/255] add in-queue --- collects/data/queue.rkt | 27 ++++++++++++++++++++++++++- collects/data/scribblings/queue.scrbl | 7 +++++++ collects/tests/data/queue.rkt | 7 +++++++ 3 files changed, 40 insertions(+), 1 deletion(-) diff --git a/collects/data/queue.rkt b/collects/data/queue.rkt index d8e54568b2..6c40dfd1d1 100644 --- a/collects/data/queue.rkt +++ b/collects/data/queue.rkt @@ -1,5 +1,8 @@ #lang racket/base +(require (for-syntax racket/base + unstable/wrapc)) + ;; A Queue contains a linked list with mutable cdrs, holding two pointers ;; to the head and the tail -- where items are pulled from the head and ;; pushed on the tail. It is not thread safe: mutating a queue from @@ -55,6 +58,28 @@ count (loop (link-tail link) (add1 count))))) +(define (in-queue queue) + (in-list (queue->list queue))) + +(define-sequence-syntax in-queue* + (lambda () #'in-queue) + (lambda (stx) + (syntax-case stx () + ([(var) (in-queue* queue-expression)] + (with-syntax ([queue-expression/c (wrap-expr/c #'queue? #'queue-expression + #:macro #'in-queue*)]) + #'[(var) + (:do-in ([(queue) queue-expression/c]) + (void) ;; handled by contract + ([link (queue-head queue)]) + link + ([(var) (link-value link)]) + #t + #t + ((link-tail link)))])) + ([(var ...) (in-queue* queue-expression)] + #f)))) + ;; --- contracts --- (require racket/contract) @@ -76,4 +101,4 @@ [queue-length (-> queue/c integer?)] [queue->list (-> queue/c (listof any/c))]) -(provide enqueue! dequeue!) +(provide enqueue! dequeue! (rename-out [in-queue* in-queue])) diff --git a/collects/data/scribblings/queue.scrbl b/collects/data/scribblings/queue.scrbl index 670c1b0329..ed2650e7df 100644 --- a/collects/data/scribblings/queue.scrbl +++ b/collects/data/scribblings/queue.scrbl @@ -79,6 +79,13 @@ thread-unsafe way. (queue? 'not-a-queue)] } +@defproc[(in-queue [queue queue?]) + sequence?]{ + +Returns a sequence whose elements are the elements of +@racket[queue]. +} + @deftogether[( @defthing[queue/c flat-contract?] @defthing[nonempty-queue/c flat-contract?] diff --git a/collects/tests/data/queue.rkt b/collects/tests/data/queue.rkt index 551b6089da..505123288f 100644 --- a/collects/tests/data/queue.rkt +++ b/collects/tests/data/queue.rkt @@ -65,6 +65,13 @@ (check-equal? (dequeue! q) 2) (check-exn exn:fail? (lambda () (dequeue! q)))))) (test-suite "queue misc" + (test-case "queue as a sequence" + (let ([queue (make-queue)]) + (enqueue! queue 1) + (enqueue! queue 2) + (enqueue! queue 3) + (check-equal? '(1 2 3) (for/list ([item (in-queue queue)]) item))) + (check-equal? '() (for/list ([item (in-queue (make-queue))]) item))) (test-case "queue to empty list" (let ([queue (make-queue)]) (check-equal? (queue->list queue) '()))) From f78e2af4e151d4e3213c2ab699e4e02c31eb3546 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 17 Nov 2010 01:57:26 -0500 Subject: [PATCH 046/255] More instructions for pull-request-based workflow --- collects/meta/web/stubs/git.rkt | 76 +++++++++++++++++++++++++++++---- 1 file changed, 68 insertions(+), 8 deletions(-) diff --git a/collects/meta/web/stubs/git.rkt b/collects/meta/web/stubs/git.rkt index 1c4056e3e2..d4cf9e4842 100644 --- a/collects/meta/web/stubs/git.rkt +++ b/collects/meta/web/stubs/git.rkt @@ -96,7 +96,6 @@ (define git-host "git.racket-lang.org") (define at-racket "@racket-lang.org") (define at-git-racket "@git.racket-lang.org") -(define at-lists-racket "@lists.racket-lang.org") (define (npre . text) (apply pre style: "margin-left: 0;" text)) (define style @style/inline[type: 'text/css]{ @@ -2579,7 +2578,7 @@ and you can see more in the @man{git-config} and @man{git-send-email} man pages. The address to send the patches to is also configurable — you can use something like - @pre{to = plt-dev@at-lists-racket} + @pre{to = dev@at-racket} or @pre{to = someone@at-racket} depending on who you send your patches to — but this is better done as a @@ -2738,7 +2737,17 @@ it shares history with yours, you can just pull that branch in, for example: @pre{git checkout -b someones-work git pull @i{someones-repository-url}} - or, if you expect to do this often (eg, you're going to suggest fixes for the + Note that the @cmd{pull} will merge the changes, creating a merge + commit if your @cmd{master} branch cannot be fast-forwarded. To avoid + this, you can use @cmd{fetch} instead: + @pre{git checkout -b someones-work + git fetch @i{someones-repository-url}} + Either way, this fetches the remote repository's HEAD. You can create + the branch in a single fetch command by specifying the remote branch + name, and the local branch to fetch into, for example: + @pre{git fetch @i{someones-repository-url} master:someone} +@~ + If you expect to do this often (eg, you're going to suggest fixes for the work and get new work in), then you can add a @cmd{someone} remote to be used more conveniently: @pre{git remote add someone @i{someones-repository-url} @@ -2746,6 +2755,8 @@ git checkout -b some-branch someone/some-branch} possibly using -t to make the branch track the remote one: @pre{git checkout -tb some-branch someone/some-branch} + Note that there is no need to create a branch before the @cmd{fetch}, since + it will be fetched to a @cmd{remotes/someone/master} branch. @~ Once you pulled in the branch, you can inspect the changes, merge them, rebase them, etc. The important point here is that you have a copy of the @@ -2758,11 +2769,11 @@ usual. @~ Git has a tool that makes this mode of work a little more organized and - robust: @cmd{git request-pull}. This simple command (surprisingly, it has no - flags) is intended to be used by the contributor. It expects a commit that - marks the start of the new work (actually, the last one before it, eg, - @cmd{origin/master}), and the url of the repository. For example: - @pre{git request-pull origin git://github.com/someone/somefork.git} + robust for the contributor: @cmd{git request-pull}. This simple + command (surprisingly, it has no flags) expects a commit that marks the start + of the new work (actually, the last one before it, eg, @cmd{origin/master}), + and the url of the repository. For example: @pre{git request-pull origin + git://github.com/someone/somefork.git} @~ Of course, the contributor doesn't have to work directly in the available repository — in the case of github or with an over-the-web setup like the one @@ -2784,6 +2795,55 @@ @cmd{git request-pull origin .}, and get a condensed summary of your changes.)} +@subsection{Pull-request workflow@br + — recipe for the sender side} +@ol*{@~ Clone the plt repository and work with it as usual, commit your work + @~ Make your repository publicly available + @~ @npre{$ git request-pull origin @i{your-repository-url}} + @~ Send the resulting text to @cmd{dev@at-racket} + @~ You're done — thanks!} +@p{Alternatively, you can fork the plt repository on github: + @cmd{http://github.com/plt/racket}, commit, then do a pull request. Note: + it is better to send a note about your pull request to @cmd{dev@at-racket}, + or you can do the pull request directly with git as listed above (using + github to have a public repository).} + +@subsection{Pull-request workflow@br + — recipe for the receiver side} +@p{This recipe is for getting some remote work in as a one-time job. If you + need to cooperate more closely with someone, you will want to add the remote + repository with @cmd{git remote} as shown above.} +@ol*{ +@~ Get a plt clone, or use your own (it's safe to do the latter, no need for a + new clone unless you're paranoid): + @pre{git clone pltgit:plt + cd plt} +@~ Get the foreign repository's master branch (or any other branch) into a + local branch: + @pre{git fetch @i{remote-repository-url} master:foo} + This pulls the @cmd{master} branch of the remote repository into a local + @cmd{foo} branch (you can use other names, of course). +@~ Inspect the changes as usual + @pre{git log master..foo # new commits + git diff master...foo # changes + git log -p master..foo # both} + (See above for more details on these.) +@~ If you're happy with the change and want to get it as-is, you can simply + @cmd{merge} the branch: + @pre{git merge foo} + But unless the remote work was done from the point your @cmd{master} points + at (i.e., there were no new commits), this will generate a merge commit that + might not be desired. To avoid it, you can rebase the branch against your + @cmd{master} and then do the @cmd{merge} (which will now be a fast-forward) + merge: + @pre{git checkout foo + git rebase master + git checkout master + git merge foo} +@~ You no longer need the @cmd{foo} branch, so delete it with: + @pre{git branch -d foo} +@~ Push things back as usual} + @section{Additional Resources} @dl*{ @~ @strong{Quick and short:} From 24dbffaf3b50d64cc7647cd89a6b1b6fc5ee9b37 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 17 Nov 2010 04:56:55 -0700 Subject: [PATCH 047/255] Fixing problem found at Brown --- collects/plai/mutator.rkt | 2 +- collects/tests/plai/gc/good-mutators/thunks.rkt | 15 +++++++++++++++ 2 files changed, 16 insertions(+), 1 deletion(-) create mode 100755 collects/tests/plai/gc/good-mutators/thunks.rkt diff --git a/collects/plai/mutator.rkt b/collects/plai/mutator.rkt index 6d34d1bebc..4c2dfefd10 100644 --- a/collects/plai/mutator.rkt +++ b/collects/plai/mutator.rkt @@ -110,7 +110,7 @@ [(_) (mutator-app void)] [(_ e) e] [(_ fe e ...) - (mutator-let ([tmp fe]) (mutator-begin e ...))])) + (let ([tmp fe]) (mutator-begin e ...))])) ; Real Macros (define-syntax-rule (mutator-define-values (id ...) e) diff --git a/collects/tests/plai/gc/good-mutators/thunks.rkt b/collects/tests/plai/gc/good-mutators/thunks.rkt new file mode 100755 index 0000000000..4191318180 --- /dev/null +++ b/collects/tests/plai/gc/good-mutators/thunks.rkt @@ -0,0 +1,15 @@ +#lang plai/mutator +(allocator-setup "../good-collectors/good-collector.ss" 4) + +; 2 +(define thunker + (lambda () + ; 2 + 'alligator + ; 2 + 'bananna + ; 2 + 'frog)) +; 4 total + +(thunker) \ No newline at end of file From 9c607d39e7d8aebd3650a3a7652e6eea6fa5cd78 Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Mon, 15 Nov 2010 13:39:37 +0100 Subject: [PATCH 048/255] Further refine DMdA signatures for `lcm' and `gcd'. --- collects/deinprogramm/DMdA.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/deinprogramm/DMdA.rkt b/collects/deinprogramm/DMdA.rkt index b00016acd1..8d668c971f 100644 --- a/collects/deinprogramm/DMdA.rkt +++ b/collects/deinprogramm/DMdA.rkt @@ -157,10 +157,10 @@ (even? (integer -> boolean) "feststellen, ob eine Zahl gerade ist") - (lcm (integer integer ... -> integer) + (lcm (integer integer ... -> natural) "kleinstes gemeinsames Vielfaches berechnen") - (gcd (integer integer ... -> integer) + (gcd (integer integer ... -> natural) "größten gemeinsamen Teiler berechnen") (rational? (%a -> boolean) From 99e66e0dea57f07b6b9803ed44cd3fff90650279 Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Wed, 17 Nov 2010 17:14:12 +0100 Subject: [PATCH 049/255] Fix cycle detection in `tequal?'. ... and thus in `check-within', by using an eq? hash table. Also, while we're at it, add cycle detection to `tech-equal?'. Fixes PR #11423. --- collects/lang/private/teachprims.rkt | 81 +++++++++++++++------------- 1 file changed, 43 insertions(+), 38 deletions(-) diff --git a/collects/lang/private/teachprims.rkt b/collects/lang/private/teachprims.rkt index 56e999ab60..39f6225d49 100644 --- a/collects/lang/private/teachprims.rkt +++ b/collects/lang/private/teachprims.rkt @@ -242,8 +242,8 @@ namespace. (define-teach beginner exit (lambda () (exit))) -(define (tequal? x y epsilon) - (let* ([ht (make-hash)] ;; make-hash +(define (make-union-equal!?) + (let* ([ht (make-hasheq)] ;; make-hash [union-find (lambda (a) (let loop ([prev a] [prev-prev a]) @@ -256,21 +256,24 @@ namespace. (let ([v (hash-ref ht a)]) (hash-set! ht a prev) (loop v)))) - prev)))))] - [union-equal!? (lambda (a b) - (let ([a (union-find a)] - [b (union-find b)]) - (if (eq? a b) - #t - (begin - (hash-set! ht b a) - #f))))] - [fail (lambda (fmt arg) - (raise (make-exn:fail:contract (if (or (eq? arg x) - (eq? arg y)) - (format fmt arg) - (format "~a (originally comparing ~e and ~e)" (format fmt arg) x y)) - (current-continuation-marks))))]) + prev)))))]) + (lambda (a b) + (let ([a (union-find a)] + [b (union-find b)]) + (if (eq? a b) + #t + (begin + (hash-set! ht b a) + #f)))))) + +(define (tequal? x y epsilon) + (let ([union-equal!? (make-union-equal!?)] + [fail (lambda (fmt arg) + (raise (make-exn:fail:contract (if (or (eq? arg x) + (eq? arg y)) + (format fmt arg) + (format "~a (originally comparing ~e and ~e)" (format fmt arg) x y)) + (current-continuation-marks))))]) (let ? ([a x][b y]) (cond [(real? a) @@ -285,27 +288,29 @@ namespace. (define (teach-equal? x y) - (define (fail fmt arg) - (raise (make-exn:fail:contract (if (or (eq? arg x) - (eq? arg y)) - (format fmt arg) - (format "~a (originally comparing ~e and ~e)" (format fmt arg) x y)) - (current-continuation-marks)))) - - (let recur ([a x] [b y]) - (cond - [(procedure? a) - (fail "first argument of equality cannot be a procedure, given ~e" a)] - [(procedure? b) - (fail "second argument of equality cannot be a procedure, given ~e" b)] - [(and (number? a) - (inexact? a)) - (fail "first argument of equality cannot be an inexact number, given ~e" a)] - [(and (number? b) - (inexact? b)) - (fail "first argument of equality cannot be an inexact number, given ~e" b)] - [else - (equal?/recur a b recur)]))) + (let ([fail (lambda (fmt arg) + (raise (make-exn:fail:contract (if (or (eq? arg x) + (eq? arg y)) + (format fmt arg) + (format "~a (originally comparing ~e and ~e)" (format fmt arg) x y)) + (current-continuation-marks))))] + [union-equal!? (make-union-equal!?)]) + + (let recur ([a x] [b y]) + (cond + [(procedure? a) + (fail "first argument of equality cannot be a procedure, given ~e" a)] + [(procedure? b) + (fail "second argument of equality cannot be a procedure, given ~e" b)] + [(and (number? a) + (inexact? a)) + (fail "first argument of equality cannot be an inexact number, given ~e" a)] + [(and (number? b) + (inexact? b)) + (fail "first argument of equality cannot be an inexact number, given ~e" b)] + [(union-equal!? a b) #t] + [else + (equal?/recur a b recur)])))) (define-teach beginner equal? (lambda (a b) From 421519994d42ccd5a731e6b0b914ddf283988318 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 17 Nov 2010 13:15:59 -0700 Subject: [PATCH 050/255] make SSL listeners events --- collects/openssl/mzssl.rkt | 4 +++- collects/openssl/openssl.scrbl | 12 +++++++++--- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/collects/openssl/mzssl.rkt b/collects/openssl/mzssl.rkt index 339d72336e..d2ec22b506 100644 --- a/collects/openssl/mzssl.rkt +++ b/collects/openssl/mzssl.rkt @@ -270,7 +270,9 @@ (define-struct (ssl-client-context ssl-context) ()) (define-struct (ssl-server-context ssl-context) ()) - (define-struct ssl-listener (l mzctx)) + (define-struct ssl-listener (l mzctx) + #:property prop:evt (lambda (lst) (wrap-evt (ssl-listener-l lst) + (lambda (x) lst)))) ;; internal: (define-struct mzssl (ssl i o r-bio w-bio pipe-r pipe-w diff --git a/collects/openssl/openssl.scrbl b/collects/openssl/openssl.scrbl index 3a571d6868..a4eb3dae2d 100644 --- a/collects/openssl/openssl.scrbl +++ b/collects/openssl/openssl.scrbl @@ -139,8 +139,7 @@ Returns @scheme[#t] if @scheme[v] is a value produced by (or/c ssl-server-context? symbol?) 'sslv2-or-v3]) ssl-listener?]{ -Like @scheme[tcp-listen], but the result is an SSL listener (which is -a synchronizable value; see @scheme[sync]). The extra optional +Like @scheme[tcp-listen], but the result is an SSL listener. The extra optional @scheme[server-protocol] is as for @scheme[ssl-connect], except that a context must be a server context instead of a client context. @@ -149,7 +148,14 @@ Call @scheme[ssl-load-certificate-chain!] and error on accepting connections. The file @filepath{test.pem} in the @filepath{openssl} collection is a suitable argument for both calls when testing. Since @filepath{test.pem} is public, however, such a -test configuration obviously provides no security.} +test configuration obviously provides no security. + +An SSL listener is a synchronizable value (see @scheme[sync]). It is +ready---with itself as its value---when the underlying TCP listener is +ready. At that point, however, accepting a connection with +@racket[ssl-accept] may not complete immediately, because +further communication is needed to establish the connection.} + @deftogether[( @defproc[(ssl-close (listener ssl-listener?)) void?] From dbe896a9692a26677bb759f6fa40935cf0b5d55c Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Wed, 17 Nov 2010 16:18:20 -0500 Subject: [PATCH 051/255] wrong font size for 1column --- collects/scribble/sigplan/sigplanconf.cls | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribble/sigplan/sigplanconf.cls b/collects/scribble/sigplan/sigplanconf.cls index 318a5b6a76..4120cbda77 100644 --- a/collects/scribble/sigplan/sigplanconf.cls +++ b/collects/scribble/sigplan/sigplanconf.cls @@ -273,7 +273,7 @@ \if \@onecolumn \if \@notp{\@explicitsize}% \@setflag \@ninepoint = \@false - \PassOptionsToClass{11pt}{article}% +% \PassOptionsToClass{11pt}{article}% \fi \PassOptionsToClass{twoside,onecolumn}{article} \else From 14bdcda9a95605ab6a342d4aec8e0af7fadbf052 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Thu, 18 Nov 2010 10:26:53 -0500 Subject: [PATCH 052/255] rewrote docs for (name ...), Closes PR 11439 --- .../2htdp/scribblings/universe.scrbl | 25 +++++++++++-------- 1 file changed, 14 insertions(+), 11 deletions(-) diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl index 925fe32d3a..92359705a4 100644 --- a/collects/teachpack/2htdp/scribblings/universe.scrbl +++ b/collects/teachpack/2htdp/scribblings/universe.scrbl @@ -492,6 +492,15 @@ and @scheme[big-bang] will close down all event handling.} who wish to see how their world evolves---without having to design a rendering function---plus for the debugging of world programs. }} + +@item{ +@defform[(name name-expr) + #:contracts + ([name-expr (or/c symbol? string?)])]{ + provide a name (@scheme[namer-expr]) to this world, which is used as the + title of the canvas.} +} + ] The following example shows that @scheme[(run-simulation create-UFO-scene)] is @@ -747,17 +756,11 @@ following shapes: @item{ @defform[(register ip-expr) #:contracts ([ip-expr string?])]{ connect this world to a universe server at the specified @scheme[ip-expr] - address and set up capabilities for sending and receiving messages.} -} - -@item{ -@defform[(name name-expr) - #:contracts - ([name-expr (or/c symbol? string?)])]{ - provide a name (@scheme[namer-expr]) to this world, which is used as the - title of the canvas and the name sent to the server.} -} - + address and set up capabilities for sending and receiving messages. + If the world description includes a name specification of the form + @scheme[(name SomeString)] or @scheme[(name SomeSymbol)], the name of the + world is sent along to the server. +}} ] When a world program registers with a universe program and the universe program From cc69ceed6b756def2ed1df705b3db2c6a0278034 Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Thu, 18 Nov 2010 07:39:35 -0700 Subject: [PATCH 053/255] [Parallel-Build] Better error logging for failed match --- collects/setup/parallel-build.rkt | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/collects/setup/parallel-build.rkt b/collects/setup/parallel-build.rkt index 79cf3fff2a..50796f83e1 100644 --- a/collects/setup/parallel-build.rkt +++ b/collects/setup/parallel-build.rkt @@ -25,7 +25,11 @@ ['DONE (when (or (not (zero? (string-length out))) (not (zero? (string-length err)))) ((collects-queue-append-error jobqueue) cc "making" null out err "output"))]) - (when last ((collects-queue-printer jobqueue) (current-output-port) "made" "~a" cc-name )))])) + (when last ((collects-queue-printer jobqueue) (current-output-port) "made" "~a" cc-name )))] + [else + (eprintf "work-done match cc failed.\n") + (eprintf "trying to match:\n~a\n" (list work msg))])) + ;; assigns a collection to each worker to be compiled ;; when it runs out of collections, steals work from other workers collections (define (get-job jobqueue workerid) @@ -70,7 +74,11 @@ (build-job cc file #t)] [(cons (list cc (cons file ft) subs) tail) (hash-set! w-hash id (cons (list cc ft subs) tail)) - (build-job cc file #f)])) + (build-job cc file #f)] + [else + (eprintf "get-job match cc failed.\n") + (eprintf "trying to match:\n~a\n" cc)])) + (match (hash-ref!/true w-hash workerid take-cc) [#f (match (hash/first-pair w-hash) From 18b94ca8533674a57f1a2324bed674a4e41b9a2a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 13 Nov 2010 06:37:21 -0600 Subject: [PATCH 054/255] added scrbl as an extension --- collects/drracket/drracket.filetypes | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/drracket/drracket.filetypes b/collects/drracket/drracket.filetypes index 0da55e5f35..10bd9130b5 100644 --- a/collects/drracket/drracket.filetypes +++ b/collects/drracket/drracket.filetypes @@ -7,7 +7,7 @@ ("CFBundleTypeOSTypes" (array "TEXT" "WXME")) ("CFBundleTypeExtensions" - (array "rkt" "rktd" "rktl" "scm" "ss"))) + (array "rkt" "rktd" "rktl" "scrbl" "scm" "ss"))) (("CFBundleTypeName" "Package") ("CFBundleTypeIconFile" From a888325d786e5518546246dd4b11767def614890 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 15 Nov 2010 11:33:53 -0500 Subject: [PATCH 055/255] Fixed autobib doc. --- collects/scriblib/scribblings/autobib.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scriblib/scribblings/autobib.scrbl b/collects/scriblib/scribblings/autobib.scrbl index 66a7c57cf3..dffd154067 100644 --- a/collects/scriblib/scribblings/autobib.scrbl +++ b/collects/scriblib/scribblings/autobib.scrbl @@ -114,7 +114,7 @@ Combines elements to generate an element that is suitable for describing a technical report's location.} @defproc[(dissertation-location [#:institution institution edition any/c] - [#:number degree any/c "PhD"]) + [#:degree degree any/c "PhD"]) element?]{ Combines elements to generate an element that is suitable for From 102419f0092e1f384e99718e531266851d79c526 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 16 Nov 2010 14:34:04 -0500 Subject: [PATCH 056/255] Fixed command-line options for gambit in benchmarks. --- collects/tests/racket/benchmarks/common/auto.rkt | 3 +-- collects/tests/racket/benchmarks/common/mk-gambit.rktl | 5 ++++- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/collects/tests/racket/benchmarks/common/auto.rkt b/collects/tests/racket/benchmarks/common/auto.rkt index fd86c632fd..13cbbb7430 100755 --- a/collects/tests/racket/benchmarks/common/auto.rkt +++ b/collects/tests/racket/benchmarks/common/auto.rkt @@ -457,8 +457,7 @@ exec racket -qu "$0" ${1+"$@"} run-gambit-exe extract-gambit-times clean-up-o1 - (append '(nucleic2) - racket-specific-progs)) + racket-specific-progs) (make-impl 'larceny setup-larceny mk-larceny diff --git a/collects/tests/racket/benchmarks/common/mk-gambit.rktl b/collects/tests/racket/benchmarks/common/mk-gambit.rktl index addd829c80..335861ecb7 100644 --- a/collects/tests/racket/benchmarks/common/mk-gambit.rktl +++ b/collects/tests/racket/benchmarks/common/mk-gambit.rktl @@ -6,5 +6,8 @@ (when (file-exists? (format "~a.o1" name)) (delete-file (format "~a.o1" name))) -(system (format "gsc -:m10000 -dynamic -prelude '(include \"gambit-prelude.sch\")' ~a.sch" +(system (format "gsc -:m10000~a -dynamic -prelude '(include \"gambit-prelude.sch\")' ~a.sch" + (if (memq (string->symbol name) '(nucleic2)) + ",s" + "") name)) From 747c735eb323dd99f98c7049b4bb358e9d8f00d1 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 19 Nov 2010 17:50:52 -0600 Subject: [PATCH 057/255] adjusted scribble's sigplan setup so that the times.sty and qcourier.sty packages can be disabled. --- collects/scribble/sigplan.rkt | 4 +-- collects/scribble/sigplan/lang.rkt | 38 +++++++++++++++++---- collects/scribblings/scribble/sigplan.scrbl | 37 ++++++++++++++++---- 3 files changed, 63 insertions(+), 16 deletions(-) diff --git a/collects/scribble/sigplan.rkt b/collects/scribble/sigplan.rkt index a144ac294b..8607a80037 100644 --- a/collects/scribble/sigplan.rkt +++ b/collects/scribble/sigplan.rkt @@ -35,7 +35,7 @@ (->* () () #:rest (listof pre-content?) content?)]) -(provide preprint 10pt nocopyright onecolumn +(provide preprint 10pt nocopyright onecolumn noqcourier notimes include-abstract) (define-syntax-rule (defopts name ...) @@ -45,7 +45,7 @@ stx)) ... (provide name ...))) -(defopts preprint 10pt nocopyright onecolumn) +(defopts preprint 10pt nocopyright onecolumn noqcourier notimes) (define sigplan-extras (let ([abs (lambda (s) diff --git a/collects/scribble/sigplan/lang.rkt b/collects/scribble/sigplan/lang.rkt index 4c03b3eb5a..bcf43a5050 100644 --- a/collects/scribble/sigplan/lang.rkt +++ b/collects/scribble/sigplan/lang.rkt @@ -18,9 +18,11 @@ (let ([preprint? #f] [10pt? #f] [onecolumn? #f] - [nocopyright? #f]) + [nocopyright? #f] + [times? #t] + [qcourier? #t]) (let loop ([stuff #'body]) - (syntax-case* stuff (onecolumn preprint 10pt nocopyright) (lambda (a b) (eq? (syntax-e a) (syntax-e b))) + (syntax-case* stuff (onecolumn preprint 10pt nocopyright notimes noqcourier) (lambda (a b) (eq? (syntax-e a) (syntax-e b))) [(ws . body) ;; Skip intraline whitespace to find options: (and (string? (syntax-e #'ws)) @@ -38,19 +40,41 @@ [(10pt . body) (set! 10pt? "10pt") (loop #'body)] + [(noqcourier . body) + (set! qcourier? #f) + (loop #'body)] + [(notimes . body) + (set! times? #f) + (loop #'body)] [body - #`(#%module-begin id (post-process #,preprint? #,10pt? #,nocopyright? #,onecolumn?) () . body)])))])) + #`(#%module-begin id (post-process #,times? #,qcourier? #,preprint? #,10pt? #,nocopyright? #,onecolumn?) () . body)])))])) +#| -(define ((post-process . opts) doc) - (let ([options +The docs for the times.sty package suggests that it should not be used +so maybe we want to disable it permanently (or replace it with something else). + +Read here for more: + + http://www.ctan.org/tex-archive/macros/latex/required/psnfss/psnfss2e.pdf + +|# + +(define ((post-process times? qcourier? . opts) doc) + (let ([options (if (ormap values opts) (format "[~a]" (apply string-append (add-between (filter values opts) ", "))) "")]) (add-sigplan-styles (add-defaults doc (string->bytes/utf-8 - (format "\\documentclass~a{sigplanconf}\n\\usepackage{times}\n\\usepackage{qcourier}\n" - options)) + (format "\\documentclass~a{sigplanconf}\n~a~a" + options + (if times? + "\\usepackage{times}\n" + "") + (if qcourier? + "\\usepackage{qcourier}\n" + ""))) (scribble-file "sigplan/style.tex") (list (scribble-file "sigplan/sigplanconf.cls")) #f)))) diff --git a/collects/scribblings/scribble/sigplan.scrbl b/collects/scribblings/scribble/sigplan.scrbl index 37a206bb31..bf8b2465a2 100644 --- a/collects/scribblings/scribble/sigplan.scrbl +++ b/collects/scribblings/scribble/sigplan.scrbl @@ -12,7 +12,7 @@ file that is included with Scribble.} @defidform[preprint]{ Enables the @tt{preprint} option. Use @racket[preprint] only on the -same line as @hash-lang[], with only whitespace between +same line as @hash-lang[], with only whitespace (or other options) between @racketmodname[scribble/sigplan] and @racket[preprint]: @verbatim[#:indent 2]|{ @@ -22,7 +22,7 @@ same line as @hash-lang[], with only whitespace between @defidform[10pt]{ Enables the @tt{10pt} option. Use @racket[10pt] only on the -same line as @hash-lang[], with only whitespace between +same line as @hash-lang[], with only whitespace (or other options) between @racketmodname[scribble/sigplan] and @racket[10pt]: @verbatim[#:indent 2]|{ @@ -32,7 +32,7 @@ same line as @hash-lang[], with only whitespace between @defidform[nocopyright]{ Enables the @tt{nocopyright} option. Use @racket[nocopyright] only on the -same line as @hash-lang[], with only whitespace between +same line as @hash-lang[], with only whitespace (or other options) between @racketmodname[scribble/sigplan] and @racket[nocopyright]: @verbatim[#:indent 2]|{ @@ -42,16 +42,39 @@ same line as @hash-lang[], with only whitespace between @defidform[onecolumn]{ Enables the @tt{onecolumn} option. Use @racket[onecolumn] only on the -same line as @hash-lang[], with only whitespace between +same line as @hash-lang[], with only whitespace (or other options) between @racketmodname[scribble/sigplan] and @racket[onecolumn]: @codeblock|{ #lang scribble/sigplan @onecolumn }|} -The @racket[10pt], @racket[preprint], @racket[nocopyright], and -@racket[onecolumn] options can be used together and may appear in any -order. + +@defidform[notimes]{ + +Disables the use of @tt{\usepackage@"{"times@"}"} in the generated LaTeX output. +Use @racket[onecolumn] only on the +same line as @hash-lang[], with only whitespace (or other options) between +@racketmodname[scribble/sigplan] and @racket[notimes]: + +@codeblock|{ + #lang scribble/sigplan @notimes +}|} + +@defidform[noqcourier]{ + +Disables the use of @tt{\usepackage@"{"qcourier@"}"} in the generated LaTeX output. +Use @racket[onecolumn] only on the +same line as @hash-lang[], with only whitespace (or other options) between +@racketmodname[scribble/sigplan] and @racket[noqcourier]: + +@codeblock|{ + #lang scribble/sigplan @noqcourier +}|} + +The @racket[10pt], @racket[preprint], @racket[nocopyright], +@racket[onecolumn], @racket[notimes], and @racket[noqcourier] +options can be used together and may appear in any order. } From 2a3c66b731f368cbc1ab031e011321296f905024 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Fri, 19 Nov 2010 11:57:22 -0500 Subject: [PATCH 058/255] start animate from 0 not 1 --- collects/2htdp/universe.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/2htdp/universe.rkt b/collects/2htdp/universe.rkt index 1b0e22344c..791f5a68c3 100644 --- a/collects/2htdp/universe.rkt +++ b/collects/2htdp/universe.rkt @@ -230,7 +230,7 @@ (define (run-simulation f) (check-proc 'run-simulation f 1 "first" "one argument") - (big-bang 1 (on-draw f) (on-tick add1))) + (big-bang 0 (on-draw f) (on-tick add1))) (define animate run-simulation) From bf9b913f33adaeaec494739a4c1a68a727eb939f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 20 Nov 2010 15:37:02 -0700 Subject: [PATCH 059/255] cocoa: avoid another 10.6-only method Closes PR 11442 --- collects/mred/private/wx/cocoa/filedialog.rkt | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/collects/mred/private/wx/cocoa/filedialog.rkt b/collects/mred/private/wx/cocoa/filedialog.rkt index 7ffc630d31..419bc4ebf2 100644 --- a/collects/mred/private/wx/cocoa/filedialog.rkt +++ b/collects/mred/private/wx/cocoa/filedialog.rkt @@ -57,11 +57,14 @@ (when message (tellv ns setMessage: #:type _NSString message)) (when directory - (tellv ns setDirectoryURL: (tell NSURL - fileURLWithPath: #:type _NSString (if (string? directory) - directory - (path->string directory)) - isDirectory: #:type _BOOL #t))) + (let ([dir (if (string? directory) + directory + (path->string directory))]) + (if (version-10.6-or-later?) + (tellv ns setDirectoryURL: (tell NSURL + fileURLWithPath: #:type _NSString dir + isDirectory: #:type _BOOL #t)) + (tellv ns setDirectory: #:type _NSString dir)))) (when filename (tellv ns setNameFieldStringValue: #:type _NSString (path->string (file-name-from-path filename)))) From c94df207a4678224b30f9746f533ca84a739fe45 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 20 Nov 2010 15:45:28 -0700 Subject: [PATCH 060/255] cocoa: one more 10.6-only method --- collects/mred/private/wx/cocoa/filedialog.rkt | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/collects/mred/private/wx/cocoa/filedialog.rkt b/collects/mred/private/wx/cocoa/filedialog.rkt index 419bc4ebf2..3e6d35d1e1 100644 --- a/collects/mred/private/wx/cocoa/filedialog.rkt +++ b/collects/mred/private/wx/cocoa/filedialog.rkt @@ -66,9 +66,10 @@ isDirectory: #:type _BOOL #t)) (tellv ns setDirectory: #:type _NSString dir)))) (when filename - (tellv ns setNameFieldStringValue: #:type _NSString (path->string - (file-name-from-path filename)))) - + (when (version-10.6-or-later?) + (tellv ns setNameFieldStringValue: #:type _NSString (path->string + (file-name-from-path filename))))) + (when (memq 'enter-packages style) (tellv ns setTreatsFilePackagesAsDirectories: #:type _BOOL #t)) From 84fc6407521d4f694542dfa66615c51036cc4d71 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 19 Nov 2010 08:55:07 -0600 Subject: [PATCH 061/255] refactoring --- collects/racket/contract/private/vector.rkt | 66 ++++++++------------- 1 file changed, 24 insertions(+), 42 deletions(-) diff --git a/collects/racket/contract/private/vector.rkt b/collects/racket/contract/private/vector.rkt index 46393c404d..0e1f1674d5 100644 --- a/collects/racket/contract/private/vector.rkt +++ b/collects/racket/contract/private/vector.rkt @@ -9,6 +9,24 @@ (define-struct base-vectorof (elem immutable)) +(define-for-syntax (convert-args args this-one) + (let loop ([args args] + [new-args null]) + (cond + [(null? args) (reverse new-args)] + [(keyword? (syntax-e (car args))) + (if (null? (cdr args)) + (reverse (cons (car args) new-args)) + (loop (cddr args) + (list* (cadr args) (car args) new-args)))] + [else + (loop (cdr args) + (cons (syntax-property + (car args) + 'racket/contract:positive-position + this-one) + new-args))]))) + (define (vectorof-name c) (let ([immutable (base-vectorof-immutable c)]) (apply build-compound-type-name 'vectorof @@ -111,29 +129,11 @@ (vector (gensym 'ctc) (list #'x) null))] [(vecof arg ...) (let ([args (syntax->list #'(arg ...))] - [this-one (gensym 'ctc)]) - (define (convert-args args) - (let loop ([args args] - [new-args null]) - (cond - [(null? args) (reverse new-args)] - [(keyword? (syntax-e (car args))) - (if (null? (cdr args)) - (reverse (cons (car args) new-args)) - (loop (cddr args) - (list* (cadr args) (car args) new-args)))] - [else - (append (reverse new-args) - (cons (syntax-property - (car args) - 'racket/contract:positive-position - this-one) - (cdr args)))]))) - (with-syntax ([(new-arg ...) (convert-args args)] - [app (datum->syntax stx '#%app)]) + [this-one (gensym 'vectorof-ctc)]) + (with-syntax ([(new-arg ...) (convert-args args this-one)]) (syntax-property (syntax/loc stx - (app vectorof new-arg ...)) + (vectorof new-arg ...)) 'racket/contract:contract (vector this-one (list #'vecof) null))))])) @@ -265,29 +265,11 @@ (vector (gensym 'ctc) (list #'x) null))] [(vec/c arg ...) (let ([args (syntax->list #'(arg ...))] - [this-one (gensym 'ctc)]) - (define (convert-args args) - (let loop ([args args] - [new-args null]) - (cond - [(null? args) (reverse new-args)] - [(keyword? (syntax-e (car args))) - (if (null? (cdr args)) - (reverse (cons (car args) new-args)) - (loop (cddr args) - (list* (cadr args) (car args) new-args)))] - [else - (loop (cdr args) - (cons (syntax-property - (car args) - 'racket/contract:positive-position - this-one) - new-args))]))) - (with-syntax ([(new-arg ...) (convert-args args)] - [app (datum->syntax stx '#%app)]) + [this-one (gensym 'vector/c-ctc)]) + (with-syntax ([(new-arg ...) (convert-args args this-one)]) (syntax-property (syntax/loc stx - (app vector/c new-arg ...)) + (vector/c new-arg ...)) 'racket/contract:contract (vector this-one (list #'vec/c) null))))])) From 3b56f81b101bc518f9252186ea413b7e8abfc4f6 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 21 Nov 2010 07:15:02 -0600 Subject: [PATCH 062/255] adjusted case of 'show line numbers' to match menu / prefs distinction --- collects/drracket/private/unit.rkt | 8 ++++---- collects/string-constants/english-string-constants.rkt | 5 +++-- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/collects/drracket/private/unit.rkt b/collects/drracket/private/unit.rkt index 591e311d59..df09c003db 100644 --- a/collects/drracket/private/unit.rkt +++ b/collects/drracket/private/unit.rkt @@ -3799,15 +3799,15 @@ module browser threading seems wrong. (new menu:can-restore-menu-item% [label (if (show-line-numbers?) - (string-constant hide-line-numbers) - (string-constant show-line-numbers))] + (string-constant hide-line-numbers/menu) + (string-constant show-line-numbers/menu))] [parent (get-show-menu)] [callback (lambda (self event) (define value (preferences:get 'drracket:show-line-numbers?)) (send self set-label (if value - (string-constant show-line-numbers) - (string-constant hide-line-numbers))) + (string-constant show-line-numbers/menu) + (string-constant hide-line-numbers/menu))) (preferences:set 'drracket:show-line-numbers? (not value)) (show-line-numbers! (not value)))]) diff --git a/collects/string-constants/english-string-constants.rkt b/collects/string-constants/english-string-constants.rkt index a2f11e19f1..c6dd81652e 100644 --- a/collects/string-constants/english-string-constants.rkt +++ b/collects/string-constants/english-string-constants.rkt @@ -448,8 +448,9 @@ please adhere to these guidelines: (show-interactions-on-execute "Automatically open interactions window when running a program") (switch-to-module-language-automatically "Automatically switch to the module language when opening a module") (interactions-beside-definitions "Put the interactions window beside the definitions window") ;; in preferences, below the checkbox one line above this one - (show-line-numbers "Show Line Numbers") - (hide-line-numbers "Hide Line Numbers") + (show-line-numbers "Show line numbers") + (show-line-numbers/menu "Show Line Numbers") ;; just like the above, but capitalized for appearance in a menu item + (hide-line-numbers/menu "Hide Line Numbers") (limit-interactions-size "Limit interactions size") (background-color "Background Color") (default-text-color "Default text") ;; used for configuring colors, but doesn't need the word "color" From 860de6358c65deef424d523bed9974740bb6f403 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 21 Nov 2010 07:38:29 -0600 Subject: [PATCH 063/255] brought the preferences dialog description up to date with reality. closes PR 11453 --- collects/scribblings/drracket/prefs.scrbl | 185 ++++++++++++---------- 1 file changed, 104 insertions(+), 81 deletions(-) diff --git a/collects/scribblings/drracket/prefs.scrbl b/collects/scribblings/drracket/prefs.scrbl index 7e3ed7243b..d8e4cb5749 100644 --- a/collects/scribblings/drracket/prefs.scrbl +++ b/collects/scribblings/drracket/prefs.scrbl @@ -36,7 +36,7 @@ The preferences dialog consists of several panels. This panel controls which keywords DrRacket recognizes for indenting, and how each keyword is treated.} - + @item{@onscreen{Square bracket} This panel controls which keywords DrRacket uses to determine @@ -49,6 +49,100 @@ The preferences dialog consists of several panels. columns behave.} @item{@onscreen{General} + @itemize[@item{@PrefItem{Map delete to backspace} --- If checked, the editor + treats the Delete key like the Backspace key.} + + @item{@PrefItem{Wrap words in editor buffers} --- If checked, + DrRacket editors auto-wrap text lines by default. Changing this + preference affects new windows only.} + + @item{@PrefItem{Reuse existing frames when opening new files} --- + If checked, new files are opened in the same DrRacket window, + rather than creating a new DrRacket window for each new file.} + + @item{@PrefItem{Enable keybindings in menus} --- If checked, some + DrRacket menu items have keybindings. Otherwise, no menu items + have key bindings. This preference is designed for people who are + comfortable editing in Emacs and find the standard menu + keybindings interfere with the Emacs keybindings.} + + + @item{@PrefItem{Treat command key as meta} --- If checked, DrRacket will use the command key for some Emacs-like keybindings, instead of using it for menu shortcuts. This option is only available under Mac OS X.} + + @item{@PrefItem{Color syntax interactively} --- If checked, DrRacket + colors your syntax as you type.} + + @item{@PrefItem{Search using anchors} --- If checked, DrRacket's searching mode will jump directly to the first search hit, using an ``anchor'' to determine where to search if the search string changes.} + + @item{@PrefItem{Normalize pasted strings} --- If checked, DrRacket adjusts strings that are pasted into the editor to avoid confusion. For example, non-breaking spaces look just like spaces but are not considered separators like ordinary spaces are. If this is checked DrRacket will automatically turn those non-breaking spaces into regular spaces. Similarly with other (less common) characters.} + + @item{@PrefItem{Enable overwrite mode keybindings} --- If checked, DrRacket enables the insert keybinding to swap into overwrite mode} + + @item{@PrefItem{Show line numbers} --- If checked, DrRacket shows line numbers for the file being edited in the left-hand column} + + ]} + + + + + + @item{@onscreen{Racket} + + @itemize[ + + @item{@PrefItem{Highlight between matching parens} --- If checked, the + editor marks the region between matching parenthesis with a gray + background (in color) or a stipple pattern (in monochrome) when + the blinking caret is next to a parenthesis.} + + @item{@PrefItem{Automatically adjust closing parens} --- If checked, the editor + automatically converts a typed @litchar[")"] to @litchar["]"] to + match @litchar["["], or it converts a typed @litchar["]"] to + @litchar[")"] to match @litchar["("].} + + @item{@PrefItem{Automatically adjust opening square brackets} If checked, the editor changes + typed @litchar["["] to match the context (as explained in + @secref["editor"]).} + + @item{@PrefItem{Flash paren match} --- If checked, typing a closing + parenthesis, square bracket, or quotation mark flashes the + matching open parenthesis/bracket/quote.} + + ]}] + +@section{@onscreen{Warnings}} + + @itemize[ + + @item{@PrefItem{Ask before changing save format} --- If checked, + DrRacket consults the user before saving a file in non-text format + (see @secref["drracket-file-formats"]).} + + @item{@PrefItem{Verify exit} --- If checked, DrRacket consults the + user before exiting.} + + @item{@PrefItem{Ask about normalizing strings} --- If checked, DrRacket + consults the user before normalizing a string pasted into the editor.} + + @item{@PrefItem{Only warn once when executions and interactions are + not synchronized} --- If checked, DrRacket warns the user on the + first interaction after the definitions window, language, or + teachpack is changed without a corresponding click on + @onscreen{Run}. Otherwise, the warning appears on every + interaction.} + + @item{@PrefItem{Ask about clearing test coverage} --- If checked, + when test coverage annotations are displayed DrRacket prompts + about removing them. This setting only applies to the PLT + languages. DrRacket never asks in the teaching languages.} + + @item{@PrefItem{Check for newer Racket versions} --- If + checked, DrRacket periodically polls a server to determine + whether a newer version of DrRacket is available.} + + ] + +@section{@onscreen{General}} @itemize[ @@ -66,9 +160,6 @@ The preferences dialog consists of several panels. files have the same name as the original, except that they end in either @indexed-file{.bak} or @indexed-file{~}.} - @item{@PrefItem{Map delete to backspace} --- If checked, the editor - treats the Delete key like the Backspace key.} - @item{@PrefItem{Show status-line} --- If checked, DrRacket shows a status line at the bottom of each window.} @@ -81,29 +172,6 @@ The preferences dialog consists of several panels. @nonterm{line}:@nonterm{column} display for the current selection rather than the character offset into the text.} - @item{@PrefItem{Wrap words in editor buffers} --- If checked, - DrRacket editors auto-wrap text lines by default. Changing this - preference affects new windows only.} - - @item{@PrefItem{Use separate dialog for searching} --- If checked, - then selecting the @onscreen{Find} menu item opens a separate - dialog for searching and replacing. Otherwise, selecting - @onscreen{Find} opens an interactive search-and-replace panel at - the bottom of a DrRacket window.} - - @item{@PrefItem{Reuse existing frames when opening new files} --- - If checked, new files are opened in the same DrRacket window, - rather than creating a new DrRacket window for each new file.} - - @item{@PrefItem{Enable keybindings in menus} --- If checked, some - DrRacket menu items have keybindings. Otherwise, no menu items - have key bindings. This preference is designed for people who are - comfortable editing in Emacs and find the standard menu - keybindings interfere with the Emacs keybindings.} - - @item{@PrefItem{Color syntax interactively} --- If checked, DrRacket - colors your syntax as you type.} - @item{@PrefItem{Automatically print to PostScript file} --- If checked, printing will automatically save PostScript files. If not, printing will use the standard printing mechanisms for your @@ -117,6 +185,10 @@ The preferences dialog consists of several panels. a program} -- If checked, DrRacket shows the interactions window (if it is hidden) when a program is run.} + @item{@PrefItem{Automatically switch to the module language when opening a module} -- + If checked, DrRacket will recognize files that have a @tt{#lang} line + and adjust the language setting automatically.} + @item{@PrefItem{Put the interactions window beside the definitions window} -- If checked, DrRacket puts the interactions window to the right of the definitions window. By default, the interactions @@ -128,60 +200,7 @@ The preferences dialog consists of several panels. that the @hash-lang[] line is the first line in the file. } - ]} - - @item{@onscreen{Racket} - - @itemize[ - - @item{@PrefItem{Highlight between matching parens} --- If checked, the - editor marks the region between matching parenthesis with a gray - background (in color) or a stipple pattern (in monochrome) when - the blinking caret is next to a parenthesis.} - - @item{@PrefItem{Correct parens} --- If checked, the editor - automatically converts a typed @litchar[")"] to @litchar["]"] to - match @litchar["["], or it converts a typed @litchar["]"] to - @litchar[")"] to match @litchar["("]. Also, the editor changes - typed @litchar["["] to match the context (as explained in - @secref["editor"]).} - - @item{@PrefItem{Flash paren match} --- If checked, typing a closing - parenthesis, square bracket, or quotation mark flashes the - matching open parenthesis/bracket/quote.} - - ]} - -] - -@section{@onscreen{Warnings}} - - @itemize[ - - @item{@PrefItem{Ask before changing save format} --- If checked, - DrRacket consults the user before saving a file in non-text format - (see @secref["drracket-file-formats"]).} - - @item{@PrefItem{Verify exit} --- If checked, DrRacket consults the - user before exiting.} - - @item{@PrefItem{Only warn once when executions and interactions are - not synchronized} --- If checked, DrRacket warns the user on the - first interaction after the definitions window, language, or - teachpack is changed without a corresponding click on - @onscreen{Run}. Otherwise, the warning appears on every - interaction.} - - @item{@PrefItem{Ask about clearing test coverage} --- If checked, - when test coverage annotations are displayed DrRacket prompts - about removing them. This setting only applies to the PLT - languages. DrRacket never asks in the teaching languages.} - - @item{@PrefItem{Check for newer PLT Racket versions} --- If - checked, DrRacket periodically polls a server to determine - whether a newer version of DrRacket is available.} - - ] + ] @section{@onscreen{Profiling}} @@ -199,3 +218,7 @@ The preferences dialog consists of several panels. This preferences panel allows you to configure your HTTP proxy. Contact your system administrator for details. + +@section{@onscreen{Tools}} + +This preference panel allows you to configure the currently active plugins. \ No newline at end of file From 39b3a289c591965f81113e22031923e4bddbbb22 Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Mon, 22 Nov 2010 09:29:54 +0100 Subject: [PATCH 064/255] Update signatutures and explanations on DMdA primitives. --- collects/deinprogramm/DMdA.rkt | 54 +++++++++++++++++----------------- 1 file changed, 27 insertions(+), 27 deletions(-) diff --git a/collects/deinprogramm/DMdA.rkt b/collects/deinprogramm/DMdA.rkt index 8d668c971f..fef2a25dcb 100644 --- a/collects/deinprogramm/DMdA.rkt +++ b/collects/deinprogramm/DMdA.rkt @@ -79,7 +79,7 @@ (provide-and-document procedures ("Zahlen" - (number? (%a -> boolean) + (number? (any -> boolean) "feststellen, ob ein Wert eine Zahl ist") (= (number number number ... -> boolean) @@ -141,9 +141,9 @@ (exact? (number -> boolean) "feststellen, ob eine Zahl exakt ist") - (integer? (%a -> boolean) + (integer? (any -> boolean) "feststellen, ob ein Wert eine ganze Zahl ist") - (natural? (%a -> boolean) + (natural? (any -> boolean) "feststellen, ob ein Wert eine natürliche Zahl (inkl. 0) ist") (zero? (number -> boolean) @@ -163,7 +163,7 @@ (gcd (integer integer ... -> natural) "größten gemeinsamen Teiler berechnen") - (rational? (%a -> boolean) + (rational? (any -> boolean) "feststellen, ob eine Zahl rational ist") (numerator (rational -> integer) @@ -175,7 +175,7 @@ (inexact? (number -> boolean) "feststellen, ob eine Zahl inexakt ist") - (real? (%a -> boolean) + (real? (any -> boolean) "feststellen, ob ein Wert eine reelle Zahl ist") (floor (real -> integer) @@ -187,7 +187,7 @@ (round (real -> integer) "relle Zahl auf eine ganze Zahl runden") - (complex? (%a -> boolean) + (complex? (any -> boolean) "feststellen, ob ein Wert eine komplexe Zahl ist") (make-polar (real real -> number) @@ -226,7 +226,7 @@ "aktuelle Zeit in Sekunden seit einem unspezifizierten Startzeitpunkt berechnen")) ("boolesche Werte" - (boolean? (%a -> boolean) + (boolean? (any -> boolean) "feststellen, ob ein Wert ein boolescher Wert ist") ((DMdA-not not) (boolean -> boolean) @@ -235,45 +235,45 @@ (boolean=? (boolean boolean -> boolean) "Booleans auf Gleichheit testen") - (true? (%a -> boolean) + (true? (any -> boolean) "feststellen, ob ein Wert #t ist") - (false? (%a -> boolean) + (false? (any -> boolean) "feststellen, ob ein Wert #f ist")) ("Listen" (empty list "die leere Liste") - (make-pair (%a (list %a) -> (list %a)) + (make-pair (%a (list-of %a) -> (list-of %a)) "erzeuge ein Paar aus Element und Liste") - ((DMdA-cons cons) (%a -> boolean) + ((DMdA-cons cons) (%a (list-of %a) -> (list-of %a)) "erzeuge ein Paar aus Element und Liste") - (pair? (%a -> boolean) + (pair? (any -> boolean) "feststellen, ob ein Wert ein Paar ist") - (cons? (%a -> boolean) + (cons? (any -> boolean) "feststellen, ob ein Wert ein Paar ist") - (empty? (%a -> boolean) + (empty? (any -> boolean) "feststellen, ob ein Wert die leere Liste ist") - (first ((list %a) -> %a) + (first ((list-of %a) -> %a) "erstes Element eines Paars extrahieren") - (rest ((list %a) -> (list %a)) + (rest ((list-of %a) -> (list-of %a)) "Rest eines Paars extrahieren") - (list (%a ... -> (list %a)) + (list (%a ... -> (list-of %a)) "Liste aus den Argumenten konstruieren") - (length ((list %a) -> natural) + (length ((list-of %a) -> natural) "Länge einer Liste berechnen") - (fold ((%b (%a %b -> %b) (list %a) -> %b) - "Liste einfalten.")) + (fold (%b (%a %b -> %b) (list-of %a) -> %b) + "Liste einfalten.") - ((DMdA-append append) ((list %a) ... -> (list %a)) + ((DMdA-append append) ((list-of %a) ... -> (list-of %a)) "mehrere Listen aneinanderhängen") - (list-ref ((list %a) natural -> %a) + (list-ref ((list-of %a) natural -> %a) "das Listenelement an der gegebenen Position extrahieren") - (reverse ((list %a) -> (list %a)) + (reverse ((list-of %a) -> (list-of %a)) "Liste in umgekehrte Reihenfolge bringen")) ("Computer" @@ -281,7 +281,7 @@ "Signatur für Computer") (make-computer (string rational rational -> computer) "Computer aus Prozessorname, Arbeitsspeicher und Festplattenkapazität konstruieren") - (computer? (%a -> boolean) + (computer? (any -> boolean) "feststellen, ob Wert ein Computer ist") (computer-processor (computer -> string) "Prozessorname aus Computer extrahieren") @@ -295,7 +295,7 @@ "Signatur für Schokokekse") (make-chocolate-cookie (number number -> chocolate-cookie) "Schokokeks aus Schoko- und Keks-Anteil konstruieren") - (chocolate-cookie? (%a -> boolean) + (chocolate-cookie? (any -> boolean) "feststellen, ob ein Wert ein Schokokeks ist") (chocolate-cookie-chocolate (chocolate-cookie -> number) "Schoko-Anteil eines Schokokekses extrahieren") @@ -305,7 +305,7 @@ ;; #### Zeichen sollten noch dazu, Vektoren wahrscheinlich auch ("Zeichenketten" - (string? (%a -> boolean) + (string? (any -> boolean) "feststellen, ob ein Wert eine Zeichenkette ist") (string=? (string string string ... -> boolean) @@ -332,7 +332,7 @@ "Liefert Länge einer Zeichenkette")) ("Symbole" - (symbol? (%a -> boolean) + (symbol? (any -> boolean) "feststellen, ob ein Wert ein Symbol ist") (symbol->string (symbol -> string) "Symbol in Zeichenkette umwandeln") From a671fddc1875b7bc7b3805033fd75a46c23dcd32 Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Mon, 22 Nov 2010 15:33:49 +0100 Subject: [PATCH 065/255] Better signature for `string->number'. --- collects/deinprogramm/DMdA.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/deinprogramm/DMdA.rkt b/collects/deinprogramm/DMdA.rkt index fef2a25dcb..c8a524d9b4 100644 --- a/collects/deinprogramm/DMdA.rkt +++ b/collects/deinprogramm/DMdA.rkt @@ -216,7 +216,7 @@ (number->string (number -> string) "Zahl in Zeichenkette umwandeln") - (string->number (string -> (mixed number (one-of #f))) + (string->number (string -> (mixed number false)) "Zeichenkette in Zahl umwandeln, falls möglich") (random (natural -> natural) From dd44053911cf2d5c017c050c2db830706ce6f97a Mon Sep 17 00:00:00 2001 From: James Swaine Date: Mon, 22 Nov 2010 14:23:05 -0600 Subject: [PATCH 066/255] Add execution time logging for futures. --- src/racket/src/future.c | 24 ++++++++++++++++++++++-- src/racket/src/future.h | 4 ++++ 2 files changed, 26 insertions(+), 2 deletions(-) diff --git a/src/racket/src/future.c b/src/racket/src/future.c index 0b069eb862..d4831847fc 100644 --- a/src/racket/src/future.c +++ b/src/racket/src/future.c @@ -627,6 +627,7 @@ Scheme_Object *scheme_future(int argc, Scheme_Object *argv[]) Scheme_Native_Closure *nc; Scheme_Native_Closure_Data *ncd; Scheme_Object *lambda = argv[0]; + double time_of_start; /* Input validation */ scheme_check_proc_arity("future", 0, 0, argc, argv); @@ -669,6 +670,11 @@ Scheme_Object *scheme_future(int argc, Scheme_Object *argv[]) if (ft->status != PENDING_OVERSIZE) { mzrt_mutex_lock(fs->future_mutex); enqueue_future(fs, ft); + + /* Log the spawn time */ + time_of_start = scheme_get_inexact_milliseconds(); + ft->time_of_start = time_of_start; + /* Signal that a future is pending */ mzrt_sema_post(fs->future_pending_sema); /* Alert the runtime thread, in case it wants to @@ -722,6 +728,7 @@ static void future_in_runtime(future_t * volatile ft) Scheme_Thread *p = scheme_current_thread; Scheme_Object * volatile retval; future_t * volatile old_ft; + double time_of_completion; old_ft = p->current_ft; p->current_ft = ft; @@ -744,6 +751,8 @@ static void future_in_runtime(future_t * volatile ft) p->error_buf = savebuf; p->current_ft = old_ft; + time_of_completion = scheme_get_inexact_milliseconds(); + ft->time_of_completion = time_of_completion; ft->work_completed = 1; ft->retval = retval; ft->status = FINISHED; @@ -818,8 +827,16 @@ Scheme_Object *touch(int argc, Scheme_Object *argv[]) { retval = ft->retval; - LOG("Successfully touched future %d\n", ft->id); - + /* Log execution time */ + if (scheme_log_level_p(scheme_main_logger, SCHEME_LOG_DEBUG)) { + scheme_log(scheme_main_logger, SCHEME_LOG_DEBUG, 0, + "future: %d finished. start time: %f, finish time: %f (%f ms)", + ft->id, + ft->time_of_start, + ft->time_of_completion, + ft->time_of_completion - ft->time_of_start); + } + mzrt_mutex_unlock(fs->future_mutex); break; } @@ -1048,6 +1065,9 @@ void *worker_thread_future_loop(void *arg) /* Set the return val in the descriptor */ ft->work_completed = 1; ft->retval = v; + + /* Log future completion time */ + ft->time_of_completion = scheme_get_inexact_milliseconds(); /* In case of multiple values: */ send_special_result(ft, v); diff --git a/src/racket/src/future.h b/src/racket/src/future.h index 752244cbdd..2822791c5a 100644 --- a/src/racket/src/future.h +++ b/src/racket/src/future.h @@ -65,6 +65,10 @@ typedef struct future_t { unsigned long alloc_retval; int alloc_retval_counter; + /* For logging the future's execution time */ + double time_of_start; + double time_of_completion; + void *prim_func; int prim_protocol; Scheme_Object *arg_s0; From 76c07dd594160bd37b49aff654055aa28ed2fe93 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 19 Nov 2010 17:10:55 -0500 Subject: [PATCH 067/255] Improved `get-bindings' using regexps etc. (But note that it looks like it reimplements `form-urlencoded->alist'.) --- collects/net/cgi-unit.rkt | 102 ++++++++++++++++---------------------- 1 file changed, 42 insertions(+), 60 deletions(-) diff --git a/collects/net/cgi-unit.rkt b/collects/net/cgi-unit.rkt index 24a1ba3492..00c916e267 100644 --- a/collects/net/cgi-unit.rkt +++ b/collects/net/cgi-unit.rkt @@ -24,16 +24,15 @@ ;; -------------------------------------------------------------------- -;; query-chars->string : list (char) -> string +;; query-string->string : string -> string -;; -- The input is the characters post-processed as per Web specs, which +;; -- The input is the string post-processed as per Web specs, which ;; is as follows: ;; spaces are turned into "+"es and lots of things are turned into %XX, where ;; XX are hex digits, eg, %E7 for ~. The output is a regular Scheme string ;; with all the characters converted back. -(define (query-chars->string chars) - (form-urlencoded-decode (list->string chars))) +(define query-string->string form-urlencoded-decode) ;; string->html : string -> string ;; -- the input is raw text, the output is HTML appropriately quoted @@ -92,70 +91,53 @@ (define (output-http-headers) (printf "Content-type: text/html\r\n\r\n")) -;; read-until-char : iport x char -> list (char) x bool -;; -- operates on the default input port; the second value indicates whether -;; reading stopped because an EOF was hit (as opposed to the delimiter being -;; seen); the delimiter is not part of the result -(define (read-until-char ip delimiter?) - (let loop ([chars '()]) - (let ([c (read-char ip)]) - (cond [(eof-object? c) (values (reverse chars) #t)] - [(delimiter? c) (values (reverse chars) #f)] - [else (loop (cons c chars))])))) - -;; delimiter->predicate : -;; symbol -> (char -> bool) -;; returns a predicates to pass to read-until-char -(define (delimiter->predicate delimiter) +;; delimiter->predicate : symbol -> regexp +;; returns a regexp to read a chunk of text up to a delimiter (excluding it) +(define (delimiter->rx delimiter) (case delimiter - [(eq) (lambda (c) (char=? c #\=))] - [(amp) (lambda (c) (char=? c #\&))] - [(semi) (lambda (c) (char=? c #\;))] - [(amp-or-semi) (lambda (c) (or (char=? c #\&) (char=? c #\;)))])) + [(amp) #rx#"^[^&]*"] + [(semi) #rx#"^[^;]*"] + [(amp-or-semi) #rx#"^[^&;]*"] + [else (error 'delimiter->rx + "internal-error, unknown delimiter: ~e" delimiter)])) -;; read-name+value : iport -> (symbol + bool) x (string + bool) x bool -;; -- If the first value is false, so is the second, and the third is true, -;; indicating EOF was reached without any input seen. Otherwise, the first -;; and second values contain strings and the third is either true or false -;; depending on whether the EOF has been reached. The strings are processed -;; to remove the CGI spec "escape"s. This code is _slightly_ lax: it allows -;; an input to end in (current-alist-separator-mode). -;; It's not clear this is legal by the CGI spec, -;; which suggests that the last value binding must end in an EOF. It doesn't -;; look like this matters. It would also introduce needless modality and -;; reduce flexibility. -(define (read-name+value ip) - (let-values ([(name eof?) (read-until-char ip (delimiter->predicate 'eq))]) - (cond [(and eof? (null? name)) (values #f #f #t)] - [eof? - (generate-error-output - (list "Server generated malformed input for POST method:" - (string-append - "No binding for `" (list->string name) "' field.")))] - [else (let-values ([(value eof?) - (read-until-char - ip - (delimiter->predicate - (current-alist-separator-mode)))]) - (values (string->symbol (query-chars->string name)) - (query-chars->string value) - eof?))]))) +;; get-bindings* : iport -> (listof (cons symbol string)) +;; Reads all bindings from the input port. The strings are processed to +;; remove the CGI spec "escape"s. +;; This code is _slightly_ lax: it allows an input to end in +;; (current-alist-separator-mode). It's not clear this is legal by the +;; CGI spec, which suggests that the last value binding must end in an +;; EOF. It doesn't look like this matters. +;; ELI: * Keeping this behavior for now, maybe better to remove it? +;; * Looks like `form-urlencoded->alist' is doing almost exactly +;; the same job this code does. +(define (get-bindings* method ip) + (define (err fmt . xs) + (generate-error-output + (list (format "Server generated malformed input for ~a method:" method) + (apply format fmt xs)))) + (define value-rx (delimiter->rx (current-alist-separator-mode))) + (define (process str) (query-string->string (bytes->string/utf-8 str))) + (let loop ([bindings '()]) + (if (eof-object? (peek-char ip)) + (reverse bindings) + (let () + (define name (car (or (regexp-match #rx"^[^=]+" ip) + (err "Missing field name before `='")))) + (unless (eq? #\= (read-char ip)) + (err "No binding for `~a' field." name)) + (define value (car (regexp-match value-rx ip))) + (read-char ip) ; consume the delimiter, possibly eof (retested above) + (loop (cons (cons (string->symbol (process name)) (process value)) + bindings)))))) ;; get-bindings/post : () -> bindings (define (get-bindings/post) - (let-values ([(name value eof?) (read-name+value (current-input-port))]) - (cond [(and eof? (not name)) null] - [(and eof? name) (list (cons name value))] - [else (cons (cons name value) (get-bindings/post))]))) + (get-bindings* "POST" (current-input-port))) ;; get-bindings/get : () -> bindings (define (get-bindings/get) - (let ([p (open-input-string (getenv "QUERY_STRING"))]) - (let loop () - (let-values ([(name value eof?) (read-name+value p)]) - (cond [(and eof? (not name)) null] - [(and eof? name) (list (cons name value))] - [else (cons (cons name value) (loop))]))))) + (get-bindings* "GET" (open-input-string (getenv "QUERY_STRING")))) ;; get-bindings : () -> bindings (define (get-bindings) From f3c62a0efd67a4ea9da6215920d9bdd5c173b8ce Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 23 Nov 2010 10:27:07 -0500 Subject: [PATCH 068/255] Require a non-negative exact integer argument for `take'. Closes PR 11458. --- collects/lazy/lazy.rkt | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/collects/lazy/lazy.rkt b/collects/lazy/lazy.rkt index 055f1faa23..d743ae5a5f 100644 --- a/collects/lazy/lazy.rkt +++ b/collects/lazy/lazy.rkt @@ -446,7 +446,7 @@ (define* (~list-ref l k) (let ([k (! k)]) - (unless (and (integer? k) (exact? k) (<= 0 k)) + (unless (exact-nonnegative-integer? k) (raise-type-error 'list-ref "non-negative exact integer" 1 l k)) (let loop ([k k] [l (! l)]) (cond [(not (pair? l)) @@ -455,7 +455,7 @@ [else (loop (sub1 k) (! (cdr l)))])))) (define* (~list-tail l k) (let ([k (! k)]) - (unless (and (integer? k) (exact? k) (<= 0 k)) + (unless (exact-nonnegative-integer? k) (raise-type-error 'list-tail "non-negative exact integer" 1 l k)) (let loop ([k k] [l l]) ; don't force here -- unlike list-ref (cond [(zero? k) l] @@ -575,10 +575,13 @@ ;; Extra functionality that is useful for lazy list stuff (define* (take n l) - (let loop ([n (! n)] [l (! l)]) - (cond [(or (<= n 0) (null? l)) '()] - [(pair? l) (cons (car l) (~ (loop (sub1 n) (! (cdr l)))))] - [else (error 'take "not a proper list: ~e" l)]))) + (let ([n (! n)] [l (! l)]) + (if (exact-nonnegative-integer? n) + (let loop ([n n] [l l]) + (cond [(or (<= n 0) (null? l)) '()] + [(pair? l) (cons (car l) (~ (loop (sub1 n) (! (cdr l)))))] + [else (error 'take "not a proper list: ~e" l)])) + (raise-type-error 'take "non-negative exact integer" 0 n l)))) ;; not like Haskell's `cycle' that consumes a list (define* (cycle . l) @@ -692,7 +695,7 @@ (define* (build-list n f) (let ([n (! n)] [f (! f)]) - (unless (and (integer? n) (exact? n) (>= n 0)) + (unless (exact-nonnegative-integer? n) (error 'build-list "~s must be an exact integer >= 0" n)) (unless (procedure? f) (error 'build-list "~s must be a procedure" f)) From 142cdb800f5c2a62a355befe17e135f618d7e354 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 23 Nov 2010 09:39:28 -0700 Subject: [PATCH 069/255] fix GC interaction for non-Racket thread and #:async-apply callbacks --- src/foreign/foreign.c | 122 ++++++++++++++++++++++++-------------- src/foreign/foreign.rktc | 124 ++++++++++++++++++++++++--------------- 2 files changed, 155 insertions(+), 91 deletions(-) diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index d14cb099c0..ce7ba45ff1 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -1187,10 +1187,10 @@ END_XFORM_SKIP; #endif /* The sync field: - NULL => non-atomic mode, no sync proc + NULL => non-atomic mode #t => atomic mode, no sync proc - (rcons queue proc) => non-atomic mode, sync proc - (box (rcons queue proc)) => atomic mode, sync proc */ + proc => non-atomic mode, sync proc + (box proc) => atomic mode, sync proc */ /*****************************************************************************/ /* Pointer objects */ @@ -2709,7 +2709,7 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata) argv = argv_stack; else argv = scheme_malloc(argc * sizeof(Scheme_Object*)); - if (data->sync && !SCHEME_RPAIRP(data->sync)) + if (data->sync && !SCHEME_PROCP(data->sync)) scheme_start_in_scheduler(); for (i=0, p=data->itypes; iproc, argc, argv); SCHEME2C(data->otype, resultp, 0, p, NULL, NULL, 1); - if (data->sync && !SCHEME_RPAIRP(data->sync)) + if (data->sync && !SCHEME_PROCP(data->sync)) scheme_end_in_scheduler(); } @@ -2786,7 +2786,6 @@ void scheme_check_foreign_work(void) proc = data->sync; if (SCHEME_BOXP(proc)) proc = SCHEME_BOX_VAL(proc); - proc = SCHEME_CDR(proc); scheme_start_in_scheduler(); _scheme_apply(proc, 1, a); @@ -2802,49 +2801,44 @@ void scheme_check_foreign_work(void) void ffi_queue_callback(ffi_cif* cif, void* resultp, void** args, void *userdata) XFORM_SKIP_PROC { - ffi_callback_struct *data; - - data = extract_ffi_callback(userdata); - #ifdef MZ_USE_MZRT - { - FFI_Sync_Queue *queue; - Scheme_Object *o; + /* This function must not refer to any GCable address, not even + temporarily, because a GC may occur concurrent to this + function if it's in another thread. */ + FFI_Sync_Queue *queue; - o = data->sync; - if (SCHEME_BOXP(o)) o = SCHEME_BOX_VAL(o); + queue = (FFI_Sync_Queue *)((void **)userdata)[1]; + userdata = ((void **)userdata)[0]; - queue = (FFI_Sync_Queue *)SCHEME_CAR(o); + if (queue->orig_thread != mz_proc_thread_self()) { + Queued_Callback *qc; + mzrt_sema *sema; - if (queue->orig_thread != mz_proc_thread_self()) { - Queued_Callback *qc; - mzrt_sema *sema; + mzrt_sema_create(&sema, 0); - mzrt_sema_create(&sema, 0); + qc = (Queued_Callback *)malloc(sizeof(Queued_Callback)); + qc->cif = cif; + qc->resultp = resultp; + qc->args = args; + qc->userdata = userdata; + qc->sema = sema; + qc->called = 0; - qc = (Queued_Callback *)malloc(sizeof(Queued_Callback)); - qc->cif = cif; - qc->resultp = resultp; - qc->args = args; - qc->userdata = userdata; - qc->sema = sema; - qc->called = 0; + mzrt_mutex_lock(queue->lock); + qc->next = queue->callbacks; + queue->callbacks = qc; + mzrt_mutex_unlock(queue->lock); + scheme_signal_received_at(queue->sig_hand); - mzrt_mutex_lock(queue->lock); - qc->next = queue->callbacks; - queue->callbacks = qc; - mzrt_mutex_unlock(queue->lock); - scheme_signal_received_at(queue->sig_hand); + /* wait for the callback to be invoked in the main thread */ + mzrt_sema_wait(sema); - /* wait for the callback to be invoked in the main thread */ - mzrt_sema_wait(sema); - - mzrt_sema_destroy(sema); - free(qc); - return; - } + mzrt_sema_destroy(sema); + free(qc); + return; } #endif + ffi_do_callback(cif, resultp, args, userdata); } @@ -2858,6 +2852,7 @@ typedef struct closure_and_cif_struct { void *data; #endif } closure_and_cif; + /* free the above */ void free_cl_cif_args(void *ignored, void *p) { @@ -2873,6 +2868,20 @@ void free_cl_cif_args(void *ignored, void *p) scheme_free_code(p); } +#ifdef MZ_USE_MZRT +void free_cl_cif_queue_args(void *ignored, void *p) +{ + void *data = ((closure_and_cif*)p)->data; + void **q = (void **)data; + data = q[0]; + free(q); +#ifdef MZ_PRECISE_GC + GC_free_immobile_box((void**)data); +#endif + scheme_free_code(p); +} +#endif + /* (ffi-callback scheme-proc in-types out-type [abi atomic? sync]) -> ffi-callback */ /* the treatment of in-types and out-types is similar to that in ffi-call */ /* the real work is done by ffi_do_callback above */ @@ -2921,6 +2930,11 @@ static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[]) GC_CAN_IGNORE ffi_closure *cl; GC_CAN_IGNORE closure_and_cif *cl_cif_args; GC_CAN_IGNORE ffi_callback_t do_callback; + GC_CAN_IGNORE void *callback_data; + #ifdef MZ_USE_MZRT + int keep_queue = 0; + #endif + if (!SCHEME_PROCP(argv[0])) scheme_wrong_type(MYNAME, "procedure", 0, argc, argv); nargs = scheme_proper_list_length(itypes); @@ -2948,9 +2962,9 @@ static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[]) ffi_sync_queue->sig_hand = sig_hand; ffi_sync_queue->callbacks = NULL; } - sync = scheme_make_raw_pair((Scheme_Object *)ffi_sync_queue, - argv[5]); + sync = argv[5]; if (is_atomic) sync = scheme_box(sync); + keep_queue = 1; #endif do_callback = ffi_queue_callback; } else @@ -2979,18 +2993,36 @@ static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[]) # ifdef MZ_PRECISE_GC { /* put data in immobile, weak box */ - void **tmp; + GC_CAN_IGNORE void **tmp; tmp = GC_malloc_immobile_box(GC_malloc_weak_box(data, NULL, 0, 1)); - cl_cif_args->data = (struct immobile_box*)tmp; + callback_data = (struct immobile_box*)tmp; } # else /* MZ_PRECISE_GC undefined */ - cl_cif_args->data = (void*)data; + callback_data = (void*)data; # endif /* MZ_PRECISE_GC */ + #ifdef MZ_USE_MZRT + if (keep_queue) { + /* For ffi_queue_callback(), add a level of indirection in + `data' to hold the place-specific `ffi_sync_queue'. + Use `free_cl_cif_data_args' to clean up this extra level. */ + GC_CAN_IGNORE void **tmp; + tmp = (void **)malloc(sizeof(void*) * 2); + tmp[0] = callback_data; + tmp[1] = ffi_sync_queue; + callback_data = (void *)tmp; + } + #endif + cl_cif_args->data = callback_data; if (ffi_prep_closure(cl, cif, do_callback, (void*)(cl_cif_args->data)) != FFI_OK) scheme_signal_error ("internal error: ffi_prep_closure did not return FFI_OK"); - scheme_register_finalizer(data, free_cl_cif_args, cl_cif_args, NULL, NULL); + #ifdef MZ_USE_MZRT + if (keep_queue) + scheme_register_finalizer(data, free_cl_cif_queue_args, cl_cif_args, NULL, NULL); + else + #endif + scheme_register_finalizer(data, free_cl_cif_args, cl_cif_args, NULL, NULL); return (Scheme_Object*)data; } #undef MYNAME diff --git a/src/foreign/foreign.rktc b/src/foreign/foreign.rktc index 47ceb4d0c2..7751438019 100755 --- a/src/foreign/foreign.rktc +++ b/src/foreign/foreign.rktc @@ -983,10 +983,10 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym) [sync "Scheme_Object*"]] /* The sync field: - NULL => non-atomic mode, no sync proc + NULL => non-atomic mode #t => atomic mode, no sync proc - (rcons queue proc) => non-atomic mode, sync proc - (box (rcons queue proc)) => atomic mode, sync proc */ + proc => non-atomic mode, sync proc + (box proc) => atomic mode, sync proc */ /*****************************************************************************/ /* Pointer objects */ @@ -2077,7 +2077,7 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata) argv = argv_stack; else argv = scheme_malloc(argc * sizeof(Scheme_Object*)); - if (data->sync && !SCHEME_RPAIRP(data->sync)) + if (data->sync && !SCHEME_PROCP(data->sync)) scheme_start_in_scheduler(); for (i=0, p=data->itypes; iproc, argc, argv); SCHEME2C(data->otype, resultp, 0, p, NULL, NULL, 1); - if (data->sync && !SCHEME_RPAIRP(data->sync)) + if (data->sync && !SCHEME_PROCP(data->sync)) scheme_end_in_scheduler(); } @@ -2154,7 +2154,6 @@ void scheme_check_foreign_work(void) proc = data->sync; if (SCHEME_BOXP(proc)) proc = SCHEME_BOX_VAL(proc); - proc = SCHEME_CDR(proc); scheme_start_in_scheduler(); _scheme_apply(proc, 1, a); @@ -2170,49 +2169,44 @@ void scheme_check_foreign_work(void) void ffi_queue_callback(ffi_cif* cif, void* resultp, void** args, void *userdata) XFORM_SKIP_PROC { - ffi_callback_struct *data; - - data = extract_ffi_callback(userdata); - #ifdef MZ_USE_MZRT - { - FFI_Sync_Queue *queue; - Scheme_Object *o; + /* This function must not refer to any GCable address, not even + temporarily, because a GC may occur concurrent to this + function if it's in another thread. */ + FFI_Sync_Queue *queue; - o = data->sync; - if (SCHEME_BOXP(o)) o = SCHEME_BOX_VAL(o); + queue = (FFI_Sync_Queue *)((void **)userdata)[1]; + userdata = ((void **)userdata)[0]; + + if (queue->orig_thread != mz_proc_thread_self()) { + Queued_Callback *qc; + mzrt_sema *sema; - queue = (FFI_Sync_Queue *)SCHEME_CAR(o); + mzrt_sema_create(&sema, 0); - if (queue->orig_thread != mz_proc_thread_self()) { - Queued_Callback *qc; - mzrt_sema *sema; + qc = (Queued_Callback *)malloc(sizeof(Queued_Callback)); + qc->cif = cif; + qc->resultp = resultp; + qc->args = args; + qc->userdata = userdata; + qc->sema = sema; + qc->called = 0; - mzrt_sema_create(&sema, 0); + mzrt_mutex_lock(queue->lock); + qc->next = queue->callbacks; + queue->callbacks = qc; + mzrt_mutex_unlock(queue->lock); + scheme_signal_received_at(queue->sig_hand); - qc = (Queued_Callback *)malloc(sizeof(Queued_Callback)); - qc->cif = cif; - qc->resultp = resultp; - qc->args = args; - qc->userdata = userdata; - qc->sema = sema; - qc->called = 0; + /* wait for the callback to be invoked in the main thread */ + mzrt_sema_wait(sema); - mzrt_mutex_lock(queue->lock); - qc->next = queue->callbacks; - queue->callbacks = qc; - mzrt_mutex_unlock(queue->lock); - scheme_signal_received_at(queue->sig_hand); - - /* wait for the callback to be invoked in the main thread */ - mzrt_sema_wait(sema); - - mzrt_sema_destroy(sema); - free(qc); - return; - } + mzrt_sema_destroy(sema); + free(qc); + return; } #endif + ffi_do_callback(cif, resultp, args, userdata); } @@ -2226,6 +2220,7 @@ typedef struct closure_and_cif_struct { void *data; #endif } closure_and_cif; + /* free the above */ void free_cl_cif_args(void *ignored, void *p) { @@ -2241,6 +2236,20 @@ void free_cl_cif_args(void *ignored, void *p) scheme_free_code(p); } +#ifdef MZ_USE_MZRT +void free_cl_cif_queue_args(void *ignored, void *p) +{ + void *data = ((closure_and_cif*)p)->data; + void **q = (void **)data; + data = q[0]; + free(q); +#ifdef MZ_PRECISE_GC + GC_free_immobile_box((void**)data); +#endif + scheme_free_code(p); +} +#endif + /* (ffi-callback scheme-proc in-types out-type [abi atomic? sync]) -> ffi-callback */ /* the treatment of in-types and out-types is similar to that in ffi-call */ /* the real work is done by ffi_do_callback above */ @@ -2287,6 +2296,11 @@ void free_cl_cif_args(void *ignored, void *p) GC_CAN_IGNORE ffi_closure *cl; GC_CAN_IGNORE closure_and_cif *cl_cif_args; GC_CAN_IGNORE ffi_callback_t do_callback; + GC_CAN_IGNORE void *callback_data; +#ifdef MZ_USE_MZRT + int keep_queue = 0; +#endif + if (!SCHEME_PROCP(argv[0])) scheme_wrong_type(MYNAME, "procedure", 0, argc, argv); nargs = scheme_proper_list_length(itypes); @@ -2314,9 +2328,9 @@ void free_cl_cif_args(void *ignored, void *p) ffi_sync_queue->sig_hand = sig_hand; ffi_sync_queue->callbacks = NULL; } - sync = scheme_make_raw_pair((Scheme_Object *)ffi_sync_queue, - argv[5]); + sync = argv[5]; if (is_atomic) sync = scheme_box(sync); + keep_queue = 1; #endif do_callback = ffi_queue_callback; } else @@ -2341,18 +2355,36 @@ void free_cl_cif_args(void *ignored, void *p) @@@IFDEF{MZ_PRECISE_GC}{ { /* put data in immobile, weak box */ - void **tmp; + GC_CAN_IGNORE void **tmp; tmp = GC_malloc_immobile_box(GC_malloc_weak_box(data, NULL, 0, 1)); - cl_cif_args->data = (struct immobile_box*)tmp; + callback_data = (struct immobile_box*)tmp; } }{ - cl_cif_args->data = (void*)data; + callback_data = (void*)data; } +#ifdef MZ_USE_MZRT + if (keep_queue) { + /* For ffi_queue_callback(), add a level of indirection in + `data' to hold the place-specific `ffi_sync_queue'. + Use `free_cl_cif_data_args' to clean up this extra level. */ + GC_CAN_IGNORE void **tmp; + tmp = (void **)malloc(sizeof(void*) * 2); + tmp[0] = callback_data; + tmp[1] = ffi_sync_queue; + callback_data = (void *)tmp; + } +#endif + cl_cif_args->data = callback_data; if (ffi_prep_closure(cl, cif, do_callback, (void*)(cl_cif_args->data)) != FFI_OK) scheme_signal_error ("internal error: ffi_prep_closure did not return FFI_OK"); - scheme_register_finalizer(data, free_cl_cif_args, cl_cif_args, NULL, NULL); +#ifdef MZ_USE_MZRT + if (keep_queue) + scheme_register_finalizer(data, free_cl_cif_queue_args, cl_cif_args, NULL, NULL); + else +#endif + scheme_register_finalizer(data, free_cl_cif_args, cl_cif_args, NULL, NULL); return (Scheme_Object*)data; } From 510c3f8a3362fe67979e805910b90c5bd440f586 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 23 Nov 2010 10:02:45 -0700 Subject: [PATCH 070/255] cocoa: try to fix problem with drifting gc-blit window --- collects/mred/private/wx/cocoa/canvas.rkt | 5 +++++ collects/mred/private/wx/cocoa/frame.rkt | 8 ++++++++ collects/mred/private/wx/cocoa/panel.rkt | 4 ++++ collects/mred/private/wx/cocoa/queue.rkt | 8 ++++++-- collects/mred/private/wx/cocoa/window.rkt | 2 ++ 5 files changed, 25 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 7488e4905d..34f80512e4 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -404,6 +404,11 @@ (super show-children) (resume-all-reg-blits)) + (define/override (fixup-locations-children) + ;; in atomic mode + (suspend-all-reg-blits) + (resume-all-reg-blits)) + (define/private (do-set-size x y w h) (when (pair? blits) (atomically (suspend-all-reg-blits))) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 7779a02075..3956ed8f68 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -319,6 +319,9 @@ (define/override (show-children) (when saved-child (send saved-child show-children))) + (define/override (fixup-locations-children) + (when saved-child + (send saved-child fixup-locations-children))) (define/override (children-accept-drag on?) (when saved-child @@ -532,3 +535,8 @@ (make-NSPoint x (- (NSSize-height (NSRect-size f)) y))) belowWindowWithWindowNumber: #:type _NSInteger 0)]) (atomically (hash-ref all-windows n #f)))) + +(set-fixup-window-locations! + (lambda () + (for ([f (in-hash-values all-windows)]) + (send f fixup-locations-children)))) diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt index 48a5c03feb..6d57fecc04 100644 --- a/collects/mred/private/wx/cocoa/panel.rkt +++ b/collects/mred/private/wx/cocoa/panel.rkt @@ -40,6 +40,10 @@ (define/override (show-children) (for ([child (in-list children)]) (send child show-children))) + + (define/override (fixup-locations-children) + (for ([child (in-list children)]) + (send child fixup-locations-children))) (define/override (paint-children) (for ([child (in-list children)]) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 654b8cca68..651d0eea41 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -19,6 +19,7 @@ set-eventspace-hook! set-front-hook! set-menu-bar-hooks! + set-fixup-window-locations! post-dummy-event try-to-sync-refresh) @@ -58,8 +59,11 @@ (let ([priviledged-custodian ((get-ffi-obj 'scheme_make_custodian #f (_fun _pointer -> _scheme)) #f)]) (parameterize ([current-custodian priviledged-custodian]) (thread (lambda () (sleep 5.0))))) - ;; FIXME: Also need to reset blit windows, since OS may move them incorrectly - (void)]) + ;; Also need to reset blit windows, since OS may move them incorrectly: + (fixup-window-locations)]) + +(define fixup-window-locations void) +(define (set-fixup-window-locations! f) (set! fixup-window-locations f)) ;; In case we were started in an executable without a bundle, ;; explicitly register with the dock so the application can receive diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 4243556621..a76e56fe3a 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -379,6 +379,8 @@ (focus-is-on #f)) (define/public (show-children) (void)) + (define/public (fixup-locations-children) + (void)) (define/public (fix-dc) (void)) (define/public (paint-children) From fd53321823d54733d6d5e4ff93893c406000dfe0 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 23 Nov 2010 12:34:26 -0600 Subject: [PATCH 071/255] rackunit: bring back source locations for check-equal? used in 'ho' position --- collects/rackunit/private/check.rkt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/rackunit/private/check.rkt b/collects/rackunit/private/check.rkt index f4bb83db56..75749047ac 100644 --- a/collects/rackunit/private/check.rkt +++ b/collects/rackunit/private/check.rkt @@ -171,7 +171,9 @@ (name (identifier? #'name) (syntax/loc stx - check-secret-name))))) + (λ (formal ...) (check-secret-name formal ... + #:location (quote loc) + #:expression (quote (name actual ...))))))))) )))))) (define-syntax define-simple-check From 698b3a6c90a177b993df675bb176ddc7dd3712fb Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 23 Nov 2010 14:07:29 -0500 Subject: [PATCH 072/255] Throw an error if the number input for `take' is too big. Note that this is usually delayed so it's not too useful. Note that it *doesn't* force the list -- see the explanation in the comment. (Related to PR 11458.) --- collects/lazy/lazy.rkt | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/collects/lazy/lazy.rkt b/collects/lazy/lazy.rkt index d743ae5a5f..cba16e6211 100644 --- a/collects/lazy/lazy.rkt +++ b/collects/lazy/lazy.rkt @@ -575,10 +575,16 @@ ;; Extra functionality that is useful for lazy list stuff (define* (take n l) - (let ([n (! n)] [l (! l)]) + (let ([n0 (! n)] [l (! l)]) (if (exact-nonnegative-integer? n) - (let loop ([n n] [l l]) - (cond [(or (<= n 0) (null? l)) '()] + (let loop ([n n0] [l l]) + (cond [(null? l) + (if (n . > . 0) + ;; it would be fine to force the whole list (since we now + ;; know it's finite), but doing so means keeping a reference + ;; to its head, which can lead to memory leaks. + (error 'take "index ~e too large for input list" n0) + '())] [(pair? l) (cons (car l) (~ (loop (sub1 n) (! (cdr l)))))] [else (error 'take "not a proper list: ~e" l)])) (raise-type-error 'take "non-negative exact integer" 0 n l)))) From 2c74984fcd442fd73802244801946e2d4dd8ba8c Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 22 Nov 2010 17:16:36 -0500 Subject: [PATCH 073/255] More precise type for sgn. Closes PR 11424. --- collects/typed-scheme/private/base-env-numeric.rkt | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/collects/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt index b6f30e81dd..210b2f6d2f 100644 --- a/collects/typed-scheme/private/base-env-numeric.rkt +++ b/collects/typed-scheme/private/base-env-numeric.rkt @@ -434,7 +434,14 @@ ;; scheme/math -[sgn (-Real . -> . -Real)] +[sgn (cl->* (-Zero . -> . -Zero) + (-ExactPositiveInteger . -> . -PositiveFixnum) + (-ExactNonnegativeInteger . -> . -NonnegativeFixnum) + (-ExactRational . -> . -Fixnum) + (-Flonum . -> . -Flonum) + (-InexactReal . -> . -InexactReal) + (-Real . -> . -Real))] + [pi -NonnegativeFlonum] [sqr (cl->* (-> -Pos -Pos) (-> -Integer -Nat) From e10f139ad82748ee5d6b959c1f6225886b41084d Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 22 Nov 2010 17:21:26 -0500 Subject: [PATCH 074/255] Fix type for raise-type-error. Closes PR 11426. --- collects/typed-scheme/private/base-env-indexing-abs.rkt | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/typed-scheme/private/base-env-indexing-abs.rkt b/collects/typed-scheme/private/base-env-indexing-abs.rkt index c99ba38fee..48150e6d11 100644 --- a/collects/typed-scheme/private/base-env-indexing-abs.rkt +++ b/collects/typed-scheme/private/base-env-indexing-abs.rkt @@ -173,9 +173,9 @@ [random (cl-> [(index-type) -Nat] [() -Real])] [raise-type-error - (cl-> - [(Sym -String Univ) (Un)] - [(Sym -String index-type (-lst Univ)) (Un)])] + (cl->* + [-> Sym -String Univ (Un)] + [->* (list Sym -String index-type) Univ (Un)])] )) From 7a7fe577cd464c80b4b344aef4a072c25c7652fa Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 22 Nov 2010 17:24:53 -0500 Subject: [PATCH 075/255] Add type for integer-sqrt. Closes PR 11427. --- collects/typed-scheme/private/base-env-numeric.rkt | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/collects/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt index 210b2f6d2f..b840276b17 100644 --- a/collects/typed-scheme/private/base-env-numeric.rkt +++ b/collects/typed-scheme/private/base-env-numeric.rkt @@ -414,6 +414,12 @@ (-NonnegativeFlonum . -> . -NonnegativeFlonum) (-FloatComplex . -> . -FloatComplex) (N . -> . N))] +[integer-sqrt (cl->* + (-Zero . -> . -Zero) + (-NonnegativeFixnum . -> . -NonnegativeFixnum) + (-Nat . -> . -Nat) + (-NonnegativeFlonum . -> . -NonnegativeFlonum) + (-Real . -> . N))] [log (cl->* (-Pos . -> . -Real) (-FloatComplex . -> . -FloatComplex) From 58d1f75dc1b1e2d9c17427641fa6f295aec96706 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 22 Nov 2010 17:33:53 -0500 Subject: [PATCH 076/255] Fix type for arithmetic-shift. Closes PR 11428. --- collects/typed-scheme/private/base-env-numeric.rkt | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt index b840276b17..b5ebab7bc2 100644 --- a/collects/typed-scheme/private/base-env-numeric.rkt +++ b/collects/typed-scheme/private/base-env-numeric.rkt @@ -338,9 +338,12 @@ (-Nat -Nat . -> . (-values (list -Nat -Nat))) (-Integer -Integer . -> . (-values (list -Integer -Integer))))] -[arithmetic-shift (cl->* (-Fixnum (Un -NegativeFixnum (-val 0)) . -> . -Fixnum) - (-Nat -Nat . -> . -Nat) +[arithmetic-shift (cl->* ((-val 0) (Un -NegativeFixnum (-val 0)) . -> . (-val 0)) + (-NonnegativeFixnum (Un -NegativeFixnum (-val 0)) . -> . -NonnegativeFixnum) + (-Fixnum (Un -NegativeFixnum (-val 0)) . -> . -Fixnum) + (-Nat -Integer . -> . -Nat) (-Integer -Integer . -> . -Integer))] + [bitwise-and (cl->* (null -NonnegativeFixnum . ->* . -NonnegativeFixnum) ((list -Integer) -NonnegativeFixnum . ->* . -NonnegativeFixnum) (null -Fixnum . ->* . -Fixnum) From 54991835d603a81ddaee6845e4930bfe0ab9de24 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 22 Nov 2010 17:36:15 -0500 Subject: [PATCH 077/255] Add type for fl->exact-integer. Closes PR 11429. --- collects/typed-scheme/private/base-env-numeric.rkt | 3 +++ 1 file changed, 3 insertions(+) diff --git a/collects/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt index b5ebab7bc2..88cab60338 100644 --- a/collects/typed-scheme/private/base-env-numeric.rkt +++ b/collects/typed-scheme/private/base-env-numeric.rkt @@ -381,6 +381,9 @@ [inexact->exact (cl->* (-Real . -> . -ExactRational) (N . -> . N))] +[fl->exact-integer (cl->* + (-NonnegativeFlonum . -> . -Nat) + (-Flonum . -> . -Integer))] [floor rounder] [ceiling rounder] From e7c252739ddab37973cf3c013660d6c2244c44b8 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 22 Nov 2010 17:37:40 -0500 Subject: [PATCH 078/255] Fix type for abs. Closes PR 11430. --- collects/typed-scheme/private/base-env-numeric.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt index 88cab60338..045282ef9e 100644 --- a/collects/typed-scheme/private/base-env-numeric.rkt +++ b/collects/typed-scheme/private/base-env-numeric.rkt @@ -368,6 +368,7 @@ (-Fixnum . -> . -NonnegativeFixnum) (-Pos . -> . -Pos) (-Integer . -> . -Nat) + (-ExactRational . -> . -ExactRational) (-Flonum . -> . -NonnegativeFlonum) (-InexactReal . -> . -InexactReal) (-Real . -> . -Real))] From e64f8be932eb91258310695592107c2e0674172e Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 22 Nov 2010 17:42:15 -0500 Subject: [PATCH 079/255] Fix open-input-output-file doc. Closes PR 11371. --- collects/scribblings/reference/file-ports.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/reference/file-ports.scrbl b/collects/scribblings/reference/file-ports.scrbl index eec76b0c28..c1d8c47996 100644 --- a/collects/scribblings/reference/file-ports.scrbl +++ b/collects/scribblings/reference/file-ports.scrbl @@ -192,7 +192,7 @@ A @tech{path} value that is the @tech{cleanse}d version of @defproc[(open-input-output-file [path path-string?] [#:mode mode-flag (or/c 'binary 'text) 'binary] - [#:exists exists-flag (or/c 'error 'append 'update + [#:exists exists-flag (or/c 'error 'append 'update 'can-update 'replace 'truncate 'truncate/replace) 'error]) (values input-port? output-port?)]{ From e3153e6d213fe3ce7deca3b2e2ee224c15cf42fc Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 16 Nov 2010 16:29:38 -0700 Subject: [PATCH 080/255] Adding normalization display --- collects/tests/stress.rkt | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) diff --git a/collects/tests/stress.rkt b/collects/tests/stress.rkt index 284b301a34..3aa0733e19 100644 --- a/collects/tests/stress.rkt +++ b/collects/tests/stress.rkt @@ -70,8 +70,25 @@ #:key (λ (v) (vector-ref v 1)))) (define (stress-display how-many res) + (define-values + (min-cpu min-real min-gc) + (for/fold ([min-cpu +inf.0] + [min-real +inf.0] + [min-gc +inf.0]) + ([v (in-list res)]) + (match-define (vector label cpu real gc) v) + (printf "~a: cpu: ~a real: ~a gc: ~a (averaged over ~a runs)\n" + label cpu real gc how-many) + (values (min min-cpu cpu) + (min min-real real) + (min min-gc gc)))) + (define (norm min x) + (if (zero? min) + "inf" + (real->decimal-string (/ x min)))) + (printf "Normalized:\n") (for ([v (in-list res)]) (match-define (vector label cpu real gc) v) (printf "~a: cpu: ~a real: ~a gc: ~a (averaged over ~a runs)\n" - label cpu real gc how-many)) + label (norm min-cpu cpu) (norm min-real real) (norm min-gc gc) how-many)) (newline)) \ No newline at end of file From 88fb21fa26ca5bfb400c9e353d84cc9f004cf37f Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 16 Nov 2010 16:29:49 -0700 Subject: [PATCH 081/255] cleanup --- collects/meta/drdr/plt-build.rkt | 28 ++++++++++++++++------------ 1 file changed, 16 insertions(+), 12 deletions(-) diff --git a/collects/meta/drdr/plt-build.rkt b/collects/meta/drdr/plt-build.rkt index 7aeec592c5..9fa0a24b75 100644 --- a/collects/meta/drdr/plt-build.rkt +++ b/collects/meta/drdr/plt-build.rkt @@ -211,7 +211,7 @@ (lambda () (list* gracket-path "-display" - (format ":~a" (+ XSERVER-OFFSET (current-worker))) + (format ":~a" (cpu->child (current-worker))) rst)) #f)] [_ @@ -224,7 +224,7 @@ void (λ () (define l (pth-cmd)) - (with-env (["DISPLAY" (format ":~a" (+ XSERVER-OFFSET (current-worker)))]) + (with-env (["DISPLAY" (format ":~a" (cpu->child (current-worker)))]) (with-temporary-home-directory (with-temporary-directory (run/collect/wait/log log-pth @@ -277,7 +277,10 @@ (recur-many (sub1 i) r f))))) (define XSERVER-OFFSET 20) -(define PARENT-X-SERVER 19) +(define (cpu->parent cpu-i) + (+ XSERVER-OFFSET (* cpu-i 2) 0)) +(define (cpu->child cpu-i) + (+ XSERVER-OFFSET (* cpu-i 2) 1)) (define (integrate-revision rev) (define test-dir @@ -325,6 +328,7 @@ (with-running-program (Xvfb-path) (list (format ":~a" i) "-ac" "-rfbauth" "/home/jay/.vnc/passwd") (lambda () + (sleep 1) (with-running-program (fluxbox-path) (list "-display" (format ":~a" i) "-rc" "/home/jay/.fluxbox/init") (if parent @@ -335,15 +339,15 @@ inner)) inner))))) - (start-x-server - PARENT-X-SERVER #f - (λ () - (recur-many (number-of-cpus) - (lambda (j inner) - (define i (+ j XSERVER-OFFSET)) - (start-x-server i PARENT-X-SERVER inner)) - (lambda () - (test-revision rev))))))) + (recur-many (number-of-cpus) + (lambda (cpu-i inner) + (define parent (cpu->parent cpu-i)) + (define child (cpu->child cpu-i)) + (start-x-server parent #f + (λ () + (start-x-server child parent inner)))) + (lambda () + (test-revision rev))))) ; Remove the test directory (safely-delete-directory test-dir)))) From 9c6b9b8fcdb660f2e8e2cd23a636c5d371255e0d Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 17 Nov 2010 09:21:50 -0700 Subject: [PATCH 082/255] Adding whitespace so you can copy and paste to planet remove on the OS X terminal --- collects/planet/private/cmdline-tool.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/planet/private/cmdline-tool.rkt b/collects/planet/private/cmdline-tool.rkt index c88a2269d0..1fc6ad35b7 100644 --- a/collects/planet/private/cmdline-tool.rkt +++ b/collects/planet/private/cmdline-tool.rkt @@ -212,7 +212,7 @@ This command does not unpack or install the named .plt file." (define (show-normals) (printf "Normally-installed packages:\n") (for-each - (lambda (l) (apply printf " ~a\t~a\t~a ~a\n" l)) + (lambda (l) (apply printf " ~a \t~a \t~a ~a\n" l)) (sort-by-criteria (map (lambda (x) (match x [(_ owner pkg _ maj min) (list owner pkg maj min)])) normal-packages) (list string Date: Tue, 23 Nov 2010 17:15:18 -0700 Subject: [PATCH 083/255] slideshow: use printer-dc on all platforms for --print --- collects/slideshow/cmdline.rkt | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/collects/slideshow/cmdline.rkt b/collects/slideshow/cmdline.rkt index da668dcf93..d6b935cada 100644 --- a/collects/slideshow/cmdline.rkt +++ b/collects/slideshow/cmdline.rkt @@ -161,8 +161,7 @@ "untitled.ps"))) (send pss set-orientation 'landscape) (parameterize ([current-ps-setup pss]) - (if (and native-printing? - (not (memq (system-type) '(unix)))) + (if native-printing? ;; Make printer-dc% (begin (when (can-get-page-setup-from-user?) From f245b6ca29e4bed9c19d1b46e2954d405f67f9c5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 24 Nov 2010 05:44:21 -0700 Subject: [PATCH 084/255] fix bitmap% `load-file' method and remove `{get,set}-gl-config' Closes PR 11460 --- collects/racket/draw/private/bitmap.rkt | 10 +++++----- collects/scribblings/draw/bitmap-class.scrbl | 20 ------------------- .../scribblings/draw/gl-config-class.scrbl | 4 ++-- doc/release-notes/racket/Draw_and_GUI_5_1.txt | 4 +++- 4 files changed, 10 insertions(+), 28 deletions(-) diff --git a/collects/racket/draw/private/bitmap.rkt b/collects/racket/draw/private/bitmap.rkt index 81120cc4c0..c567b45ac5 100644 --- a/collects/racket/draw/private/bitmap.rkt +++ b/collects/racket/draw/private/bitmap.rkt @@ -221,11 +221,11 @@ (define locked 0) (define/public (adjust-lock delta) (set! locked (+ locked delta))) - (def/public (load-bitmap [(make-alts path-string? input-port?) in] - [bitmap-file-kind-symbol? [kind 'unknown]] - [(make-or-false color%) [bg #f]] - [any? [complain-on-failure? #f]]) - (check-alternate 'load-bitmap) + (def/public (load-file [(make-alts path-string? input-port?) in] + [bitmap-file-kind-symbol? [kind 'unknown]] + [(make-or-false color%) [bg #f]] + [any? [complain-on-failure? #f]]) + (check-alternate 'load-file) (release-bitmap-storage) (set!-values (s b&w?) (do-load-bitmap in kind bg complain-on-failure?)) (set! width (if s (cairo_image_surface_get_width s) 0)) diff --git a/collects/scribblings/draw/bitmap-class.scrbl b/collects/scribblings/draw/bitmap-class.scrbl index 84b4d14d1b..261b1bd3eb 100644 --- a/collects/scribblings/draw/bitmap-class.scrbl +++ b/collects/scribblings/draw/bitmap-class.scrbl @@ -83,14 +83,6 @@ monochrome bitmap and @racket[32] for a color bitmap. See also } -@defmethod[(get-gl-config [config (is-a?/c gl-config%)]) - void?]{ - -Returns a copy of this bitmap's requested OpenGL configuration. See - also @method[bitmap% set-gl-config]. - -} - @defmethod[(get-height) exact-positive-integer?]{ @@ -282,18 +274,6 @@ bitmap does not have to be selected into the DC. } -@defmethod[(set-gl-config [config (is-a?/c gl-config%)]) - void?]{ - -Sets the requested OpenGL configuration for this bitmap. The - configuration is used when the bitmap selected into a drawing - context, and then a GL context is created for the drawing context. - -The given @scheme[gl-config%] object is copied, so that changes to - the object do not affect the bitmap's configuration. - -} - @defmethod[(set-loaded-mask [mask (is-a?/c bitmap%)]) void?]{ diff --git a/collects/scribblings/draw/gl-config-class.scrbl b/collects/scribblings/draw/gl-config-class.scrbl index f7dcb607d6..69fc48701f 100644 --- a/collects/scribblings/draw/gl-config-class.scrbl +++ b/collects/scribblings/draw/gl-config-class.scrbl @@ -5,8 +5,8 @@ A @scheme[gl-config%] object encapsulates configuration information for an OpenGL drawing context. Use a @scheme[gl-config%] object as an - initialization argument for @scheme[canvas%], or provide it to - @xmethod[bitmap% set-gl-config]. + initialization argument for @scheme[canvas%] or provide it to + @racket[make-gl-bitmap]. @defconstructor[()]{ diff --git a/doc/release-notes/racket/Draw_and_GUI_5_1.txt b/doc/release-notes/racket/Draw_and_GUI_5_1.txt index ddc76d856f..36c1d1ef75 100644 --- a/doc/release-notes/racket/Draw_and_GUI_5_1.txt +++ b/doc/release-notes/racket/Draw_and_GUI_5_1.txt @@ -42,7 +42,9 @@ alphas; for example, drawing a line in the middle of an empty bitmap produces an image with non-zero alpha only at the drawn line. Only bitmaps created with the new `make-gl-bitmap' function support -OpenGL drawing. +OpenGL drawing. The `make-gl-bitmap' function takes a `gl-config%' as +an argument, and the `get-gl-config' and `set-gl-config' methods of +`bitmap%' have been removed. Use the new `make-bitmap', `read-bitmap', `make-monochrome-bitmap', `make-screen-bitmap', and `make-gl-bitmap' functions to create From 0d6d285423b21170aa323cb7df8f41c54023b448 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 24 Nov 2010 07:08:54 -0700 Subject: [PATCH 085/255] clear objc ivar on `dealloc' so that a field is not incorrectly used if the super `dealloc' triggers callbacks --- collects/ffi/unsafe/objc.rkt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/ffi/unsafe/objc.rkt b/collects/ffi/unsafe/objc.rkt index a371abc34c..1166f80248 100644 --- a/collects/ffi/unsafe/objc.rkt +++ b/collects/ffi/unsafe/objc.rkt @@ -372,7 +372,9 @@ (define (free-fields obj names) (for-each (lambda (name) (let-values ([(ivar p) (object_getInstanceVariable obj name)]) - (when p (free-immobile-cell p)))) + (when p + (object_setInstanceVariable obj name #f) + (free-immobile-cell p)))) names)) ;; ---------------------------------------- From 14a72b5a083da74b42bf5a7d54ae16a05d34e325 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 24 Nov 2010 07:12:02 -0700 Subject: [PATCH 086/255] cocoa: fix problems with frame-list management --- collects/mred/private/wx/cocoa/frame.rkt | 17 ++++++++++++----- collects/mred/private/wx/cocoa/printer-dc.rkt | 16 +++++++++++++--- 2 files changed, 25 insertions(+), 8 deletions(-) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 3956ed8f68..b9570d2508 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -36,6 +36,9 @@ (define empty-mb (new menu-bar%)) (define root-fake-frame #f) +;; Maps window numbers to weak boxes of frame objects; +;; the weak-box layer is needed to avoid GC-accounting +;; problems. (define all-windows (make-hash)) (define-objc-mixin (MyWindowMethods Superclass) @@ -278,12 +281,12 @@ (register-frame-shown this on?) (let ([num (tell #:type _NSInteger cocoa windowNumber)]) (if on? - (hash-set! all-windows num this) + (hash-set! all-windows num (make-weak-box this)) (hash-remove! all-windows num))) (when on? (let ([b (eventspace-wait-cursor-count (get-eventspace))]) (set-wait-cursor-mode (not (zero? b)))))) - + (define/override (show on?) (let ([es (get-eventspace)]) (when on? @@ -534,9 +537,13 @@ (let ([f (tell #:type _NSRect (tell NSScreen mainScreen) frame)]) (make-NSPoint x (- (NSSize-height (NSRect-size f)) y))) belowWindowWithWindowNumber: #:type _NSInteger 0)]) - (atomically (hash-ref all-windows n #f)))) + (atomically (let ([b (hash-ref all-windows n #f)]) + (and b (weak-box-value b)))))) (set-fixup-window-locations! (lambda () - (for ([f (in-hash-values all-windows)]) - (send f fixup-locations-children)))) + ;; in atomic mode + (for ([b (in-hash-values all-windows)]) + (let ([f (weak-box-value b)]) + (send f fixup-locations-children))))) + diff --git a/collects/mred/private/wx/cocoa/printer-dc.rkt b/collects/mred/private/wx/cocoa/printer-dc.rkt index c1224ed17c..580ad92e1d 100644 --- a/collects/mred/private/wx/cocoa/printer-dc.rkt +++ b/collects/mred/private/wx/cocoa/printer-dc.rkt @@ -12,6 +12,7 @@ ffi/unsafe/objc "../../lock.rkt" "dc.rkt" + "frame.rkt" "bitmap.rkt" "cg.rkt" "utils.rkt" @@ -101,8 +102,13 @@ (send pss set-native pi make-print-info) pi)))]) (install-pss-to-print-info pss print-info) - (if (= (tell #:type _NSInteger (tell NSPageLayout pageLayout) runModalWithPrintInfo: print-info) - NSOkButton) + (if (atomically + (let ([front (get-front)]) + (begin0 + (= (tell #:type _NSInteger (tell NSPageLayout pageLayout) runModalWithPrintInfo: print-info) + NSOkButton) + (when front + (tellv (send front get-cocoa-window) makeKeyAndOrderFront: #f))))) (begin (let ([o (tell #:type _int print-info orientation)]) (send pss set-orientation (if (= o NSLandscapeOrientation) @@ -195,4 +201,8 @@ (set-ivar! view-cocoa wxb (->wxb this)) - (tellv op-cocoa runOperation)))) + (atomically + (let ([front (get-front)]) + (tellv op-cocoa runOperation) + (when front + (tellv (send front get-cocoa-window) makeKeyAndOrderFront: #f))))))) From e2072d5afba7cc3c8f1572bdbdac0d7020c92237 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 24 Nov 2010 10:38:20 -0700 Subject: [PATCH 087/255] cocoa: repair location fixup on screen change --- collects/mred/private/wx/cocoa/frame.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index b9570d2508..7e464a58a3 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -545,5 +545,6 @@ ;; in atomic mode (for ([b (in-hash-values all-windows)]) (let ([f (weak-box-value b)]) - (send f fixup-locations-children))))) + (when f + (send f fixup-locations-children)))))) From 2f4c782434710ecd3c2e2837d3394e5e6b7e86fb Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 24 Nov 2010 12:02:46 -0700 Subject: [PATCH 088/255] doc typos --- collects/scribblings/reference/class.scrbl | 24 +++++++++++----------- 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/collects/scribblings/reference/class.scrbl b/collects/scribblings/reference/class.scrbl index 8754cac866..caa16fad62 100644 --- a/collects/scribblings/reference/class.scrbl +++ b/collects/scribblings/reference/class.scrbl @@ -1986,11 +1986,11 @@ Returns two values, analogous to the return values of @scheme[struct-info]: @itemize[ - @item{@scheme[class]: a class or @scheme[#f]; the result is + @item{@scheme[_class]: a class or @scheme[#f]; the result is @scheme[#f] if the current inspector does not control any class for which the @scheme[object] is an instance.} - @item{@scheme[skipped?]: @scheme[#f] if the first result corresponds + @item{@scheme[_skipped?]: @scheme[#f] if the first result corresponds to the most specific class of @scheme[object], @scheme[#t] otherwise.} @@ -2011,31 +2011,31 @@ values of @scheme[struct-type-info]: @itemize[ - @item{@scheme[name]: the class's name as a symbol;} + @item{@scheme[_name]: the class's name as a symbol;} - @item{@scheme[field-cnt]: the number of fields (public and private) + @item{@scheme[_field-cnt]: the number of fields (public and private) defined by the class;} - @item{@scheme[field-name-list]: a list of symbols corresponding to the - class's public fields; this list can be larger than @scheme[field-k] + @item{@scheme[_field-name-list]: a list of symbols corresponding to the + class's public fields; this list can be larger than @scheme[_field-cnt] because it includes inherited fields;} - @item{@scheme[field-accessor]: an accessor procedure for obtaining + @item{@scheme[_field-accessor]: an accessor procedure for obtaining field values in instances of the class; the accessor takes an instance and a field index between @scheme[0] (inclusive) - and @scheme[field-cnt] (exclusive);} + and @scheme[_field-cnt] (exclusive);} - @item{@scheme[field-mutator]: a mutator procedure for modifying + @item{@scheme[_field-mutator]: a mutator procedure for modifying field values in instances of the class; the mutator takes an instance, a field index between @scheme[0] (inclusive) - and @scheme[field-cnt] (exclusive), and a new field value;} + and @scheme[_field-cnt] (exclusive), and a new field value;} - @item{@scheme[super-class]: a class for the most specific ancestor of + @item{@scheme[_super-class]: a class for the most specific ancestor of the given class that is controlled by the current inspector, or @scheme[#f] if no ancestor is controlled by the current inspector;} - @item{@scheme[skipped?]: @scheme[#f] if the sixth result is the most + @item{@scheme[_skipped?]: @scheme[#f] if the sixth result is the most specific ancestor class, @scheme[#t] otherwise.} ]} From 370c97165a2efc2b9061c27e31b1cdf0d0a97026 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 24 Nov 2010 12:03:17 -0700 Subject: [PATCH 089/255] cocoa: fix problem with frame focus --- collects/mred/private/wx/cocoa/frame.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 7e464a58a3..58ec55651b 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -271,6 +271,7 @@ (for/or ([i (in-range (tell #:type _NSUInteger wins count))]) (let ([win (tell wins objectAtIndex: #:type _NSUInteger i)]) (and (tell #:type _BOOL win isVisible) + (not (tell win parentWindow)) (or (not root-fake-frame) (not (ptr-equal? win (send root-fake-frame get-cocoa)))) win)))))))]) From bd28f2ab544d75214ff14ea4d24feb9045e466e0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 24 Nov 2010 13:41:11 -0700 Subject: [PATCH 090/255] make `equal?' equate C pointers that refer to the same address --- collects/scribblings/foreign/pointers.scrbl | 6 +- collects/scribblings/foreign/types.scrbl | 6 +- doc/release-notes/racket/HISTORY.txt | 1 + src/foreign/foreign.c | 2 +- src/foreign/foreign.rktc | 2 +- src/racket/include/scheme.h | 7 ++- src/racket/src/bool.c | 3 + src/racket/src/cstartup.inc | 68 ++++++++++----------- src/racket/src/hash.c | 10 +++ src/racket/src/mzmarksrc.c | 15 ++--- src/racket/src/salloc.c | 7 ++- src/racket/src/stypes.h | 3 +- src/racket/src/type.c | 2 - 13 files changed, 74 insertions(+), 58 deletions(-) diff --git a/collects/scribblings/foreign/pointers.scrbl b/collects/scribblings/foreign/pointers.scrbl index db13f38617..f88d572d22 100644 --- a/collects/scribblings/foreign/pointers.scrbl +++ b/collects/scribblings/foreign/pointers.scrbl @@ -14,7 +14,11 @@ Returns @scheme[#f] for other values.} @defproc[(ptr-equal? [cptr1 cpointer?] [cptr2 cpointer?]) boolean?]{ Compares the values of the two pointers. Two different Racket -pointer objects can contain the same pointer.} +pointer objects can contain the same pointer. + +If the values are both C pointers---as opposed to @racket[#f], a byte +string, @scheme[ffi-obj], or callback---this comparison is the same as +@racket[equal?].} @defproc[(ptr-add [cptr cpointer?] [offset exact-integer?] [type ctype? _byte]) diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index 22afd30bae..fe92c418f4 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -284,7 +284,11 @@ The address referenced by a @scheme[_pointer] value must not refer to memory managed by the garbage collector (unless the address corresponds to a value that supports interior pointers and that is otherwise referenced to preserve the value from garbage collection). -The reference is not traced or updated by the garbage collector.} +The reference is not traced or updated by the garbage collector. + +The @racket[equal?] predicate equates C pointers (including pointers +for @racket[_gcpointer] and possibly containing an offset) when they +refer to the same address.} @defthing[_gcpointer ctype?]{ diff --git a/doc/release-notes/racket/HISTORY.txt b/doc/release-notes/racket/HISTORY.txt index 5cfa781544..601642c636 100644 --- a/doc/release-notes/racket/HISTORY.txt +++ b/doc/release-notes/racket/HISTORY.txt @@ -1,5 +1,6 @@ 5.0.99.2 proxy => impersonator +equal? equates C pointers when they refer to the same address 5.0.99.1 Internal: weak boxes are cleared before non-will-like diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index ce7ba45ff1..52c45023f2 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -1212,7 +1212,7 @@ END_XFORM_SKIP; W_OFFSET(SCHEME_FFIANYPTR_VAL(x), SCHEME_FFIANYPTR_OFFSET(x)) #define SCHEME_CPOINTER_W_OFFSET_P(x) \ - SAME_TYPE(SCHEME_TYPE(x), scheme_offset_cpointer_type) + (SCHEME_CPTRP(x) && SCHEME_CPTR_HAS_OFFSET(x)) #define scheme_make_foreign_cpointer(x) \ ((x==NULL)?scheme_false:scheme_make_cptr(x,NULL)) diff --git a/src/foreign/foreign.rktc b/src/foreign/foreign.rktc index 7751438019..31cfbaa9bd 100755 --- a/src/foreign/foreign.rktc +++ b/src/foreign/foreign.rktc @@ -1008,7 +1008,7 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym) W_OFFSET(SCHEME_FFIANYPTR_VAL(x), SCHEME_FFIANYPTR_OFFSET(x)) #define SCHEME_CPOINTER_W_OFFSET_P(x) \ - SAME_TYPE(SCHEME_TYPE(x), scheme_offset_cpointer_type) + (SCHEME_CPTRP(x) && SCHEME_CPTR_HAS_OFFSET(x)) #define scheme_make_foreign_cpointer(x) \ ((x==NULL)?scheme_false:scheme_make_cptr(x,NULL)) diff --git a/src/racket/include/scheme.h b/src/racket/include/scheme.h index 45986e784f..949f9f2dcc 100644 --- a/src/racket/include/scheme.h +++ b/src/racket/include/scheme.h @@ -461,7 +461,7 @@ typedef long (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj, void *cycle_data) #define SCHEME_UDPP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_udp_type) #define SCHEME_UDP_EVTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_udp_evt_type) -#define SCHEME_CPTRP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_cpointer_type) || SAME_TYPE(SCHEME_TYPE(obj), scheme_offset_cpointer_type)) +#define SCHEME_CPTRP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_cpointer_type)) #define SCHEME_MUTABLEP(obj) (!(MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) & 0x1)) #define SCHEME_IMMUTABLEP(obj) (MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) & 0x1) @@ -562,7 +562,7 @@ typedef long (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj, void *cycle_data) typedef struct Scheme_Cptr { - Scheme_Inclhash_Object so; /* 0x1 => an external pointer (not GCable) */ + Scheme_Inclhash_Object so; /* 0x1 => an external pointer (not GCable); 0x2 => has offset */ void *val; Scheme_Object *type; } Scheme_Cptr; @@ -574,8 +574,9 @@ typedef struct Scheme_Offset_Cptr #define SCHEME_CPTR_VAL(obj) (((Scheme_Cptr *)(obj))->val) #define SCHEME_CPTR_TYPE(obj) (((Scheme_Cptr *)(obj))->type) -#define SCHEME_CPTR_OFFSET(obj) (SAME_TYPE(_SCHEME_TYPE(obj), scheme_offset_cpointer_type) ? ((Scheme_Offset_Cptr *)obj)->offset : 0) +#define SCHEME_CPTR_OFFSET(obj) (SCHEME_CPTR_HAS_OFFSET(obj) ? ((Scheme_Offset_Cptr *)obj)->offset : 0) #define SCHEME_CPTR_FLAGS(obj) MZ_OPT_HASH_KEY(&((Scheme_Cptr *)(obj))->so) +#define SCHEME_CPTR_HAS_OFFSET(obj) (SCHEME_CPTR_FLAGS(obj) & 0x2) #define SCHEME_SET_IMMUTABLE(obj) ((MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) |= 0x1)) #define SCHEME_SET_CHAR_STRING_IMMUTABLE(obj) SCHEME_SET_IMMUTABLE(obj) diff --git a/src/racket/src/bool.c b/src/racket/src/bool.c index bedfde85cb..8880d245d6 100644 --- a/src/racket/src/bool.c +++ b/src/racket/src/bool.c @@ -588,6 +588,9 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql) if (union_check(obj1, obj2, eql)) return 1; return scheme_bucket_table_equal_rec((Scheme_Bucket_Table *)obj1, (Scheme_Bucket_Table *)obj2, eql); + } else if (SCHEME_CPTRP(obj1)) { + return (((char *)SCHEME_CPTR_VAL(obj1) + SCHEME_CPTR_OFFSET(obj1)) + == ((char *)SCHEME_CPTR_VAL(obj2) + SCHEME_CPTR_OFFSET(obj2))); } else if (SAME_TYPE(SCHEME_TYPE(obj1), scheme_wrap_chunk_type)) { return vector_equal(obj1, obj2, eql); } else if (SAME_TYPE(SCHEME_TYPE(obj1), scheme_resolved_module_path_type)) { diff --git a/src/racket/src/cstartup.inc b/src/racket/src/cstartup.inc index 4ce4994632..92462f8615 100644 --- a/src/racket/src/cstartup.inc +++ b/src/racket/src/cstartup.inc @@ -1,44 +1,44 @@ { SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,53,46,48,46,57,57,46,50,51,0,0,0,1,0,0,10,0,13, -0,22,0,35,0,40,0,44,0,49,0,54,0,58,0,65,0,68,0,75,0, +0,22,0,35,0,39,0,43,0,46,0,53,0,58,0,63,0,70,0,75,0, 82,0,88,0,102,0,116,0,119,0,125,0,129,0,131,0,142,0,144,0,158, 0,165,0,187,0,189,0,203,0,14,1,43,1,54,1,65,1,75,1,111,1, 144,1,177,1,236,1,46,2,124,2,190,2,195,2,215,2,106,3,126,3,177, 3,243,3,128,4,14,5,66,5,89,5,168,5,0,0,109,7,0,0,69,35, 37,109,105,110,45,115,116,120,29,11,11,68,104,101,114,101,45,115,116,120,72, -112,97,114,97,109,101,116,101,114,105,122,101,64,108,101,116,42,63,108,101,116, -64,119,104,101,110,64,99,111,110,100,63,97,110,100,66,108,101,116,114,101,99, -62,111,114,66,100,101,102,105,110,101,66,117,110,108,101,115,115,65,113,117,111, +112,97,114,97,109,101,116,101,114,105,122,101,63,108,101,116,63,97,110,100,62, +111,114,66,100,101,102,105,110,101,64,119,104,101,110,64,99,111,110,100,66,108, +101,116,114,101,99,64,108,101,116,42,66,117,110,108,101,115,115,65,113,117,111, 116,101,29,94,2,14,68,35,37,107,101,114,110,101,108,11,29,94,2,14,68, 35,37,112,97,114,97,109,122,11,62,105,102,65,98,101,103,105,110,63,115,116, 120,61,115,70,108,101,116,45,118,97,108,117,101,115,61,120,73,108,101,116,114, 101,99,45,118,97,108,117,101,115,66,108,97,109,98,100,97,1,20,112,97,114, 97,109,101,116,101,114,105,122,97,116,105,111,110,45,107,101,121,61,118,73,100, -101,102,105,110,101,45,118,97,108,117,101,115,97,36,11,8,240,88,83,0,0, -95,159,2,16,36,36,159,2,15,36,36,159,2,15,36,36,16,20,2,11,2, -2,2,5,2,2,2,6,2,2,2,7,2,2,2,4,2,2,2,8,2,2, +101,102,105,110,101,45,118,97,108,117,101,115,97,36,11,8,240,252,81,0,0, +95,159,2,16,36,36,159,2,15,36,36,159,2,15,36,36,16,20,2,4,2, +2,2,11,2,2,2,5,2,2,2,6,2,2,2,7,2,2,2,8,2,2, 2,9,2,2,2,10,2,2,2,12,2,2,2,13,2,2,97,37,11,8,240, -88,83,0,0,93,159,2,15,36,37,16,2,2,3,161,2,2,37,2,3,2, -2,2,3,96,38,11,8,240,88,83,0,0,16,0,96,11,11,8,240,88,83, +252,81,0,0,93,159,2,15,36,37,16,2,2,3,161,2,2,37,2,3,2, +2,2,3,96,38,11,8,240,252,81,0,0,16,0,96,11,11,8,240,252,81, 0,0,16,0,13,16,4,36,29,11,11,2,2,11,18,16,2,99,64,104,101, -114,101,8,32,8,31,8,30,8,29,8,28,93,8,224,95,83,0,0,95,9, -8,224,95,83,0,0,2,2,27,248,22,151,4,195,249,22,144,4,80,158,39, +114,101,8,32,8,31,8,30,8,29,8,28,93,8,224,3,82,0,0,95,9, +8,224,3,82,0,0,2,2,27,248,22,151,4,195,249,22,144,4,80,158,39, 36,251,22,82,2,17,248,22,97,199,12,249,22,72,2,18,248,22,99,201,27, 248,22,151,4,195,249,22,144,4,80,158,39,36,251,22,82,2,17,248,22,97, 199,249,22,72,2,18,248,22,99,201,12,27,248,22,74,248,22,151,4,196,28, 248,22,80,193,20,15,159,37,36,37,28,248,22,80,248,22,74,194,248,22,73, 193,249,22,144,4,80,158,39,36,251,22,82,2,17,248,22,73,199,249,22,72, -2,9,248,22,74,201,11,18,16,2,101,10,8,32,8,31,8,30,8,29,8, -28,16,4,11,11,2,19,3,1,8,101,110,118,49,51,51,48,49,16,4,11, -11,2,20,3,1,8,101,110,118,49,51,51,48,50,93,8,224,96,83,0,0, -95,9,8,224,96,83,0,0,2,2,27,248,22,74,248,22,151,4,196,28,248, +2,6,248,22,74,201,11,18,16,2,101,10,8,32,8,31,8,30,8,29,8, +28,16,4,11,11,2,19,3,1,8,101,110,118,49,50,57,51,52,16,4,11, +11,2,20,3,1,8,101,110,118,49,50,57,51,53,93,8,224,4,82,0,0, +95,9,8,224,4,82,0,0,2,2,27,248,22,74,248,22,151,4,196,28,248, 22,80,193,20,15,159,37,36,37,28,248,22,80,248,22,74,194,248,22,73,193, 249,22,144,4,80,158,39,36,250,22,82,2,21,248,22,82,249,22,82,248,22, -82,2,22,248,22,73,201,251,22,82,2,17,2,22,2,22,249,22,72,2,11, +82,2,22,248,22,73,201,251,22,82,2,17,2,22,2,22,249,22,72,2,7, 248,22,74,204,18,16,2,101,11,8,32,8,31,8,30,8,29,8,28,16,4, -11,11,2,19,3,1,8,101,110,118,49,51,51,48,52,16,4,11,11,2,20, -3,1,8,101,110,118,49,51,51,48,53,93,8,224,97,83,0,0,95,9,8, -224,97,83,0,0,2,2,248,22,151,4,193,27,248,22,151,4,194,249,22,72, +11,11,2,19,3,1,8,101,110,118,49,50,57,51,55,16,4,11,11,2,20, +3,1,8,101,110,118,49,50,57,51,56,93,8,224,5,82,0,0,95,9,8, +224,5,82,0,0,2,2,248,22,151,4,193,27,248,22,151,4,194,249,22,72, 248,22,82,248,22,73,196,248,22,74,195,27,248,22,74,248,22,151,4,23,197, 1,249,22,144,4,80,158,39,36,28,248,22,57,248,22,145,4,248,22,73,23, 198,2,27,249,22,2,32,0,89,162,8,44,37,43,9,222,33,40,248,22,151, @@ -52,7 +52,7 @@ 44,37,47,9,222,33,43,248,22,151,4,248,22,73,201,248,22,74,198,27,248, 22,74,248,22,151,4,196,27,248,22,151,4,248,22,73,195,249,22,144,4,80, 158,40,36,28,248,22,80,195,250,22,83,2,21,9,248,22,74,199,250,22,82, -2,6,248,22,82,248,22,73,199,250,22,83,2,5,248,22,74,201,248,22,74, +2,5,248,22,82,248,22,73,199,250,22,83,2,12,248,22,74,201,248,22,74, 202,27,248,22,74,248,22,151,4,23,197,1,27,249,22,1,22,86,249,22,2, 22,151,4,248,22,151,4,248,22,73,199,249,22,144,4,80,158,40,36,251,22, 82,1,22,119,105,116,104,45,99,111,110,116,105,110,117,97,116,105,111,110,45, @@ -63,13 +63,13 @@ 22,151,4,196,28,248,22,80,193,20,15,159,37,36,37,249,22,144,4,80,158, 39,36,27,248,22,151,4,248,22,73,197,28,249,22,128,9,62,61,62,248,22, 145,4,248,22,97,196,250,22,82,2,21,248,22,82,249,22,82,21,93,2,26, -248,22,73,199,250,22,83,2,8,249,22,82,2,26,249,22,82,248,22,106,203, +248,22,73,199,250,22,83,2,10,249,22,82,2,26,249,22,82,248,22,106,203, 2,26,248,22,74,202,251,22,82,2,17,28,249,22,128,9,248,22,145,4,248, 22,73,200,64,101,108,115,101,10,248,22,73,197,250,22,83,2,21,9,248,22, -74,200,249,22,72,2,8,248,22,74,202,100,8,32,8,31,8,30,8,29,8, -28,16,4,11,11,2,19,3,1,8,101,110,118,49,51,51,50,55,16,4,11, -11,2,20,3,1,8,101,110,118,49,51,51,50,56,93,8,224,98,83,0,0, -18,16,2,158,94,10,64,118,111,105,100,8,48,95,9,8,224,98,83,0,0, +74,200,249,22,72,2,10,248,22,74,202,100,8,32,8,31,8,30,8,29,8, +28,16,4,11,11,2,19,3,1,8,101,110,118,49,50,57,54,48,16,4,11, +11,2,20,3,1,8,101,110,118,49,50,57,54,49,93,8,224,6,82,0,0, +18,16,2,158,94,10,64,118,111,105,100,8,48,95,9,8,224,6,82,0,0, 2,2,27,248,22,74,248,22,151,4,196,249,22,144,4,80,158,39,36,28,248, 22,57,248,22,145,4,248,22,73,197,250,22,82,2,27,248,22,82,248,22,73, 199,248,22,97,198,27,248,22,145,4,248,22,73,197,250,22,82,2,27,248,22, @@ -83,17 +83,17 @@ 11,11,11,16,0,16,0,16,0,36,36,16,11,16,5,2,3,20,15,159,36, 36,36,36,20,105,159,36,16,0,16,1,33,33,10,16,5,2,13,89,162,8, 44,37,53,9,223,0,33,34,36,20,105,159,36,16,1,2,3,16,0,11,16, -5,2,7,89,162,8,44,37,53,9,223,0,33,35,36,20,105,159,36,16,1, -2,3,16,0,11,16,5,2,9,89,162,8,44,37,53,9,223,0,33,36,36, -20,105,159,36,16,1,2,3,16,1,33,37,11,16,5,2,11,89,162,8,44, +5,2,9,89,162,8,44,37,53,9,223,0,33,35,36,20,105,159,36,16,1, +2,3,16,0,11,16,5,2,6,89,162,8,44,37,53,9,223,0,33,36,36, +20,105,159,36,16,1,2,3,16,1,33,37,11,16,5,2,7,89,162,8,44, 37,56,9,223,0,33,38,36,20,105,159,36,16,1,2,3,16,1,33,39,11, -16,5,2,6,89,162,8,44,37,58,9,223,0,33,42,36,20,105,159,36,16, -1,2,3,16,0,11,16,5,2,10,89,162,8,44,37,53,9,223,0,33,44, -36,20,105,159,36,16,1,2,3,16,0,11,16,5,2,5,89,162,8,44,37, +16,5,2,5,89,162,8,44,37,58,9,223,0,33,42,36,20,105,159,36,16, +1,2,3,16,0,11,16,5,2,11,89,162,8,44,37,53,9,223,0,33,44, +36,20,105,159,36,16,1,2,3,16,0,11,16,5,2,12,89,162,8,44,37, 54,9,223,0,33,45,36,20,105,159,36,16,1,2,3,16,0,11,16,5,2, 4,89,162,8,44,37,55,9,223,0,33,46,36,20,105,159,36,16,1,2,3, -16,0,11,16,5,2,8,89,162,8,44,37,58,9,223,0,33,47,36,20,105, -159,36,16,1,2,3,16,1,33,49,11,16,5,2,12,89,162,8,44,37,54, +16,0,11,16,5,2,10,89,162,8,44,37,58,9,223,0,33,47,36,20,105, +159,36,16,1,2,3,16,1,33,49,11,16,5,2,8,89,162,8,44,37,54, 9,223,0,33,50,36,20,105,159,36,16,1,2,3,16,0,11,16,0,94,2, 15,2,16,93,2,15,9,9,36,0}; EVAL_ONE_SIZED_STR((char *)expr, 2025); @@ -520,7 +520,7 @@ 117,116,105,108,115,11,29,94,2,2,69,35,37,110,101,116,119,111,114,107,11, 29,94,2,2,68,35,37,112,97,114,97,109,122,11,29,94,2,2,68,35,37, 101,120,112,111,98,115,11,29,94,2,2,68,35,37,107,101,114,110,101,108,11, -97,36,11,8,240,237,83,0,0,98,159,2,3,36,36,159,2,4,36,36,159, +97,36,11,8,240,145,82,0,0,98,159,2,3,36,36,159,2,4,36,36,159, 2,5,36,36,159,2,6,36,36,159,2,7,36,36,159,2,7,36,36,16,0, 159,36,20,105,159,36,16,1,11,16,0,83,158,42,20,103,145,2,1,2,1, 29,11,11,11,11,11,18,96,11,44,44,44,36,80,158,36,36,20,105,159,36, diff --git a/src/racket/src/hash.c b/src/racket/src/hash.c index 41b01d9f47..b62edbfdfc 100644 --- a/src/racket/src/hash.c +++ b/src/racket/src/hash.c @@ -1076,6 +1076,12 @@ static long equal_hash_key(Scheme_Object *o, long k, Hash_Info *hi) o = SCHEME_CDR(o); break; } + case scheme_cpointer_type: + { + k = (k << 3) + k; + k += (long)((char *)SCHEME_CPTR_VAL(o) + SCHEME_CPTR_OFFSET(o)); + break; + } case scheme_vector_type: case scheme_fxvector_type: case scheme_wrap_chunk_type: @@ -1490,6 +1496,10 @@ static long equal_hash_key2(Scheme_Object *o, Hash_Info *hi) v2 = equal_hash_key2(SCHEME_CDR(o), hi); return v1 + v2; } + case scheme_cpointer_type: + { + return (long)((char *)SCHEME_CPTR_VAL(o) + SCHEME_CPTR_OFFSET(o)); + } case scheme_vector_type: case scheme_fxvector_type: case scheme_wrap_chunk_type: diff --git a/src/racket/src/mzmarksrc.c b/src/racket/src/mzmarksrc.c index 561c9e2440..30135283cb 100644 --- a/src/racket/src/mzmarksrc.c +++ b/src/racket/src/mzmarksrc.c @@ -61,17 +61,10 @@ cpointer_obj { } gcMARK2(SCHEME_CPTR_TYPE(p), gc); size: - gcBYTES_TO_WORDS(sizeof(Scheme_Cptr)); -} - -offset_cpointer_obj { - mark: - if (!(SCHEME_CPTR_FLAGS(p) & 0x1)) { - gcMARK2(SCHEME_CPTR_VAL(p), gc); - } - gcMARK2(SCHEME_CPTR_TYPE(p), gc); - size: - gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr)); + if (SCHEME_CPTR_HAS_OFFSET(p)) + return gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr)); + else + return gcBYTES_TO_WORDS(sizeof(Scheme_Cptr)); } twoptr_obj { diff --git a/src/racket/src/salloc.c b/src/racket/src/salloc.c index c510c8cf36..2194289eec 100644 --- a/src/racket/src/salloc.c +++ b/src/racket/src/salloc.c @@ -527,7 +527,7 @@ Scheme_Object *scheme_make_external_cptr(GC_CAN_IGNORE void *cptr, Scheme_Object { Scheme_Object *o; o = scheme_make_cptr(NULL, typetag); - SCHEME_CPTR_FLAGS(o) |= 1; + SCHEME_CPTR_FLAGS(o) |= 0x1; SCHEME_CPTR_VAL(o) = cptr; return o; } @@ -537,7 +537,8 @@ Scheme_Object *scheme_make_offset_cptr(void *cptr, long offset, Scheme_Object *t Scheme_Object *o; o = (Scheme_Object *)scheme_malloc_small_tagged(sizeof(Scheme_Offset_Cptr)); - o->type = scheme_offset_cpointer_type; + o->type = scheme_cpointer_type; + SCHEME_CPTR_FLAGS(o) |= 0x2; SCHEME_CPTR_VAL(o) = cptr; SCHEME_CPTR_TYPE(o) = (void *)typetag; ((Scheme_Offset_Cptr *)o)->offset = offset; @@ -549,7 +550,7 @@ Scheme_Object *scheme_make_offset_external_cptr(GC_CAN_IGNORE void *cptr, long o { Scheme_Object *o; o = scheme_make_offset_cptr(NULL, offset, typetag); - SCHEME_CPTR_FLAGS(o) |= 1; + SCHEME_CPTR_FLAGS(o) |= 0x1; SCHEME_CPTR_VAL(o) = cptr; return o; } diff --git a/src/racket/src/stypes.h b/src/racket/src/stypes.h index 950061b7e4..889bb6ae16 100644 --- a/src/racket/src/stypes.h +++ b/src/racket/src/stypes.h @@ -88,7 +88,7 @@ enum { scheme_hash_table_type, /* 69 */ scheme_hash_tree_type, /* 70 */ scheme_cpointer_type, /* 71 */ - scheme_offset_cpointer_type, /* 72 */ + scheme_currently_unused_type, /* 72 */ scheme_weak_box_type, /* 73 */ scheme_ephemeron_type, /* 74 */ scheme_struct_type_type, /* 75 */ @@ -183,6 +183,7 @@ enum { scheme_once_used_type, /* 164 */ scheme_serialized_symbol_type, /* 165 */ scheme_serialized_structure_type, /* 166 */ + /* use scheme_currently_unused_type above, first */ #ifdef MZTAG_REQUIRED _scheme_last_normal_type_, /* 167 */ diff --git a/src/racket/src/type.c b/src/racket/src/type.c index e46296ab4e..cfac6d9a82 100644 --- a/src/racket/src/type.c +++ b/src/racket/src/type.c @@ -220,7 +220,6 @@ scheme_init_type () set_name(scheme_subprocess_type, ""); set_name(scheme_cpointer_type, ""); - set_name(scheme_offset_cpointer_type, ""); set_name(scheme_wrap_chunk_type, ""); @@ -555,7 +554,6 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_flvector_type, flvector_obj); GC_REG_TRAV(scheme_fxvector_type, fxvector_obj); GC_REG_TRAV(scheme_cpointer_type, cpointer_obj); - GC_REG_TRAV(scheme_offset_cpointer_type, offset_cpointer_obj); GC_REG_TRAV(scheme_bucket_type, bucket_obj); From 470ed7c996dca2f0801f43efc768f1082c7bea92 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 24 Nov 2010 14:25:07 -0700 Subject: [PATCH 091/255] fix get-face-list bug (caused Windows 7 crash on my test) --- collects/racket/draw/unsafe/pango.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/racket/draw/unsafe/pango.rkt b/collects/racket/draw/unsafe/pango.rkt index 7475f5fcc1..f5e282ca6d 100644 --- a/collects/racket/draw/unsafe/pango.rkt +++ b/collects/racket/draw/unsafe/pango.rkt @@ -230,7 +230,7 @@ -> (begin0 (for/list ([i (in-range len)]) (ptr-ref fams PangoFontFamily i)) - (free fams)))) + (g_free fams)))) (define-pango pango_font_description_free (_fun PangoFontDescription -> _void) #:wrap (deallocator)) From 1034c9be4ee918000b6cce922b7ba5782bbcf010 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 24 Nov 2010 15:44:18 -0700 Subject: [PATCH 092/255] fix hashing on C pointers and missing tests --- collects/tests/racket/foreign-test.rktl | 15 +++++++++++++++ src/racket/src/hash.c | 2 +- 2 files changed, 16 insertions(+), 1 deletion(-) diff --git a/collects/tests/racket/foreign-test.rktl b/collects/tests/racket/foreign-test.rktl index a8ef509b5c..182edfdea5 100644 --- a/collects/tests/racket/foreign-test.rktl +++ b/collects/tests/racket/foreign-test.rktl @@ -239,6 +239,21 @@ (ptr-set! v _pointer (ptr-add #f 107)) (test 107 ptr-ref v _intptr)) +;; Test equality and hashing of c pointers: +(let ([seventeen1 (cast 17 _long _pointer)] + [seventeen2 (cast 17 _long _pointer)] + [seventeen3 (ptr-add (cast 13 _long _pointer) 4)] + [sixteen (cast 16 _long _pointer)]) + (test #t equal? seventeen1 seventeen2) + (test #t equal? seventeen1 seventeen3) + (test #f equal? sixteen seventeen1) + (test #t = (equal-hash-code seventeen1) (equal-hash-code seventeen2)) + (test #t = (equal-hash-code seventeen1) (equal-hash-code seventeen3)) + (let ([ht (make-hash)]) + (hash-set! ht seventeen1 'hello) + (test 'hello hash-ref ht seventeen2 #f) + (test 'hello hash-ref ht seventeen3 #f))) + (delete-test-files) (report-errs) diff --git a/src/racket/src/hash.c b/src/racket/src/hash.c index b62edbfdfc..b9ac3e4766 100644 --- a/src/racket/src/hash.c +++ b/src/racket/src/hash.c @@ -1080,7 +1080,7 @@ static long equal_hash_key(Scheme_Object *o, long k, Hash_Info *hi) { k = (k << 3) + k; k += (long)((char *)SCHEME_CPTR_VAL(o) + SCHEME_CPTR_OFFSET(o)); - break; + return k; } case scheme_vector_type: case scheme_fxvector_type: From b686cc84a9e9606658e0e5f0773d402f2bce8854 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 24 Nov 2010 22:33:37 -0500 Subject: [PATCH 093/255] Removing test because we reintroduced gensym --- collects/tests/compiler/zo-exs.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index 3bd665ca04..2abdaab4ff 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -31,7 +31,7 @@ (prefix 0 empty empty) (list 1 (list 2 3) (list 2 3) 4 5))) - (roundtrip + #;(roundtrip (compilation-top 0 (prefix 0 empty empty) (let* ([ph (make-placeholder #f)] From 11f2653b7e20e25d19157f3bdeba73632584f77b Mon Sep 17 00:00:00 2001 From: tv Date: Mon, 15 Nov 2010 16:55:21 +0100 Subject: [PATCH 094/255] add #:tcp@ to ws-serve for wss: support --- collects/net/scribblings/websocket.scrbl | 3 +++ collects/net/websocket/server.rkt | 16 +++++++++++++++- 2 files changed, 18 insertions(+), 1 deletion(-) diff --git a/collects/net/scribblings/websocket.scrbl b/collects/net/scribblings/websocket.scrbl index c887c99dc1..5833c5d117 100644 --- a/collects/net/scribblings/websocket.scrbl +++ b/collects/net/scribblings/websocket.scrbl @@ -6,6 +6,7 @@ web-server/http racket/list racket/async-channel + (prefix-in raw: (for-label net/tcp-unit)) net/websocket net/websocket/client net/websocket/server @@ -46,6 +47,7 @@ This module also provides the exports from @racketmodname[net/websocket/conn]. conn-headers (bytes? (listof header?) . -> . (values (listof header?) any/c)) (λ (b hs) (values empty (void)))] + [#:tcp@ tcp@ (unit/c (import) (export tcp^)) raw:tcp@] [#:port port tcp-listen-port? 80] [#:listen-ip listen-ip (or/c string? false/c) #f] [#:max-waiting max-waiting integer? 4] @@ -64,6 +66,7 @@ This module also provides the exports from @racketmodname[net/websocket/conn]. All other arguments are used as in a @secref["dispatch-server-unit" #:doc '(lib "web-server/scribblings/web-server-internal.scrbl")]. + The @racket[#:tcp@] keyword is provided for building an SSL server. } This module also provides the exports from @racketmodname[net/websocket/conn]. diff --git a/collects/net/websocket/server.rkt b/collects/net/websocket/server.rkt index d0f4af751c..f74d78a8c6 100644 --- a/collects/net/websocket/server.rkt +++ b/collects/net/websocket/server.rkt @@ -7,6 +7,8 @@ web-server/http/request-structs racket/async-channel unstable/contract + net/tcp-sig + (prefix-in raw: net/tcp-unit) net/websocket/conn net/websocket/handshake) (provide (except-out (all-from-out net/websocket/conn) ws-conn)) @@ -16,6 +18,8 @@ (->* ((open-ws-conn? any/c . -> . void)) (#:conn-headers (bytes? (listof header?) . -> . (values (listof header?) any/c)) + #:tcp@ + (unit/c (import) (export tcp^)) #:port tcp-listen-port? #:listen-ip @@ -30,6 +34,7 @@ (define (ws-serve conn-dispatch #:conn-headers [pre-conn-dispatch (λ (cline hs) (values empty (void)))] + #:tcp@ [tcp@ raw:tcp@] #:port [port 80] #:listen-ip [listen-ip #f] #:max-waiting [max-waiting 4] @@ -71,5 +76,14 @@ (conn-dispatch conn state)) - (define-values/invoke-unit/infer dispatch-server@) + (define-unit-binding a-tcp@ + tcp@ (import) (export tcp^)) + (define-compound-unit/infer dispatch-server@/tcp@ + (import dispatch-server-config^) + (link a-tcp@ dispatch-server@) + (export dispatch-server^)) + (define-values/invoke-unit + dispatch-server@/tcp@ + (import dispatch-server-config^) + (export dispatch-server^)) (serve #:confirmation-channel confirm-ch)) \ No newline at end of file From 32377647f8197b5081fe1687d85b05d6f939322c Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 24 Nov 2010 22:50:46 -0500 Subject: [PATCH 095/255] Applying GMT RFC1123 patch from YC --- collects/web-server/http/response.rkt | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/collects/web-server/http/response.rkt b/collects/web-server/http/response.rkt index 44e16faf20..2a7868cf33 100644 --- a/collects/web-server/http/response.rkt +++ b/collects/web-server/http/response.rkt @@ -125,9 +125,7 @@ ; format is rfc1123 compliant according to rfc2068 (http/1.1) (define (seconds->gmt-string s) (let* ([local-date (seconds->date s)] - [date (seconds->date (- s - (date-time-zone-offset local-date) - (if (date-dst? local-date) 3600 0)))]) + [date (seconds->date (- s (date-time-zone-offset local-date)))]) (format "~a, ~a ~a ~a ~a:~a:~a GMT" (vector-ref DAYS (date-week-day date)) (two-digits (date-day date)) From c9dcbb9edb30245cf6c2858d24673e80f5b54a50 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 24 Nov 2010 23:26:29 -0500 Subject: [PATCH 096/255] Failing test --- collects/tests/plai/gc/good-mutators/let-star.rkt | 9 +++++++++ collects/tests/plai/test-random-mutator.rkt | 2 ++ 2 files changed, 11 insertions(+) create mode 100644 collects/tests/plai/gc/good-mutators/let-star.rkt diff --git a/collects/tests/plai/gc/good-mutators/let-star.rkt b/collects/tests/plai/gc/good-mutators/let-star.rkt new file mode 100644 index 0000000000..4b76d97492 --- /dev/null +++ b/collects/tests/plai/gc/good-mutators/let-star.rkt @@ -0,0 +1,9 @@ +#lang plai/mutator +(allocator-setup "../good-collectors/good-collector.rkt" 4) + +(define (go) + (let ([obj 'z]) + 2 3 + (symbol? obj))) + +(go) \ No newline at end of file diff --git a/collects/tests/plai/test-random-mutator.rkt b/collects/tests/plai/test-random-mutator.rkt index ec74cfad89..b4f964a1cb 100644 --- a/collects/tests/plai/test-random-mutator.rkt +++ b/collects/tests/plai/test-random-mutator.rkt @@ -15,6 +15,8 @@ ;; returns true if evaluating the example code (as a mutator) ;; returns one result at the top-level, namely the symbol 'passed. (define (test-code exps) + (printf "Test code\n") + (for-each pretty-print exps) (let ([tmpfile (make-temporary-file "plai-random-mutator-test-~a")]) (call-with-output-file tmpfile (λ (port) From eecbc539c11770abadc1d2912d6f6026a4e0430a Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 24 Nov 2010 23:32:59 -0500 Subject: [PATCH 097/255] Fixing problem with previous "fix" to mutator-begin --- collects/plai/mutator.rkt | 5 ++++- .../let-star.rkt => other-mutators/begin.rkt} | 2 +- collects/tests/plai/gc/run-test.rkt | 8 ++++++++ collects/tests/plai/test-random-mutator.rkt | 2 -- 4 files changed, 13 insertions(+), 4 deletions(-) rename collects/tests/plai/gc/{good-mutators/let-star.rkt => other-mutators/begin.rkt} (55%) diff --git a/collects/plai/mutator.rkt b/collects/plai/mutator.rkt index 4c2dfefd10..f67254ce26 100644 --- a/collects/plai/mutator.rkt +++ b/collects/plai/mutator.rkt @@ -110,7 +110,10 @@ [(_) (mutator-app void)] [(_ e) e] [(_ fe e ...) - (let ([tmp fe]) (mutator-begin e ...))])) + (let ([tmp + (syntax-parameterize ([mutator-tail-call? #f]) + fe)]) + (mutator-begin e ...))])) ; Real Macros (define-syntax-rule (mutator-define-values (id ...) e) diff --git a/collects/tests/plai/gc/good-mutators/let-star.rkt b/collects/tests/plai/gc/other-mutators/begin.rkt similarity index 55% rename from collects/tests/plai/gc/good-mutators/let-star.rkt rename to collects/tests/plai/gc/other-mutators/begin.rkt index 4b76d97492..71f729b3ae 100644 --- a/collects/tests/plai/gc/good-mutators/let-star.rkt +++ b/collects/tests/plai/gc/other-mutators/begin.rkt @@ -1,5 +1,5 @@ #lang plai/mutator -(allocator-setup "../good-collectors/good-collector.rkt" 4) +(allocator-setup "../good-collectors/good-collector.rkt" 6) (define (go) (let ([obj 'z]) diff --git a/collects/tests/plai/gc/run-test.rkt b/collects/tests/plai/gc/run-test.rkt index eb0d42ef0c..9cb6d41c46 100644 --- a/collects/tests/plai/gc/run-test.rkt +++ b/collects/tests/plai/gc/run-test.rkt @@ -51,6 +51,14 @@ (good (heap-loc head) 62 62 "at line 18") (bad (heap-loc head) 62 47 "at line 19") +END + + (capture-output (test-mutator (build-path here "other-mutators" "begin.rkt"))) + => + #< Date: Thu, 25 Nov 2010 06:33:53 -0600 Subject: [PATCH 098/255] added empty-image --- collects/2htdp/image.rkt | 4 +++- collects/2htdp/private/image-more.rkt | 5 +++++ collects/2htdp/tests/test-image.rkt | 9 +++++++++ collects/teachpack/2htdp/scribblings/image-toc.rkt | 7 +++++++ collects/teachpack/2htdp/scribblings/image.scrbl | 10 ++++++++++ 5 files changed, 34 insertions(+), 1 deletion(-) diff --git a/collects/2htdp/image.rkt b/collects/2htdp/image.rkt index 80502263d2..667b56ab60 100644 --- a/collects/2htdp/image.rkt +++ b/collects/2htdp/image.rkt @@ -105,6 +105,7 @@ and they all have good sample contracts. (It is amazing what we can do with kids scene+curve text text/font + image->color-list color-list->bitmap @@ -139,7 +140,8 @@ and they all have good sample contracts. (It is amazing what we can do with kids step-count? save-image) -(provide bitmap) +(provide bitmap + empty-image) (define-primitive make-color build-color/make-color) (define-primitive color build-color/color) diff --git a/collects/2htdp/private/image-more.rkt b/collects/2htdp/private/image-more.rkt index b1b511c864..78dcd1a964 100644 --- a/collects/2htdp/private/image-more.rkt +++ b/collects/2htdp/private/image-more.rkt @@ -1171,6 +1171,8 @@ [(zero? b) a] [else (gcd b (modulo a b))])) + + ;; swizzle : (listof X)[odd-length] -> (listof X) ;; returns a list with the same elements, ;; but reordered according to the step. Eg, if the step @@ -1212,6 +1214,8 @@ (make-bb w/h w/h w/h) #f))) +(define empty-image (rectangle 0 0 'solid 'black)) + (define/chk (image-width image) (bb-select/round/exact bb-right image)) (define/chk (image-height image) (bb-select/round/exact bb-bottom image)) (define/chk (image-baseline image) (bb-select/round/exact bb-baseline image)) @@ -1367,6 +1371,7 @@ empty-scene square rhombus + empty-image polygon regular-polygon diff --git a/collects/2htdp/tests/test-image.rkt b/collects/2htdp/tests/test-image.rkt index ae0f11ad0e..084e8b0c39 100644 --- a/collects/2htdp/tests/test-image.rkt +++ b/collects/2htdp/tests/test-image.rkt @@ -156,6 +156,15 @@ => 0) +(test (image-width empty-image) => 0) +(test (image-height empty-image) => 0) +(test (equal? (above empty-image + (rectangle 10 10 "solid" "red")) + (beside empty-image + (rectangle 10 10 "solid" "red"))) + => + #t) + (check-close (image-width (rotate 45 (rectangle 100 0 'solid 'blue))) (inexact->exact (ceiling (* (sin (* pi 1/4)) 100)))) (check-close (image-height (rotate 45 (rectangle 100 0 'solid 'blue))) diff --git a/collects/teachpack/2htdp/scribblings/image-toc.rkt b/collects/teachpack/2htdp/scribblings/image-toc.rkt index 0c4abae7fb..f769ce1de7 100644 --- a/collects/teachpack/2htdp/scribblings/image-toc.rkt +++ b/collects/teachpack/2htdp/scribblings/image-toc.rkt @@ -712,6 +712,13 @@ "2dde939d6dc.png") (list '(right-triangle 36 48 "solid" "black") 'image "1a0088e3819.png") (list '(triangle 40 "solid" "tan") 'image "aeddf66d5d.png") + (list + '(equal? + (above empty-image (rectangle 10 10 "solid" "red")) + (beside empty-image (rectangle 10 10 "solid" "red"))) + 'val + '#t) + (list '(image-width empty-image) 'val '0) (list '(text/font "not really a link" 18 "blue" #f 'roman 'normal 'normal #t) 'image diff --git a/collects/teachpack/2htdp/scribblings/image.scrbl b/collects/teachpack/2htdp/scribblings/image.scrbl index 10bc2b7427..dce22fbfa8 100644 --- a/collects/teachpack/2htdp/scribblings/image.scrbl +++ b/collects/teachpack/2htdp/scribblings/image.scrbl @@ -177,6 +177,16 @@ Unlike @racket[scene+curve], if the line passes outside of @racket[image], the i #f 'roman 'normal 'normal #t)] } +@defthing[empty-image image?]{ + The empty image. Its width and height are both zero and it does not draw at all. + + @image-examples[(image-width empty-image) + (equal? (above empty-image + (rectangle 10 10 "solid" "red")) + (beside empty-image + (rectangle 10 10 "solid" "red")))] +} + @section{Polygons} @defproc*[([(triangle [side-length (and/c real? (not/c negative?))] From 57fe568a5e89e866a20051243744be3eb48fee7e Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 25 Nov 2010 06:50:34 -0600 Subject: [PATCH 099/255] fixed a bug --- collects/2htdp/private/image-more.rkt | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/collects/2htdp/private/image-more.rkt b/collects/2htdp/private/image-more.rkt index 78dcd1a964..9d33136a6f 100644 --- a/collects/2htdp/private/image-more.rkt +++ b/collects/2htdp/private/image-more.rkt @@ -707,15 +707,15 @@ (let ([bitmap (flip-shape atomic-shape)] [flipped? (flip-flipped? atomic-shape)]) (make-flip flipped? - (make-bitmap (ibitmap-raw-bitmap bitmap) - (ibitmap-raw-mask bitmap) - (bring-between (if flipped? - (+ (ibitmap-angle bitmap) θ) - (- (ibitmap-angle bitmap) θ)) - 360) - (ibitmap-x-scale bitmap) - (ibitmap-y-scale bitmap) - (make-hash))))])) + (make-ibitmap (ibitmap-raw-bitmap bitmap) + (ibitmap-raw-mask bitmap) + (bring-between (if flipped? + (+ (ibitmap-angle bitmap) θ) + (- (ibitmap-angle bitmap) θ)) + 360) + (ibitmap-x-scale bitmap) + (ibitmap-y-scale bitmap) + (make-hash))))])) ;; rotate-point : point angle -> point (define (rotate-point p θ) From a658a7620b268edef2fe2af014b0e8a892619393 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 25 Nov 2010 06:52:46 -0600 Subject: [PATCH 100/255] a (failed) attempt to fix equality comparison (but at least it is a step in the right direction (I think)) --- collects/mrlib/image-core.rkt | 24 +++++++++--------------- 1 file changed, 9 insertions(+), 15 deletions(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 0190fbf94d..b9b0057fdb 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -214,26 +214,20 @@ has been moved out). (equal? (get-normalized-shape) (send that get-normalized-shape))) (let ([w (+ 1 (round (inexact->exact (bb-right bb))))] ;; some shapes (ie, rectangles) draw 1 outside the bounding box [h (+ 1 (round (inexact->exact (bb-bottom bb))))]) ;; so we make the bitmap slightly bigger to accomodate that. - (or (zero? w) - (zero? h) - (let ([bm1 (make-object bitmap% w h)] - [bm2 (make-object bitmap% w h)] + (or ;(zero? w) + ;(zero? h) + (let ([bm1 (make-bitmap w h #t)] + [bm2 (make-bitmap w h #t)] [bytes1 (make-bytes (* w h 4) 0)] [bytes2 (make-bytes (* w h 4) 0)] [bdc (make-object bitmap-dc%)]) - (and (check-same? bm1 bm2 bytes1 bytes2 bdc "red" that) - (check-same? bm1 bm2 bytes1 bytes2 bdc "green" that)))))))))) + (draw-into bm1 bdc bytes1 this) + (draw-into bm2 bdc bytes2 that) + (equal? bytes1 bytes2))))))))) - (define/private (check-same? bm1 bm2 bytes1 bytes2 bdc color that) - (clear-bitmap/draw/bytes bm1 bdc bytes1 this color) - (clear-bitmap/draw/bytes bm2 bdc bytes2 that color) - (equal? bytes1 bytes2)) - - (define/private (clear-bitmap/draw/bytes bm bdc bytes obj color) + (define/private (draw-into bm bdc bytes obj) (send bdc set-bitmap bm) - (send bdc set-pen "black" 1 'transparent) - (send bdc set-brush color 'solid) - (send bdc draw-rectangle 0 0 (send bm get-width) (send bm get-height)) + (send bdc clear) (render-image obj bdc 0 0) (send bdc get-argb-pixels 0 0 (send bm get-width) (send bm get-height) bytes)) From bf62d4b6d6e1968ddaf3adc835c4f70d7321228a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 25 Nov 2010 09:03:06 -0600 Subject: [PATCH 101/255] get two more 2htdp/image test cases to pass --- collects/mrlib/image-core.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index b9b0057fdb..e9d4684d3d 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -1014,7 +1014,7 @@ the mask bitmap and the original bitmap are all together in a single bytes! [(pen? color) (pen->pen-obj/cache color)] [else - (send the-pen-list find-or-create-pen (get-color-arg color) 0 'solid)])] + (send the-pen-list find-or-create-pen (get-color-arg color) 0 'solid 'round 'miter)])] [(solid) (send the-pen-list find-or-create-pen "black" 1 'transparent)])) From ab070b205ea20b76b76dea5e027d2a35e7de6c73 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 24 Nov 2010 16:57:44 -0700 Subject: [PATCH 102/255] cocoa: finally found the documented API to enable GUI mode --- collects/mred/private/wx/cocoa/finfo.rkt | 2 -- collects/mred/private/wx/cocoa/queue.rkt | 19 ++++++++++--------- collects/mred/private/wx/cocoa/types.rkt | 4 +++- 3 files changed, 13 insertions(+), 12 deletions(-) diff --git a/collects/mred/private/wx/cocoa/finfo.rkt b/collects/mred/private/wx/cocoa/finfo.rkt index dad503cb09..300386efd5 100644 --- a/collects/mred/private/wx/cocoa/finfo.rkt +++ b/collects/mred/private/wx/cocoa/finfo.rkt @@ -65,8 +65,6 @@ (define _FSRef _pointer) ; 80 bytes -(define _OSStatus _sint32) - (define-coreserv FSPathMakeRef (_fun _path _FSRef (_pointer = #f) -> _OSStatus)) (define-coreserv FSGetCatalogInfo diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 651d0eea41..d6ca67c558 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -68,15 +68,16 @@ ;; In case we were started in an executable without a bundle, ;; explicitly register with the dock so the application can receive ;; keyboard events. -;; This technique is not sanctioned by Apple --- I found the code in SDL. -(define-cstruct _CPSProcessSerNum ([lo _uint32] [hi _uint32])) -(define-appserv CPSGetCurrentProcess (_fun _CPSProcessSerNum-pointer -> _int) - #:fail (lambda () (lambda args 1))) -(define-appserv CPSEnableForegroundOperation (_fun _CPSProcessSerNum-pointer _int _int _int _int -> _int) - #:fail (lambda () #f)) -(let ([psn (make-CPSProcessSerNum 0 0)]) - (when (zero? (CPSGetCurrentProcess psn)) - (void (CPSEnableForegroundOperation psn #x03 #x3C #x2C #x1103)))) +(define-cstruct _ProcessSerialNumber + ([highLongOfPSN _ulong] + [lowLongOfPSN _ulong])) +(define kCurrentProcess 2) +(define kProcessTransformToForegroundApplication 1) +(define-appserv TransformProcessType (_fun _ProcessSerialNumber-pointer + _uint32 + -> _OSStatus)) +(void (TransformProcessType (make-ProcessSerialNumber 0 kCurrentProcess) + kProcessTransformToForegroundApplication)) (define app-delegate (tell (tell MyApplicationDelegate alloc) init)) (tellv app setDelegate: app-delegate) diff --git a/collects/mred/private/wx/cocoa/types.rkt b/collects/mred/private/wx/cocoa/types.rkt index 5e577c9550..665aeae12a 100644 --- a/collects/mred/private/wx/cocoa/types.rkt +++ b/collects/mred/private/wx/cocoa/types.rkt @@ -5,7 +5,7 @@ "utils.rkt") (provide - (protect-out _NSInteger _NSUInteger + (protect-out _NSInteger _NSUInteger _OSStatus _CGFloat _NSPoint _NSPoint-pointer (struct-out NSPoint) _NSSize _NSSize-pointer (struct-out NSSize) @@ -18,6 +18,8 @@ (define _NSInteger _long) (define _NSUInteger _ulong) +(define _OSStatus _sint32) + (define 64-bit? (= (ctype-sizeof _long) 8)) (define _CGFloat (make-ctype (if 64-bit? _double _float) From 820e832853058ee2063599ea9ab2bc8cfc23676f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 25 Nov 2010 06:57:58 -0700 Subject: [PATCH 103/255] add 'close-button style to dialog%; fix cocoa default frame placement --- collects/framework/splash.rkt | 2 +- collects/mred/private/mrtop.rkt | 2 +- collects/mred/private/wx/cocoa/frame.rkt | 10 ++++++---- collects/mred/private/wx/cocoa/procs.rkt | 11 ++++++++--- collects/mred/private/wx/cocoa/window.rkt | 4 +++- collects/mred/private/wxtop.rkt | 2 +- collects/scribblings/gui/dialog-class.scrbl | 7 ++++++- 7 files changed, 26 insertions(+), 12 deletions(-) diff --git a/collects/framework/splash.rkt b/collects/framework/splash.rkt index 9bb519ec57..3edea6e37b 100644 --- a/collects/framework/splash.rkt +++ b/collects/framework/splash.rkt @@ -286,7 +286,7 @@ (define/augment (on-close) (when quit-on-close? (exit))) - (super-new))) + (super-new [style '(close-button)]))) (define splash-canvas% (class canvas% diff --git a/collects/mred/private/mrtop.rkt b/collects/mred/private/mrtop.rkt index c107cfb154..a290834db2 100644 --- a/collects/mred/private/mrtop.rkt +++ b/collects/mred/private/mrtop.rkt @@ -237,7 +237,7 @@ (check-label-string cwho label) (check-top-level-parent/false cwho parent) (for-each (lambda (x) (check-dimension cwho x)) (list width height x y)) - (check-style cwho #f '(no-caption resize-border no-sheet) style))) + (check-style cwho #f '(no-caption resize-border no-sheet close-button) style))) (rename [super-on-subwindow-char on-subwindow-char]) (private-field [wx #f]) (override diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 58ec55651b..79e5c6a3a6 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -167,7 +167,9 @@ NSTitledWindowMask (if is-sheet? NSUtilityWindowMask 0) (if is-dialog? - 0 + (if (memq 'close-button style) + NSClosableWindowMask + 0) (bitwise-ior NSClosableWindowMask NSMiniaturizableWindowMask @@ -190,7 +192,7 @@ (tellv tb setVisible: #:type _BOOL #f) (tellv tb release)))) - (move -11111 (if (= y -11111) 0 y)) + (internal-move -11111 (if (= y -11111) 0 y)) (tellv cocoa setAcceptsMouseMovedEvents: #:type _BOOL #t) @@ -415,7 +417,7 @@ (define/override (set-size x y w h) (unless (and (= x -1) (= y -1)) - (move x y)) + (internal-move x y)) (let ([f (tell #:type _NSRect cocoa frame)]) (tellv cocoa setFrame: #:type _NSRect (make-NSRect @@ -436,7 +438,7 @@ (NSSize-height (NSRect-size f))))) (make-NSSize w h)) display: #:type _BOOL #t))) - (define/override (move x y) + (define/override (internal-move x y) (let ([x (if (= x -11111) (get-x) x)] [y (if (= y -11111) (get-y) y)]) (tellv cocoa setFrameTopLeftPoint: #:type _NSPoint (make-NSPoint x (- (flip-screen y) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index 77866d045d..a6caa39307 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -91,10 +91,15 @@ (define (check-for-break) #f) (define (display-origin xb yb all?) - (set-box! xb 0) (if all? - (set-box! yb 0) - (set-box! yb (get-menu-bar-height)))) + (atomically + (with-autorelease + (let* ([screen (tell (tell NSScreen screens) objectAtIndex: #:type _NSUInteger 0)] + [f (tell #:type _NSRect screen visibleFrame)]) + (set-box! xb (->long (NSPoint-x (NSRect-origin f))))))) + (set-box! xb 0)) + (set-box! yb (get-menu-bar-height))) + (define (display-size xb yb all?) (atomically (with-autorelease diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index a76e56fe3a..a23a7a7295 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -520,8 +520,10 @@ (tellv cocoa setNeedsDisplay: #:type _BOOL #t) (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint x (flip y h)) (make-NSSize w h))))) - (define/public (move x y) + (define/public (internal-move x y) (set-size x y (get-width) (get-height))) + (define/public (move x y) + (internal-move x y)) (define accept-drag? #f) (define accept-parent-drag? #f) diff --git a/collects/mred/private/wxtop.rkt b/collects/mred/private/wxtop.rkt index a0858c4816..c1fd3e71a6 100644 --- a/collects/mred/private/wxtop.rkt +++ b/collects/mred/private/wxtop.rkt @@ -90,7 +90,7 @@ [panel #f] [use-default-position? (and (= -11111 (list-ref args 2)) - (= -11111 (list-ref args (if dlg? 3 1))))] + (= -11111 (list-ref args (if dlg? 3 1))))] [enabled? #t] [focus #f] diff --git a/collects/scribblings/gui/dialog-class.scrbl b/collects/scribblings/gui/dialog-class.scrbl index 98f5e55dd6..15df432952 100644 --- a/collects/scribblings/gui/dialog-class.scrbl +++ b/collects/scribblings/gui/dialog-class.scrbl @@ -16,7 +16,9 @@ A dialog is a top-level window that is @defterm{modal}: while the [height (or/c (integer-in 0 10000) false/c) #f] [x (or/c (integer-in 0 10000) false/c) #f] [y (or/c (integer-in 0 10000) false/c) #f] - [style (listof (one-of/c 'no-caption 'resize-border 'no-sheet)) null] + [style (listof (one-of/c 'no-caption 'resize-border + 'no-sheet 'close-button)) + null] [enabled any/c #t] [border (integer-in 0 1000) 0] [spacing (integer-in 0 1000) 0] @@ -68,6 +70,9 @@ The @scheme[style] flags adjust the appearance of the dialog on some @item{@scheme['no-sheet] --- uses a movable window for the dialog, even if a parent window is provided (Mac OS X)} + @item{@scheme['close-button] --- include a close button in the + dialog's title bar, which would not normally be included (Mac OS X)} + ] Even if the dialog is not shown, a few notification events may be From 347869fc9e90560493f39654afd7037be7dac690 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 25 Nov 2010 08:02:33 -0700 Subject: [PATCH 104/255] fix some racket/gui tests and fix cocoa frame centering --- collects/mred/private/wx/cocoa/frame.rkt | 12 +++++------ collects/tests/gracket/windowing.rktl | 27 ++++++++++-------------- 2 files changed, 17 insertions(+), 22 deletions(-) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 79e5c6a3a6..81972157be 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -451,15 +451,15 @@ #:type _NSRect (make-NSRect (make-NSPoint (if (or (eq? dir 'both) (eq? dir 'horizontal)) - (/ (- (NSSize-width (NSRect-size s)) - (NSSize-width (NSRect-size f))) - 2) + (quotient (- (NSSize-width (NSRect-size s)) + (NSSize-width (NSRect-size f))) + 2) (NSPoint-x (NSRect-origin f))) (if (or (eq? dir 'both) (eq? dir 'vertical)) - (/ (- (NSSize-height (NSRect-size s)) - (NSSize-height (NSRect-size f))) - 2) + (quotient (- (NSSize-height (NSRect-size s)) + (NSSize-height (NSRect-size f))) + 2) (NSPoint-x (NSRect-origin f)))) (NSRect-size f)) display: #:type _BOOL #t))) diff --git a/collects/tests/gracket/windowing.rktl b/collects/tests/gracket/windowing.rktl index 52f0f2459c..34e479a439 100644 --- a/collects/tests/gracket/windowing.rktl +++ b/collects/tests/gracket/windowing.rktl @@ -66,7 +66,7 @@ (test #t `(client-size ,f ,cw ,ch ,w ,h) (and (<= 1 cw w) (<= 1 ch h)))) (stv f refresh)) -(define (area-tests f sw? sh? no-stretch?) +(define (area-tests f sw? sh? no-stretch? use-client-size?) (printf "Area ~a\n" f) (let ([x (send f min-width)] [y (send f min-height)]) @@ -75,7 +75,9 @@ (stv (send f get-top-level-window) reflow-container) (pause) ; to make sure size has taken effect (let-values ([(w h) (if no-stretch? - (send f get-size) + (if use-client-size? + (send f get-client-size) + (send f get-size)) (values 0 0))]) (printf "Size ~a x ~a\n" w h) (when no-stretch? @@ -95,7 +97,7 @@ (stv f min-height y))) (define (containee-tests f sw? sh? m) - (area-tests f sw? sh? #f) + (area-tests f sw? sh? #f #f) (printf "Containee ~a\n" f) (st m f horiz-margin) (st m f vert-margin) @@ -166,7 +168,7 @@ (st my-l b get-plain-label) (stv b set-label &-l))) -(let ([f (make-object frame% "Yes & No" #f 150 151 20 21)]) +(let ([f (make-object frame% "Yes & No" #f 150 151 70 21)]) (let ([init-tests (lambda (hidden?) (st "Yes & No" f get-label) @@ -177,15 +179,8 @@ (stv f set-label "Yes & No") (st #f f get-parent) (st f f get-top-level-window) - (case (system-type 'os) - [(unix) - (st 21 f get-x) - (if hidden? - (st 43 f get-y) - (st 22 f get-y))] - [else - (st 20 f get-x) - (st 21 f get-y)]) + (st 70 f get-x) + (st 21 f get-y) (st 150 f get-width) (st 151 f get-height) (stvals (list (send f get-width) (send f get-height)) f get-size) @@ -218,7 +213,7 @@ [container-tests (lambda () (printf "Container\n") - (area-tests f #t #t #t) + (area-tests f #t #t #t #t) (let-values ([(x y) (send f container-size null)]) (st x f min-width) (st y f min-height)) @@ -263,7 +258,7 @@ (stv f iconize #t) (pause) (pause) - (st #t f is-iconized?) ; NB: test will fail on MacOS + (st #t f is-iconized?) (stv f show #t) (pause) (st #f f is-iconized?) @@ -1010,7 +1005,7 @@ (test-controls panel frame) (if win? ((if % containee-window-tests window-tests) panel #t #t (and % frame) frame 0) - (area-tests panel #t #t #f)) + (area-tests panel #t #t #f #f)) (when (is-a? panel panel%) (st #t panel get-orientation (is-a? panel horizontal-panel%))) (container-tests panel win?) From df9c4c8c6906de97b919fa5f56c32a84a1b58afd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 25 Nov 2010 08:41:50 -0700 Subject: [PATCH 105/255] cocoa: don't treat dead-key events as normal character events but more work is still needed for multi-key input --- collects/mred/private/wx/cocoa/window.rkt | 27 ++++++++++++++++------- 1 file changed, 19 insertions(+), 8 deletions(-) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index a23a7a7295..5e5fd3ba7d 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -78,6 +78,7 @@ (import-protocol NSTextInput) (define current-insert-text (make-parameter #f)) +(define current-set-mark (make-parameter #f)) (define NSDragOperationCopy 1) @@ -169,6 +170,9 @@ [-a _NSRange (markedRange) (make-NSRange 0 0)] [-a _NSRange (selectedRange) (make-NSRange 0 0)] [-a _void (setMarkedText: [_id aString] selectedRange: [_NSRange selRange]) + ;; We interpreter a call to `setMarkedText:' as meaning that the + ;; key is a dead key for composing some other character. + (let ([m (current-set-mark)]) (when m (set-box! m #t))) (void)] [-a _id (validAttributesForMarkedText) #f] [-a _id (attributedSubstringFromRange: [_NSRange theRange]) #f] @@ -213,7 +217,8 @@ (let ([wx (->wx wxb)]) (and wx - (let ([inserted-text (box #f)]) + (let ([inserted-text (box #f)] + [set-mark (box #f)]) (unless wheel? ;; Calling `interpretKeyEvents:' allows key combinations to be ;; handled, such as option-e followed by e to produce é. The @@ -222,16 +227,22 @@ ;; give us back the text in the parameter. For now, we ignore the ;; text and handle the event as usual, though probably we should ;; be doing something with it. - (parameterize ([current-insert-text inserted-text]) - (tellv self interpretKeyEvents: (tell (tell NSArray alloc) - initWithObjects: #:type (_ptr i _id) event - count: #:type _NSUInteger 1)))) + (parameterize ([current-insert-text inserted-text] + [current-set-mark set-mark]) + (let ([array (tell (tell NSArray alloc) + initWithObjects: #:type (_ptr i _id) event + count: #:type _NSUInteger 1)]) + (tellv self interpretKeyEvents: array) + (tellv array release)))) (let* ([modifiers (tell #:type _NSUInteger event modifierFlags)] [bit? (lambda (m b) (positive? (bitwise-and m b)))] [pos (tell #:type _NSPoint event locationInWindow)] - [str (if wheel? - #f - (tell #:type _NSString event characters))] + [str (cond + [wheel? #f] + [(unbox set-mark) ""] ; => dead key for composing characters + [(unbox inserted-text)] + [else + (tell #:type _NSString event characters)])] [control? (bit? modifiers NSControlKeyMask)] [option? (bit? modifiers NSAlternateKeyMask)] [delta-y (and wheel? From aaa39873dbe606cc9e485a95412627efc4ffd3d1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 25 Nov 2010 08:50:37 -0700 Subject: [PATCH 106/255] v5.0.99.3 --- src/racket/src/schvers.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/racket/src/schvers.h b/src/racket/src/schvers.h index f0dc87a25b..81f05695d2 100644 --- a/src/racket/src/schvers.h +++ b/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "5.0.99.2" +#define MZSCHEME_VERSION "5.0.99.3" #define MZSCHEME_VERSION_X 5 #define MZSCHEME_VERSION_Y 0 #define MZSCHEME_VERSION_Z 99 -#define MZSCHEME_VERSION_W 2 +#define MZSCHEME_VERSION_W 3 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) From 4a0c276d4cc295b4ff40e490194fecd2adca3c28 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 24 Nov 2010 17:11:16 -0500 Subject: [PATCH 107/255] More content hooks for the wiki template. (And remove a bogus leftover definition.) --- collects/meta/web/stubs/wiki.rkt | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/collects/meta/web/stubs/wiki.rkt b/collects/meta/web/stubs/wiki.rkt index 11c3f29732..62f8198eb6 100644 --- a/collects/meta/web/stubs/wiki.rkt +++ b/collects/meta/web/stubs/wiki.rkt @@ -4,12 +4,8 @@ (define-context "stubs/wiki" #:resources www:the-resources) -(define header+footer - (delay (regexp-split #rx"{{{BODY}}}" - (xml->string @page[#:id 'browse-downloads - #:html-only #t - #:part-of 'download - "{{{BODY}}}"])))) - (define template - @page[#:title "{{{TITLE}}}" "{{{BODY}}}"]) + (page #:title "{{{TITLE}}}" + #:extra-headers "{{{HEADERS}}}" + #:extra-body-attrs '(|{{{ATTRS}}}|: #t) + "{{{BODY}}}")) From 41d6459e9d8c015f55cf5d39c8b1d12c8ff0b009 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 25 Nov 2010 11:00:41 -0500 Subject: [PATCH 108/255] New Racket version 5.0.99.3. --- src/worksp/gracket/gracket.manifest | 2 +- src/worksp/gracket/gracket.rc | 8 ++++---- src/worksp/mzcom/mzcom.rc | 8 ++++---- src/worksp/mzcom/mzobj.rgs | 6 +++--- src/worksp/racket/racket.rc | 8 ++++---- src/worksp/starters/start.rc | 8 ++++---- 6 files changed, 20 insertions(+), 20 deletions(-) diff --git a/src/worksp/gracket/gracket.manifest b/src/worksp/gracket/gracket.manifest index ce0285c16b..722786809c 100644 --- a/src/worksp/gracket/gracket.manifest +++ b/src/worksp/gracket/gracket.manifest @@ -1,7 +1,7 @@ Date: Thu, 25 Nov 2010 11:11:27 -0500 Subject: [PATCH 109/255] Fixing error introduce by Robby in fd53321 --- collects/rackunit/private/check.rkt | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/collects/rackunit/private/check.rkt b/collects/rackunit/private/check.rkt index 75749047ac..3a059a4987 100644 --- a/collects/rackunit/private/check.rkt +++ b/collects/rackunit/private/check.rkt @@ -171,9 +171,15 @@ (name (identifier? #'name) (syntax/loc stx - (λ (formal ...) (check-secret-name formal ... - #:location (quote loc) - #:expression (quote (name actual ...))))))))) + (case-lambda + [(formal ...) + (check-secret-name formal ... + #:location (quote loc) + #:expression (quote (name actual ...)))] + [(formal ... msg) + (check-secret-name formal ... msg + #:location (quote loc) + #:expression (quote (name actual ...)))])))))) )))))) (define-syntax define-simple-check From 81cb890323a26758f228195f295c90de41504e45 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 25 Nov 2010 11:27:22 -0500 Subject: [PATCH 110/255] Fixing problem introduce in 686ec83. Definitely fixes check-dists, may break bundle, but I don't think so --- collects/meta/build/bundle | 2 +- collects/meta/check-dists.rkt | 2 +- collects/meta/checker.rkt | 7 +++++-- 3 files changed, 7 insertions(+), 4 deletions(-) diff --git a/collects/meta/build/bundle b/collects/meta/build/bundle index 79c6f3cbf3..c7e080a1ea 100755 --- a/collects/meta/build/bundle +++ b/collects/meta/build/bundle @@ -227,7 +227,7 @@ (error 'binaries "no binaries found for ~s" platform))) *platforms* *platform-tree-lists*) ;; Get the racket tree, remove junk and binary stuff - (set-racket-tree! racket-base/ racket/-name *platform-tree-lists*) + (set-racket-tree! racket/ racket-base/ racket/-name *platform-tree-lists*) (set-bin-files-delayed-lists! (delay (map (lambda (trees) (sort* (mappend tree-flatten (add-trees trees)))) diff --git a/collects/meta/check-dists.rkt b/collects/meta/check-dists.rkt index 600bdb1ba1..4726d845b7 100644 --- a/collects/meta/check-dists.rkt +++ b/collects/meta/check-dists.rkt @@ -22,7 +22,7 @@ (register-spec! 'verify! verify!) (register-spec! 'distribute! void) - (set-racket-tree! racket-base/ racket/-name null) + (set-racket-tree! racket/ racket-base/ racket/-name null) (set-bin-files-delayed-lists! ;; FIXME: hard-wired list of binary-specific files diff --git a/collects/meta/checker.rkt b/collects/meta/checker.rkt index 8a5acc53d5..9d17a223f8 100644 --- a/collects/meta/checker.rkt +++ b/collects/meta/checker.rkt @@ -3,7 +3,8 @@ #lang scheme/base -(require scheme/cmdline scheme/runtime-path scheme/match scheme/promise +(require scheme/cmdline scheme/runtime-path scheme/match scheme/promise + scheme/list ; for use in specs too (for-syntax scheme/base) ; for runtime-path (except-in scheme/mpair mappend) (only-in (lib "process.ss") system) @@ -560,8 +561,10 @@ (provide checker-namespace-anchor) (define-namespace-anchor checker-namespace-anchor) +(define racket/ #f) (provide set-racket-tree!) -(define (set-racket-tree! racket-base/ racket/-name tree-lists) +(define (set-racket-tree! racket/* racket-base/ racket/-name tree-lists) + (set! racket/ racket/*) (set! *platform-tree-lists* tree-lists) (dprintf "Scanning main tree...") (set! *racket-tree* From e081af2aef7e2b98c6c8671f38810bfbcc88a079 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 25 Nov 2010 11:38:43 -0500 Subject: [PATCH 111/255] This test relied on the old source location losing behavior of Rackunit --- collects/tests/rackunit/pr10950.rkt | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/collects/tests/rackunit/pr10950.rkt b/collects/tests/rackunit/pr10950.rkt index 1663aaaeb9..c99dd9d234 100644 --- a/collects/tests/rackunit/pr10950.rkt +++ b/collects/tests/rackunit/pr10950.rkt @@ -4,13 +4,19 @@ racket/port tests/eli-tester) -(test - (with-output-to-string +(define output + (with-output-to-string (lambda () (parameterize ([current-error-port (current-output-port)]) (define-check (check3) (fail-check)) - (run-tests (test-suite "tests" (let ((foo check3)) (foo))))))) - => - "--------------------\ntests > #f\nUnnamed test \nFAILURE\nname: check3\nlocation: unknown:?:?\nparams: \n--------------------\n0 success(es) 1 failure(s) 0 error(s) 1 test(s) run\n") \ No newline at end of file + (run-tests (test-suite "tests" (let ((foo check3)) (foo)))))))) + +(test + (regexp-match + (regexp (format "~a.*~a" + (regexp-quote "--------------------\ntests > #f\nUnnamed test \nFAILURE\nname: check3\nlocation: ") + + (regexp-quote "/collects/tests/rackunit/pr10950.rkt:14:51\nparams: \n--------------------\n0 success(es) 1 failure(s) 0 error(s) 1 test(s) run\n"))) + output)) \ No newline at end of file From 68051f845a8642e16f9749e0775195a9075e98aa Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 25 Nov 2010 11:47:02 -0500 Subject: [PATCH 112/255] Fixing use and documentation of draw-bitmap-section-smooth --- collects/handin-client/client-gui.rkt | 4 ++-- collects/scribblings/draw/bitmap-dc-class.scrbl | 2 -- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/collects/handin-client/client-gui.rkt b/collects/handin-client/client-gui.rkt index ed7f1016f9..ce78530a2f 100644 --- a/collects/handin-client/client-gui.rkt +++ b/collects/handin-client/client-gui.rkt @@ -704,13 +704,13 @@ (make-object bitmap% (quotient w 2) (quotient h 2)))] [mdc (make-object bitmap-dc% bm2)]) (send mdc draw-bitmap-section-smooth bm - 0 0 (quotient w 2) (quotient h 2) + 0 0 0 0 w h) (send mdc set-bitmap #f) (when mbm2 (send mdc set-bitmap mbm2) (send mdc draw-bitmap-section-smooth (send bm get-loaded-mask) - 0 0 (quotient w 2) (quotient h 2) + 0 0 0 0 w h) (send mdc set-bitmap #f) (send bm2 set-loaded-mask mbm2)) diff --git a/collects/scribblings/draw/bitmap-dc-class.scrbl b/collects/scribblings/draw/bitmap-dc-class.scrbl index ac591d7c98..bf3d9ee55c 100644 --- a/collects/scribblings/draw/bitmap-dc-class.scrbl +++ b/collects/scribblings/draw/bitmap-dc-class.scrbl @@ -30,8 +30,6 @@ Creates a new memory DC. If @scheme[bitmap] is not @scheme[#f], it is @defmethod[(draw-bitmap-section-smooth [source (is-a?/c bitmap%)] [dest-x real?] [dest-y real?] - [dest-width (and/c real? (not/c negative?))] - [dest-height (and/c real? (not/c negative?))] [src-x real?] [src-y real?] [src-width (and/c real? (not/c negative?))] From 6474b519bb16e431dcb76c8fb9f28982050bc39d Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 25 Nov 2010 12:01:44 -0500 Subject: [PATCH 113/255] Fixes usage of argb-pixels --- collects/tests/htdp-lang/htdp-image.rktl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/tests/htdp-lang/htdp-image.rktl b/collects/tests/htdp-lang/htdp-image.rktl index 41bce43b18..f21d453b73 100644 --- a/collects/tests/htdp-lang/htdp-image.rktl +++ b/collects/tests/htdp-lang/htdp-image.rktl @@ -96,8 +96,8 @@ (let ([bm-normal (make-object bitmap% (max 1 width) (max 1 height))] [bm-bitmap (make-object bitmap% (max 1 width) (max 1 height))] - [s-normal (make-bytes (* width height 4))] - [s-bitmap (make-bytes (* width height 4))]) + [s-normal (make-bytes (* (max 1 width) (max 1 height) 4))] + [s-bitmap (make-bytes (* (max 1 width) (max 1 height) 4))]) (send bdc set-bitmap bm-normal) (send bdc clear) From bd7ffb282fb42a975bff6f11e44d59081a82940f Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 25 Nov 2010 12:03:10 -0500 Subject: [PATCH 114/255] This code appears to have been copied from the other --- collects/tests/deinprogramm/image.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/tests/deinprogramm/image.rkt b/collects/tests/deinprogramm/image.rkt index 4bb2cc43b5..0ee64a739a 100644 --- a/collects/tests/deinprogramm/image.rkt +++ b/collects/tests/deinprogramm/image.rkt @@ -101,8 +101,8 @@ (let ([bm-normal (make-object bitmap% (max 1 width) (max 1 height))] [bm-bitmap (make-object bitmap% (max 1 width) (max 1 height))] - [s-normal (make-bytes (* width height 4))] - [s-bitmap (make-bytes (* width height 4))]) + [s-normal (make-bytes (* (max 1 width) (max 1 height) 4))] + [s-bitmap (make-bytes (* (max 1 width) (max 1 height) 4))]) (send bdc set-bitmap bm-normal) (send bdc clear) From 0540359965fd1836fea319fbaadeb2090300ce64 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 25 Nov 2010 10:30:55 -0700 Subject: [PATCH 115/255] fix GC handling of cpointers with offsets --- src/racket/src/mzmark.c | 41 ++++++++++---------------------------- src/racket/src/mzmarksrc.c | 7 +++---- 2 files changed, 13 insertions(+), 35 deletions(-) diff --git a/src/racket/src/mzmark.c b/src/racket/src/mzmark.c index 835c6d69f7..a9ce6020f5 100644 --- a/src/racket/src/mzmark.c +++ b/src/racket/src/mzmark.c @@ -152,7 +152,9 @@ static int quotesyntax_obj_FIXUP(void *p, struct NewGC *gc) { static int cpointer_obj_SIZE(void *p, struct NewGC *gc) { return - gcBYTES_TO_WORDS(sizeof(Scheme_Cptr)); + (SCHEME_CPTR_HAS_OFFSET(p) + ? gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr)) + : gcBYTES_TO_WORDS(sizeof(Scheme_Cptr))); } static int cpointer_obj_MARK(void *p, struct NewGC *gc) { @@ -161,7 +163,9 @@ static int cpointer_obj_MARK(void *p, struct NewGC *gc) { } gcMARK2(SCHEME_CPTR_TYPE(p), gc); return - gcBYTES_TO_WORDS(sizeof(Scheme_Cptr)); + (SCHEME_CPTR_HAS_OFFSET(p) + ? gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr)) + : gcBYTES_TO_WORDS(sizeof(Scheme_Cptr))); } static int cpointer_obj_FIXUP(void *p, struct NewGC *gc) { @@ -170,38 +174,13 @@ static int cpointer_obj_FIXUP(void *p, struct NewGC *gc) { } gcFIXUP2(SCHEME_CPTR_TYPE(p), gc); return - gcBYTES_TO_WORDS(sizeof(Scheme_Cptr)); + (SCHEME_CPTR_HAS_OFFSET(p) + ? gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr)) + : gcBYTES_TO_WORDS(sizeof(Scheme_Cptr))); } #define cpointer_obj_IS_ATOMIC 0 -#define cpointer_obj_IS_CONST_SIZE 1 - - -static int offset_cpointer_obj_SIZE(void *p, struct NewGC *gc) { - return - gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr)); -} - -static int offset_cpointer_obj_MARK(void *p, struct NewGC *gc) { - if (!(SCHEME_CPTR_FLAGS(p) & 0x1)) { - gcMARK2(SCHEME_CPTR_VAL(p), gc); - } - gcMARK2(SCHEME_CPTR_TYPE(p), gc); - return - gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr)); -} - -static int offset_cpointer_obj_FIXUP(void *p, struct NewGC *gc) { - if (!(SCHEME_CPTR_FLAGS(p) & 0x1)) { - gcFIXUP2(SCHEME_CPTR_VAL(p), gc); - } - gcFIXUP2(SCHEME_CPTR_TYPE(p), gc); - return - gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr)); -} - -#define offset_cpointer_obj_IS_ATOMIC 0 -#define offset_cpointer_obj_IS_CONST_SIZE 1 +#define cpointer_obj_IS_CONST_SIZE 0 static int twoptr_obj_SIZE(void *p, struct NewGC *gc) { diff --git a/src/racket/src/mzmarksrc.c b/src/racket/src/mzmarksrc.c index 30135283cb..eeb1a32bca 100644 --- a/src/racket/src/mzmarksrc.c +++ b/src/racket/src/mzmarksrc.c @@ -61,10 +61,9 @@ cpointer_obj { } gcMARK2(SCHEME_CPTR_TYPE(p), gc); size: - if (SCHEME_CPTR_HAS_OFFSET(p)) - return gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr)); - else - return gcBYTES_TO_WORDS(sizeof(Scheme_Cptr)); + (SCHEME_CPTR_HAS_OFFSET(p) + ? gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr)) + : gcBYTES_TO_WORDS(sizeof(Scheme_Cptr))); } twoptr_obj { From e0bcec082500e81a86ea2d307c371df53af4dc8c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 25 Nov 2010 10:38:28 -0700 Subject: [PATCH 116/255] cocoa: handle multi-key character input --- collects/mred/private/wx/cocoa/window.rkt | 183 ++++++++++++++-------- 1 file changed, 119 insertions(+), 64 deletions(-) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 5e5fd3ba7d..11ae6cda57 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -82,6 +82,16 @@ (define NSDragOperationCopy 1) +(import-class NSAttributedString) +(define _NSStringOrAttributed + (make-ctype _id + (lambda (v) + (cast v _NSString _id)) + (lambda (v) + (if (tell #:type _BOOL v isKindOfClass: (tell NSAttributedString class)) + (tell #:type _NSString v string) + (cast v _id _NSString))))) + (define-objc-mixin (KeyMouseResponder Superclass) [wxb] [-a _void (mouseDown: [_id event]) @@ -152,7 +162,7 @@ [-a _void (keyUp: [_id event]) (unless (do-key-event wxb event self #f #f) (super-tell #:type _void keyUp: event))] - [-a _void (insertText: [_NSString str]) + [-a _void (insertText: [_NSStringOrAttributed str]) (let ([cit (current-insert-text)]) (if cit (set-box! cit str) @@ -163,24 +173,47 @@ (send wx key-event-as-string str)))))))] ;; for NSTextInput: - [-a _BOOL (hasMarkedText) #f] + [-a _BOOL (hasMarkedText) (get-saved-marked wxb)] [-a _id (validAttributesForMarkedText) (tell NSArray array)] - [-a _void (unmarkText) (void)] - [-a _NSRange (markedRange) (make-NSRange 0 0)] + [-a _void (unmarkText) + (set-saved-marked! wxb #f)] + [-a _NSRange (markedRange) + (let ([saved-marked (get-saved-marked wxb)]) + (make-NSRange 0 (if saved-marked 0 (length saved-marked))))] [-a _NSRange (selectedRange) (make-NSRange 0 0)] - [-a _void (setMarkedText: [_id aString] selectedRange: [_NSRange selRange]) + [-a _void (setMarkedText: [_NSStringOrAttributed aString] selectedRange: [_NSRange selRange]) ;; We interpreter a call to `setMarkedText:' as meaning that the ;; key is a dead key for composing some other character. (let ([m (current-set-mark)]) (when m (set-box! m #t))) + ;; At the same time, we need to remember the text: + (set-saved-marked! wxb (range-substring aString selRange)) (void)] [-a _id (validAttributesForMarkedText) #f] - [-a _id (attributedSubstringFromRange: [_NSRange theRange]) #f] + [-a _id (attributedSubstringFromRange: [_NSRange theRange]) + (let ([saved-marked (get-saved-marked wxb)]) + (and saved-marked + (let ([s (tell (tell NSAttributedString alloc) + initWithString: #:type _NSString + (range-substring saved-marked theRange))]) + (tellv s autorelease) + s)))] + [-a _NSUInteger (characterIndexForPoint: [_NSPoint thePoint]) 0] [-a _NSInteger (conversationIdentifier) 0] [-a _void (doCommandBySelector: [_SEL aSelector]) (void)] - [-a _NSRect (firstRectForCharacterRange: [_NSRange r]) (make-NSRect (make-NSPoint 0 0) - (make-NSSize 0 0))] + [-a _NSRect (firstRectForCharacterRange: [_NSRange r]) + ;; This location is used to place a window for multi-character + ;; input, such as when typing Chinese with Pinyin + (let ([f (tell #:type _NSRect self frame)] + [pt (tell #:type _NSPoint (tell self window) + convertBaseToScreen: + #:type _NSPoint + (tell #:type _NSPoint self + convertPoint: #:type _NSPoint + (make-NSPoint 0 0) + toView: #f))]) + (make-NSRect pt (NSRect-size f)))] ;; Dragging: [-a _int (draggingEntered: [_id info]) @@ -200,6 +233,18 @@ (lambda () (send wx do-on-drop-file s))))))))))) #t]) +(define (set-saved-marked! wxb str) + (let ([wx (->wx wxb)]) + (when wx + (send wx set-saved-marked str)))) +(define (get-saved-marked wxb) + (let ([wx (->wx wxb)]) + (and wx + (send wx get-saved-marked)))) +(define (range-substring s range) + (let ([start (min (max 0 (NSRange-location range)) (string-length s))]) + (substring s start (max (min start (NSRange-length range)) (string-length s))))) + (define-objc-mixin (KeyMouseTextResponder Superclass) #:mixins (KeyMouseResponder) @@ -246,61 +291,67 @@ [control? (bit? modifiers NSControlKeyMask)] [option? (bit? modifiers NSAlternateKeyMask)] [delta-y (and wheel? - (tell #:type _CGFloat event deltaY))]) - (let-values ([(x y) (send wx window-point-to-view pos)]) - (let ([k (new key-event% - [key-code (if wheel? - (if (positive? delta-y) - 'wheel-up - 'wheel-down) - (or - (map-key-code (tell #:type _ushort event keyCode)) - (if (string=? "" str) - #\nul - (let ([c (string-ref str 0)]) - (or (and control? - (char<=? #\u00 c #\u1F) - (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) - (and (string? alt-str) - (= 1 (string-length alt-str)) - (string-ref alt-str 0)))) - c)))))] - [shift-down (bit? modifiers NSShiftKeyMask)] - [control-down control?] - [meta-down (bit? modifiers NSCommandKeyMask)] - [alt-down option?] - [x (->long x)] - [y (->long y)] - [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] - [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) - (unless wheel? - (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) - (when (and (string? alt-str) - (= 1 (string-length alt-str))) - (let ([alt-code (string-ref alt-str 0)]) - (unless (equal? alt-code (send k get-key-code)) - (send k set-other-altgr-key-code alt-code))))) - (when (and (or (and option? - special-option-key?) - (and control? - (equal? (send k get-key-code) #\u00))) - (send k get-other-altgr-key-code)) - ;; swap altenate with main - (let ([other (send k get-other-altgr-key-code)]) - (send k set-other-altgr-key-code (send k get-key-code)) - (send k set-key-code other))) - (unless down? - ;; swap altenate with main - (send k set-key-release-code (send k get-key-code)) - (send k set-key-code 'release))) - (if (send wx definitely-wants-event? k) - (begin - (queue-window-event wx (lambda () - (send wx dispatch-on-char/sync k))) - #t) - (constrained-reply (send wx get-eventspace) - (lambda () (send wx dispatch-on-char k #t)) - #t))))))))) + (tell #:type _CGFloat event deltaY))] + [codes (cond + [wheel? (if (positive? delta-y) + '(wheel-up) + '(wheel-down))] + [(map-key-code (tell #:type _ushort event keyCode)) + => list] + [(string=? "" str) '(#\nul)] + [(and (= 1 (string-length str)) + (let ([c (string-ref str 0)]) + (or (and control? + (char<=? #\u00 c #\u1F) + (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) + (and (string? alt-str) + (= 1 (string-length alt-str)) + (string-ref alt-str 0))))))) + => list] + [else str])]) + (for/fold ([result #f]) ([one-code codes]) + (or + ;; Handle one key event + (let-values ([(x y) (send wx window-point-to-view pos)]) + (let ([k (new key-event% + [key-code one-code] + [shift-down (bit? modifiers NSShiftKeyMask)] + [control-down control?] + [meta-down (bit? modifiers NSCommandKeyMask)] + [alt-down option?] + [x (->long x)] + [y (->long y)] + [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] + [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) + (unless wheel? + (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) + (when (and (string? alt-str) + (= 1 (string-length alt-str))) + (let ([alt-code (string-ref alt-str 0)]) + (unless (equal? alt-code (send k get-key-code)) + (send k set-other-altgr-key-code alt-code))))) + (when (and (or (and option? + special-option-key?) + (and control? + (equal? (send k get-key-code) #\u00))) + (send k get-other-altgr-key-code)) + ;; swap altenate with main + (let ([other (send k get-other-altgr-key-code)]) + (send k set-other-altgr-key-code (send k get-key-code)) + (send k set-key-code other))) + (unless down? + ;; swap altenate with main + (send k set-key-release-code (send k get-key-code)) + (send k set-key-code 'release))) + (if (send wx definitely-wants-event? k) + (begin + (queue-window-event wx (lambda () + (send wx dispatch-on-char/sync k))) + #t) + (constrained-reply (send wx get-eventspace) + (lambda () (send wx dispatch-on-char k #t)) + #t)))) + result))))))) (define (do-mouse-event wxb event kind l? m? r? [ctl-kind kind]) (let ([wx (->wx wxb)]) @@ -725,8 +776,12 @@ (define/public (can-be-responder?) #t) (define/public (on-color-change) - (send parent on-color-change)))) + (send parent on-color-change)) + ;; For multi-key character composition: + (define saved-marked #f) + (define/public (set-saved-marked v) (set! saved-marked v)) + (define/public (get-saved-marked) saved-marked))) ;; ---------------------------------------- From e9562a8ddc256a7730c79f84996be0224eea8914 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 25 Nov 2010 10:40:06 -0700 Subject: [PATCH 117/255] Revert "Fixing use and documentation of draw-bitmap-section-smooth" because the implementation is wrong, not the documented contract This reverts commit 68051f845a8642e16f9749e0775195a9075e98aa. --- collects/handin-client/client-gui.rkt | 4 ++-- collects/scribblings/draw/bitmap-dc-class.scrbl | 2 ++ 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/collects/handin-client/client-gui.rkt b/collects/handin-client/client-gui.rkt index ce78530a2f..ed7f1016f9 100644 --- a/collects/handin-client/client-gui.rkt +++ b/collects/handin-client/client-gui.rkt @@ -704,13 +704,13 @@ (make-object bitmap% (quotient w 2) (quotient h 2)))] [mdc (make-object bitmap-dc% bm2)]) (send mdc draw-bitmap-section-smooth bm - 0 0 + 0 0 (quotient w 2) (quotient h 2) 0 0 w h) (send mdc set-bitmap #f) (when mbm2 (send mdc set-bitmap mbm2) (send mdc draw-bitmap-section-smooth (send bm get-loaded-mask) - 0 0 + 0 0 (quotient w 2) (quotient h 2) 0 0 w h) (send mdc set-bitmap #f) (send bm2 set-loaded-mask mbm2)) diff --git a/collects/scribblings/draw/bitmap-dc-class.scrbl b/collects/scribblings/draw/bitmap-dc-class.scrbl index bf3d9ee55c..ac591d7c98 100644 --- a/collects/scribblings/draw/bitmap-dc-class.scrbl +++ b/collects/scribblings/draw/bitmap-dc-class.scrbl @@ -30,6 +30,8 @@ Creates a new memory DC. If @scheme[bitmap] is not @scheme[#f], it is @defmethod[(draw-bitmap-section-smooth [source (is-a?/c bitmap%)] [dest-x real?] [dest-y real?] + [dest-width (and/c real? (not/c negative?))] + [dest-height (and/c real? (not/c negative?))] [src-x real?] [src-y real?] [src-width (and/c real? (not/c negative?))] From 8e8844641c63767ce0df4428051cf086ffa91e6e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 25 Nov 2010 10:52:15 -0700 Subject: [PATCH 118/255] fix `draw-bitmap-section-smooth' method of bitmap-dc<%> --- collects/racket/draw/private/bitmap-dc.rkt | 18 ++++++++++++---- collects/racket/draw/private/dc.rkt | 4 ++-- .../scribblings/draw/bitmap-dc-class.scrbl | 10 ++++++--- collects/tests/gracket/dc.rktl | 21 +++++++++++++++++++ 4 files changed, 44 insertions(+), 9 deletions(-) diff --git a/collects/racket/draw/private/bitmap-dc.rkt b/collects/racket/draw/private/bitmap-dc.rkt index 2758407159..6364a69387 100644 --- a/collects/racket/draw/private/bitmap-dc.rkt +++ b/collects/racket/draw/private/bitmap-dc.rkt @@ -82,7 +82,10 @@ (inherit draw-bitmap-section internal-set-bitmap internal-get-bitmap - get-size) + get-size + get-transformation + set-transformation + scale) (super-new) @@ -131,13 +134,20 @@ (def/public (draw-bitmap-section-smooth [bitmap% src] [real? dest-x] [real? dest-y] + [nonnegative-real? dest-w] + [nonnegative-real? dest-h] [real? src-x] [real? src-y] - [real? src-w] - [real? src-h] + [nonnegative-real? src-w] + [nonnegative-real? src-h] [(symbol-in solid opaque xor) [style 'solid]] [(make-or-false color%) [color black]] [(make-or-false bitmap%) [mask #f]]) - (draw-bitmap-section src dest-x dest-y src-x src-y src-w src-h style color mask)))) + (let ([sx (if (zero? src-w) 1.0 (/ dest-w src-w))] + [sy (if (zero? src-h) 1.0 (/ dest-h src-h))]) + (let ([t (get-transformation)]) + (scale sx sy) + (draw-bitmap-section src (/ dest-x sx) (/ dest-y sy) src-x src-y src-w src-h style color mask) + (set-transformation t)))))) (install-bitmap-dc-class! bitmap-dc%) diff --git a/collects/racket/draw/private/dc.rkt b/collects/racket/draw/private/dc.rkt index 9a33b84cd9..320d880818 100644 --- a/collects/racket/draw/private/dc.rkt +++ b/collects/racket/draw/private/dc.rkt @@ -1450,8 +1450,8 @@ [real? dest-y] [real? src-x] [real? src-y] - [real? src-w] - [real? src-h] + [nonnegative-real? src-w] + [nonnegative-real? src-h] [(symbol-in solid opaque xor) [style 'solid]] [(make-or-false color%) [color black]] [(make-or-false bitmap%) [mask #f]]) diff --git a/collects/scribblings/draw/bitmap-dc-class.scrbl b/collects/scribblings/draw/bitmap-dc-class.scrbl index ac591d7c98..4200395217 100644 --- a/collects/scribblings/draw/bitmap-dc-class.scrbl +++ b/collects/scribblings/draw/bitmap-dc-class.scrbl @@ -39,10 +39,14 @@ Creates a new memory DC. If @scheme[bitmap] is not @scheme[#f], it is [mask (or/c (is-a?/c bitmap%) false/c)]) boolean?]{ -The same as @method[dc<%> draw-bitmap-section]. In older version, this - method smoothed drawing more than @method[dc<%> draw-bitmap-section], but - smoothing is now provided by @method[dc<%> draw-bitmap-section]. +The same as @method[dc<%> draw-bitmap-section], except that + @racket[dest-width] and @racket[dest-height] cause the DC's + transformation to be adjusted while drawing the bitmap so + that the bitmap is scaled. +In older versions, this method smoothed drawing more than + @method[dc<%> draw-bitmap-section], but smoothing is now provided by + @method[dc<%> draw-bitmap-section]. } @defmethod[(get-argb-pixels [x real?] diff --git a/collects/tests/gracket/dc.rktl b/collects/tests/gracket/dc.rktl index 5e7d0f6f78..afce8bc4c5 100644 --- a/collects/tests/gracket/dc.rktl +++ b/collects/tests/gracket/dc.rktl @@ -194,6 +194,27 @@ #"\377\377\377\377\377\377\377\377\377\0\0\0\377\0\0\0\377\0\0\0"))) (test #t 'same-bits (equal? bs bs2))) +;; ---------------------------------------- +;; Test draw-bitmap-section-smooth + +(let* ([bm (make-bitmap 100 100)] + [dc (make-object bitmap-dc% bm)] + [bm2 (make-bitmap 70 70)] + [dc2 (make-object bitmap-dc% bm2)] + [bm3 (make-bitmap 70 70)] + [dc3 (make-object bitmap-dc% bm3)]) + (send dc draw-ellipse 0 0 100 100) + (send dc2 draw-bitmap-section-smooth bm + 10 10 50 50 + 0 0 100 100) + (send dc3 scale 0.5 0.5) + (send dc3 draw-bitmap bm 20 20) + (let ([s2 (make-bytes (* 4 70 70))] + [s3 (make-bytes (* 4 70 70))]) + (send bm2 get-argb-pixels 0 0 70 70 s2) + (send bm3 get-argb-pixels 0 0 70 70 s3) + (test #t 'same-scaled (equal? s2 s3)))) + ;; ---------------------------------------- (report-errs) From 9caf9f6203190b1a4a12672e448c1fa83b9007e2 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 25 Nov 2010 21:53:06 -0500 Subject: [PATCH 119/255] Drop brown build, due to the machine being too problematic. --- collects/meta/build/build | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/meta/build/build b/collects/meta/build/build index ec6bd46855..30abc55cb7 100755 --- a/collects/meta/build/build +++ b/collects/meta/build/build @@ -95,7 +95,7 @@ defbuild "ccs-linux" "i386-linux-ubuntu-jaunty" "moveto=/proj/racket" # defbuild "punge" "i386-linux-ubuntu-jaunty" "renice=20" # defbuild "bjorn" "i386-linux-gcc2" # defbuild "chicago" "i386-linux-debian" -defbuild "brownbuild" "i386-linux-debian" # really an AMD64 machine +# defbuild "brownbuild" "i386-linux-debian" # really an AMD64 machine # defbuild "inga" "i386-freebsd" # defbuild "chicago-unstable" "i386-linux-debian-unstable" # Start the main build last From 4842c708851b95d26eb6477558ff1a3b7a6855ef Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 25 Nov 2010 21:58:19 -0500 Subject: [PATCH 120/255] "TeachScheme!" -> "Program by Design". --- collects/meta/web/common/links.rkt | 6 +++--- collects/meta/web/www/learning.rkt | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/meta/web/common/links.rkt b/collects/meta/web/common/links.rkt index 5bb5ed731c..96c6ba666d 100644 --- a/collects/meta/web/common/links.rkt +++ b/collects/meta/web/common/links.rkt @@ -29,13 +29,13 @@ ;; External links (define* -htdp - @make-link["http://www.htdp.org/"]{@i{How to Design Programs}}) + @make-link["http://htdp.org/"]{@i{How to Design Programs}}) (define* -redex @make-link["http://redex.plt-scheme.org/"]{Redex}) -(define* -teachscheme - @make-link["http://www.teach-scheme.org/"]{TeachScheme!}) +(define* -pbd + @make-link["http://programbydesign.org/"]{Program by Design}) (define* -cookbook @make-link["http://schemecookbook.org/"]{Schematics Scheme Cookbook}) diff --git a/collects/meta/web/www/learning.rkt b/collects/meta/web/www/learning.rkt index 42852f3f79..3e9ed876d1 100644 --- a/collects/meta/web/www/learning.rkt +++ b/collects/meta/web/www/learning.rkt @@ -14,7 +14,7 @@ @text{@-plai — a textbook on programming languages.}] @parlist[ @strong{Outreach} - @text{@-teachscheme — a workshop to train teachers using @-htdp in the + @text{@-pbd — a workshop to train teachers using @-htdp in the classroom.} @text{@-bootstrap — a curriculum for middle-school students.}] @(apply parlist @strong{PLT Publications} From be2ea96cc8c61efb9d396e1bc96b0f07ca962629 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 25 Nov 2010 22:08:40 -0500 Subject: [PATCH 121/255] "TeachScheme!" -> "Program by Design" in DrRacket --- collects/drracket/private/app.rkt | 6 +++--- collects/string-constants/danish-string-constants.rkt | 2 +- collects/string-constants/dutch-string-constants.rkt | 2 +- collects/string-constants/english-string-constants.rkt | 2 +- collects/string-constants/french-string-constants.rkt | 2 +- collects/string-constants/german-string-constants.rkt | 2 +- collects/string-constants/japanese-string-constants.rkt | 2 +- collects/string-constants/korean-string-constants.rkt | 2 +- collects/string-constants/portuguese-string-constants.rkt | 2 +- collects/string-constants/russian-string-constants.rkt | 2 +- .../simplified-chinese-string-constants.rkt | 2 +- collects/string-constants/spanish-string-constants.rkt | 2 +- .../traditional-chinese-string-constants.rkt | 2 +- collects/string-constants/ukrainian-string-constants.rkt | 2 +- 14 files changed, 16 insertions(+), 16 deletions(-) diff --git a/collects/drracket/private/app.rkt b/collects/drracket/private/app.rkt index 5ec857a585..8590b0cae1 100644 --- a/collects/drracket/private/app.rkt +++ b/collects/drracket/private/app.rkt @@ -369,9 +369,9 @@ (λ (x y) (send-url url)))))]) (add (string-constant plt-homepage) "http://racket-lang.org/") - (add (string-constant teachscheme!-homepage) "http://www.teach-scheme.org/") - (add (string-constant how-to-design-programs) "http://www.htdp.org/") - + (add (string-constant pbd-homepage) "http://programbydesign.org/") + (add (string-constant how-to-design-programs) "http://htdp.org/") + (for-each (λ (tool) (cond [(drracket:tools:successful-tool-url tool) => diff --git a/collects/string-constants/danish-string-constants.rkt b/collects/string-constants/danish-string-constants.rkt index 5954e73e95..977047c1de 100644 --- a/collects/string-constants/danish-string-constants.rkt +++ b/collects/string-constants/danish-string-constants.rkt @@ -133,7 +133,7 @@ please adhere to these guidelines: (tool-web-sites "Tool Web Sites") ;; menu item title (plt-homepage "Racket") (how-to-use-scheme "How to Use Scheme") ;; title of a book. - (teachscheme!-homepage "TeachScheme!") ;; probably this should be a `word' in all languages + (pbd-homepage "Program by Design") ;;; bug report form (cancel-bug-report? "Fortryd afsendelse af fejlrapport?") diff --git a/collects/string-constants/dutch-string-constants.rkt b/collects/string-constants/dutch-string-constants.rkt index f0c63566cc..a14edccb42 100644 --- a/collects/string-constants/dutch-string-constants.rkt +++ b/collects/string-constants/dutch-string-constants.rkt @@ -33,7 +33,7 @@ (web-materials "Verwante Web Sites") ;; menu item title (plt-homepage "Racket") (how-to-use-scheme "How to Use Scheme") ;; title of a book. - (teachscheme!-homepage "TeachScheme!") ;; probably this should be a `word' in all languages + (pbd-homepage "Program by Design") ;;; bug report form (cancel-bug-report? "Melden defect afbreken?") diff --git a/collects/string-constants/english-string-constants.rkt b/collects/string-constants/english-string-constants.rkt index c6dd81652e..12b25d35ca 100644 --- a/collects/string-constants/english-string-constants.rkt +++ b/collects/string-constants/english-string-constants.rkt @@ -135,7 +135,7 @@ please adhere to these guidelines: (tool-web-sites "Tool Web Sites") ;; menu item title (plt-homepage "Racket") (how-to-use-scheme "How to Use Scheme") ;; title of a book. - (teachscheme!-homepage "TeachScheme!") ;; probably this should be a `word' in all languages + (pbd-homepage "Program by Design") ;;; bug report form (cancel-bug-report? "Cancel Bug Report?") diff --git a/collects/string-constants/french-string-constants.rkt b/collects/string-constants/french-string-constants.rkt index 655cc9ef32..32615600f8 100644 --- a/collects/string-constants/french-string-constants.rkt +++ b/collects/string-constants/french-string-constants.rkt @@ -135,7 +135,7 @@ (tool-web-sites "Sites web d'outils") ;; menu item title (plt-homepage "Racket") (how-to-use-scheme "How to Use Scheme") ;; title of a book. - (teachscheme!-homepage "TeachScheme!") ;; probably this should be a `word' in all languages + (pbd-homepage "Program by Design") ;;; bug report form (cancel-bug-report? "Annuler la soumission du rapport de bogue ?") diff --git a/collects/string-constants/german-string-constants.rkt b/collects/string-constants/german-string-constants.rkt index 7b035962bc..b29ba84b41 100644 --- a/collects/string-constants/german-string-constants.rkt +++ b/collects/string-constants/german-string-constants.rkt @@ -37,7 +37,7 @@ (tool-web-sites "Web-Seiten mit Tools") (plt-homepage "Racket") (how-to-use-scheme "How to Use Scheme") - (teachscheme!-homepage "TeachScheme!") + (pbd-homepage "Program by Design") ;;; bug report form (cancel-bug-report? "Bug-Report verwerfen?") diff --git a/collects/string-constants/japanese-string-constants.rkt b/collects/string-constants/japanese-string-constants.rkt index 115db43130..0f4511033c 100644 --- a/collects/string-constants/japanese-string-constants.rkt +++ b/collects/string-constants/japanese-string-constants.rkt @@ -135,7 +135,7 @@ please adhere to these guidelines: (tool-web-sites "ツールのウェブサイト") ;; menu item title (plt-homepage "Racket") (how-to-use-scheme "How to Use Scheme") ;; title of a book. - (teachscheme!-homepage "TeachScheme!") ;; probably this should be a `word' in all languages + (pbd-homepage "Program by Design") ;;; bug report form (cancel-bug-report? "バグ報告を中止しますか？") diff --git a/collects/string-constants/korean-string-constants.rkt b/collects/string-constants/korean-string-constants.rkt index c64fc4f716..bcfe68d7b1 100644 --- a/collects/string-constants/korean-string-constants.rkt +++ b/collects/string-constants/korean-string-constants.rkt @@ -53,7 +53,7 @@ (tool-web-sites "참고 사이트") ;; menu item title (plt-homepage "Racket") (how-to-use-scheme "How to Use Scheme") ;; title of a book. - (teachscheme!-homepage "TeachScheme!") ;; probably this should be a `word' in all languages + (pbd-homepage "Program by Design") ;;; bug report form (cancel-bug-report? "오류 보고를 취소하시겠습니까?") diff --git a/collects/string-constants/portuguese-string-constants.rkt b/collects/string-constants/portuguese-string-constants.rkt index 4f031f5a6f..3fec300969 100644 --- a/collects/string-constants/portuguese-string-constants.rkt +++ b/collects/string-constants/portuguese-string-constants.rkt @@ -135,7 +135,7 @@ please adhere to these guidelines: (tool-web-sites "Sítios Web de Ferramentas") ;; menu item title (plt-homepage "Racket") (how-to-use-scheme "Como Usar o Scheme") ;; title of a book. - (teachscheme!-homepage "AprenderScheme!") ;; probably this should be a `word' in all languages + (pbd-homepage "Program by Design") ;;; bug report form (cancel-bug-report? "Cancelar relatório de erro?") diff --git a/collects/string-constants/russian-string-constants.rkt b/collects/string-constants/russian-string-constants.rkt index 53d7358e17..af2c7e85a2 100644 --- a/collects/string-constants/russian-string-constants.rkt +++ b/collects/string-constants/russian-string-constants.rkt @@ -135,7 +135,7 @@ please adhere to these guidelines: (tool-web-sites "Web-сайты установленных инструментов") ;; menu item title (plt-homepage "Racket") (how-to-use-scheme "Как использовать Scheme") ;; title of a book. - (teachscheme!-homepage "TeachScheme!") ;; probably this should be a `word' in all languages + (pbd-homepage "Program by Design") ;;; bug report form (cancel-bug-report? "Отменить отправку отчета об ошибках?") diff --git a/collects/string-constants/simplified-chinese-string-constants.rkt b/collects/string-constants/simplified-chinese-string-constants.rkt index 8d596a5541..461e59ede9 100644 --- a/collects/string-constants/simplified-chinese-string-constants.rkt +++ b/collects/string-constants/simplified-chinese-string-constants.rkt @@ -62,7 +62,7 @@ (tool-web-sites "Tools网站") ;; menu item title (plt-homepage "Racket") (how-to-use-scheme "How to Use Scheme") ;; title of a book. - (teachscheme!-homepage "TeachScheme!") ;; probably this should be a `word' in all languages + (pbd-homepage "Program by Design") ;;; bug report form (cancel-bug-report? "取消程序错误报告？") diff --git a/collects/string-constants/spanish-string-constants.rkt b/collects/string-constants/spanish-string-constants.rkt index aad50daf90..d01d7790aa 100644 --- a/collects/string-constants/spanish-string-constants.rkt +++ b/collects/string-constants/spanish-string-constants.rkt @@ -43,7 +43,7 @@ (tool-web-sites "Sitios de Web de Herramientas") ;; menu item title (plt-homepage "Racket") (how-to-use-scheme "Cómo Usar Scheme") - (teachscheme!-homepage "TeachScheme!") + (pbd-homepage "Program by Design") ;;; bug report form (cancel-bug-report? "¿Cancelar el reporte de problemas?") diff --git a/collects/string-constants/traditional-chinese-string-constants.rkt b/collects/string-constants/traditional-chinese-string-constants.rkt index 4857df9e7f..b7ee2890e0 100644 --- a/collects/string-constants/traditional-chinese-string-constants.rkt +++ b/collects/string-constants/traditional-chinese-string-constants.rkt @@ -61,7 +61,7 @@ (tool-web-sites "Tools网站") ;; menu item title (plt-homepage "Racket") (how-to-use-scheme "How to Use Scheme") ;; title of a book. - (teachscheme!-homepage "TeachScheme!") ;; probably this should be a `word' in all languages + (pbd-homepage "Program by Design") ;;; bug report form (cancel-bug-report? "取消程序错误报告？") diff --git a/collects/string-constants/ukrainian-string-constants.rkt b/collects/string-constants/ukrainian-string-constants.rkt index 811ae52585..18e616ed17 100644 --- a/collects/string-constants/ukrainian-string-constants.rkt +++ b/collects/string-constants/ukrainian-string-constants.rkt @@ -135,7 +135,7 @@ please adhere to these guidelines: (tool-web-sites "Web-сайти встановлених інструментів") ;; menu item title (plt-homepage "Racket") (how-to-use-scheme "Як використовувати Scheme") ;; title of a book. - (teachscheme!-homepage "TeachScheme!") ;; probably this should be a `word' in all languages + (pbd-homepage "Program by Design") ;;; bug report form (cancel-bug-report? "Скасувати відправлення звіту про помилки?") From 22f1c96a4aad8514a1f0c63948ed5cb0e1fa7edc Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 25 Nov 2010 22:10:02 -0500 Subject: [PATCH 122/255] Remove unused `how-to-use-scheme' string. --- collects/string-constants/danish-string-constants.rkt | 1 - collects/string-constants/dutch-string-constants.rkt | 1 - collects/string-constants/english-string-constants.rkt | 1 - collects/string-constants/french-string-constants.rkt | 1 - collects/string-constants/german-string-constants.rkt | 1 - collects/string-constants/japanese-string-constants.rkt | 1 - collects/string-constants/korean-string-constants.rkt | 1 - collects/string-constants/portuguese-string-constants.rkt | 1 - collects/string-constants/russian-string-constants.rkt | 1 - .../string-constants/simplified-chinese-string-constants.rkt | 1 - collects/string-constants/spanish-string-constants.rkt | 1 - .../string-constants/traditional-chinese-string-constants.rkt | 1 - collects/string-constants/ukrainian-string-constants.rkt | 1 - 13 files changed, 13 deletions(-) diff --git a/collects/string-constants/danish-string-constants.rkt b/collects/string-constants/danish-string-constants.rkt index 977047c1de..a9a58e24bd 100644 --- a/collects/string-constants/danish-string-constants.rkt +++ b/collects/string-constants/danish-string-constants.rkt @@ -132,7 +132,6 @@ please adhere to these guidelines: (web-materials "Relaterede websites") ;; menu item title (tool-web-sites "Tool Web Sites") ;; menu item title (plt-homepage "Racket") - (how-to-use-scheme "How to Use Scheme") ;; title of a book. (pbd-homepage "Program by Design") ;;; bug report form diff --git a/collects/string-constants/dutch-string-constants.rkt b/collects/string-constants/dutch-string-constants.rkt index a14edccb42..1ac0bb16d5 100644 --- a/collects/string-constants/dutch-string-constants.rkt +++ b/collects/string-constants/dutch-string-constants.rkt @@ -32,7 +32,6 @@ ;;; important urls (web-materials "Verwante Web Sites") ;; menu item title (plt-homepage "Racket") - (how-to-use-scheme "How to Use Scheme") ;; title of a book. (pbd-homepage "Program by Design") ;;; bug report form diff --git a/collects/string-constants/english-string-constants.rkt b/collects/string-constants/english-string-constants.rkt index 12b25d35ca..086d1e35ae 100644 --- a/collects/string-constants/english-string-constants.rkt +++ b/collects/string-constants/english-string-constants.rkt @@ -134,7 +134,6 @@ please adhere to these guidelines: (web-materials "Related Web Sites") ;; menu item title (tool-web-sites "Tool Web Sites") ;; menu item title (plt-homepage "Racket") - (how-to-use-scheme "How to Use Scheme") ;; title of a book. (pbd-homepage "Program by Design") ;;; bug report form diff --git a/collects/string-constants/french-string-constants.rkt b/collects/string-constants/french-string-constants.rkt index 32615600f8..b976305859 100644 --- a/collects/string-constants/french-string-constants.rkt +++ b/collects/string-constants/french-string-constants.rkt @@ -134,7 +134,6 @@ (web-materials "Sites web apparentés") ;; menu item title (tool-web-sites "Sites web d'outils") ;; menu item title (plt-homepage "Racket") - (how-to-use-scheme "How to Use Scheme") ;; title of a book. (pbd-homepage "Program by Design") ;;; bug report form diff --git a/collects/string-constants/german-string-constants.rkt b/collects/string-constants/german-string-constants.rkt index b29ba84b41..4aeea50975 100644 --- a/collects/string-constants/german-string-constants.rkt +++ b/collects/string-constants/german-string-constants.rkt @@ -36,7 +36,6 @@ (web-materials "Verwandte Web-Seiten") (tool-web-sites "Web-Seiten mit Tools") (plt-homepage "Racket") - (how-to-use-scheme "How to Use Scheme") (pbd-homepage "Program by Design") ;;; bug report form diff --git a/collects/string-constants/japanese-string-constants.rkt b/collects/string-constants/japanese-string-constants.rkt index 0f4511033c..ecf092fc73 100644 --- a/collects/string-constants/japanese-string-constants.rkt +++ b/collects/string-constants/japanese-string-constants.rkt @@ -134,7 +134,6 @@ please adhere to these guidelines: (web-materials "関連するウェブサイト") ;; menu item title (tool-web-sites "ツールのウェブサイト") ;; menu item title (plt-homepage "Racket") - (how-to-use-scheme "How to Use Scheme") ;; title of a book. (pbd-homepage "Program by Design") ;;; bug report form diff --git a/collects/string-constants/korean-string-constants.rkt b/collects/string-constants/korean-string-constants.rkt index bcfe68d7b1..c60e4d674f 100644 --- a/collects/string-constants/korean-string-constants.rkt +++ b/collects/string-constants/korean-string-constants.rkt @@ -52,7 +52,6 @@ (web-materials "관련 사이트") ;; menu item title (tool-web-sites "참고 사이트") ;; menu item title (plt-homepage "Racket") - (how-to-use-scheme "How to Use Scheme") ;; title of a book. (pbd-homepage "Program by Design") ;;; bug report form diff --git a/collects/string-constants/portuguese-string-constants.rkt b/collects/string-constants/portuguese-string-constants.rkt index 3fec300969..32da893194 100644 --- a/collects/string-constants/portuguese-string-constants.rkt +++ b/collects/string-constants/portuguese-string-constants.rkt @@ -134,7 +134,6 @@ please adhere to these guidelines: (web-materials "Sítios Web Relacionados") ;; menu item title (tool-web-sites "Sítios Web de Ferramentas") ;; menu item title (plt-homepage "Racket") - (how-to-use-scheme "Como Usar o Scheme") ;; title of a book. (pbd-homepage "Program by Design") ;;; bug report form diff --git a/collects/string-constants/russian-string-constants.rkt b/collects/string-constants/russian-string-constants.rkt index af2c7e85a2..18b03a4600 100644 --- a/collects/string-constants/russian-string-constants.rkt +++ b/collects/string-constants/russian-string-constants.rkt @@ -134,7 +134,6 @@ please adhere to these guidelines: (web-materials "Связанные Web-сайты") ;; menu item title (tool-web-sites "Web-сайты установленных инструментов") ;; menu item title (plt-homepage "Racket") - (how-to-use-scheme "Как использовать Scheme") ;; title of a book. (pbd-homepage "Program by Design") ;;; bug report form diff --git a/collects/string-constants/simplified-chinese-string-constants.rkt b/collects/string-constants/simplified-chinese-string-constants.rkt index 461e59ede9..0aece53ff4 100644 --- a/collects/string-constants/simplified-chinese-string-constants.rkt +++ b/collects/string-constants/simplified-chinese-string-constants.rkt @@ -61,7 +61,6 @@ (web-materials "相关网站") ;; menu item title (tool-web-sites "Tools网站") ;; menu item title (plt-homepage "Racket") - (how-to-use-scheme "How to Use Scheme") ;; title of a book. (pbd-homepage "Program by Design") ;;; bug report form diff --git a/collects/string-constants/spanish-string-constants.rkt b/collects/string-constants/spanish-string-constants.rkt index d01d7790aa..e5284948b9 100644 --- a/collects/string-constants/spanish-string-constants.rkt +++ b/collects/string-constants/spanish-string-constants.rkt @@ -42,7 +42,6 @@ (web-materials "Sitios de Web Relacionados") (tool-web-sites "Sitios de Web de Herramientas") ;; menu item title (plt-homepage "Racket") - (how-to-use-scheme "Cómo Usar Scheme") (pbd-homepage "Program by Design") ;;; bug report form diff --git a/collects/string-constants/traditional-chinese-string-constants.rkt b/collects/string-constants/traditional-chinese-string-constants.rkt index b7ee2890e0..4048e4097f 100644 --- a/collects/string-constants/traditional-chinese-string-constants.rkt +++ b/collects/string-constants/traditional-chinese-string-constants.rkt @@ -60,7 +60,6 @@ (web-materials "相关网站") ;; menu item title (tool-web-sites "Tools网站") ;; menu item title (plt-homepage "Racket") - (how-to-use-scheme "How to Use Scheme") ;; title of a book. (pbd-homepage "Program by Design") ;;; bug report form diff --git a/collects/string-constants/ukrainian-string-constants.rkt b/collects/string-constants/ukrainian-string-constants.rkt index 18e616ed17..2bbbd349f4 100644 --- a/collects/string-constants/ukrainian-string-constants.rkt +++ b/collects/string-constants/ukrainian-string-constants.rkt @@ -134,7 +134,6 @@ please adhere to these guidelines: (web-materials "Пов'язані Web-сайти") ;; menu item title (tool-web-sites "Web-сайти встановлених інструментів") ;; menu item title (plt-homepage "Racket") - (how-to-use-scheme "Як використовувати Scheme") ;; title of a book. (pbd-homepage "Program by Design") ;;; bug report form From dbd1cfaf1029539c9268a5101dfd9486a347dac6 Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Fri, 26 Nov 2010 11:10:29 +0100 Subject: [PATCH 123/255] Don't use `teach-equal?' for `one-of' signature. I did this under the mistaken assumption `equal?' would not work for cycles, I think. --- collects/deinprogramm/signature/signature-syntax.rkt | 5 ++--- collects/lang/private/signature-syntax.rkt | 3 +-- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/collects/deinprogramm/signature/signature-syntax.rkt b/collects/deinprogramm/signature/signature-syntax.rkt index e8962846ec..5bf8b6e758 100644 --- a/collects/deinprogramm/signature/signature-syntax.rkt +++ b/collects/deinprogramm/signature/signature-syntax.rkt @@ -11,8 +11,7 @@ scheme/promise (for-syntax scheme/base) (for-syntax syntax/stx) - (for-syntax stepper/private/shared) - (only-in lang/private/teachprims teach-equal?)) + (for-syntax stepper/private/shared)) (define-for-syntax (phase-lift stx) (with-syntax ((?stx stx)) @@ -50,7 +49,7 @@ (syntax->list #'((?temp ?exp) ...))))) #'(let ((?temp ?exp) ...) ?check ... - (make-case-signature '?name (list ?temp ...) teach-equal? ?stx))))) + (make-case-signature '?name (list ?temp ...) equal? ?stx))))) ((predicate ?exp) (with-syntax ((?stx (phase-lift stx)) (?name name)) diff --git a/collects/lang/private/signature-syntax.rkt b/collects/lang/private/signature-syntax.rkt index 22a02dcc0e..6ec3ac1d95 100644 --- a/collects/lang/private/signature-syntax.rkt +++ b/collects/lang/private/signature-syntax.rkt @@ -11,7 +11,6 @@ (for-syntax scheme/base) (for-syntax syntax/stx) (for-syntax stepper/private/shared) - (only-in lang/private/teachprims teach-equal?) (for-syntax "firstorder.rkt")) (define-for-syntax (phase-lift stx) @@ -50,7 +49,7 @@ (syntax->list #'((?temp ?exp) ...))))) #'(let ((?temp ?exp) ...) ?check ... - (make-case-signature '?name (list ?temp ...) teach-equal? ?stx))))) + (make-case-signature '?name (list ?temp ...) equal? ?stx))))) ((predicate ?exp) (with-syntax ((?stx (phase-lift stx)) (?name name)) From 1d154e4bc320466063adeeb5ac72d6ebc9be7f61 Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Fri, 26 Nov 2010 13:27:35 +0100 Subject: [PATCH 124/255] Synch German string constants with latest. --- collects/string-constants/german-string-constants.rkt | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/collects/string-constants/german-string-constants.rkt b/collects/string-constants/german-string-constants.rkt index 4aeea50975..f89b7da066 100644 --- a/collects/string-constants/german-string-constants.rkt +++ b/collects/string-constants/german-string-constants.rkt @@ -344,8 +344,10 @@ (show-interactions-on-execute "Interaktionen beim Programmstart automatisch öffnen") (switch-to-module-language-automatically "Automatisch in die `module'-Sprache wechseln, wenn ein Modul geöffnet wird") (interactions-beside-definitions "Interaktionen neben den Definitionen anzeigen") ;; in preferences, below the checkbox one line above this one - (show-line-numbers "Zeilennummern anzeigen") - (hide-line-numbers "Zeilennummern ausblenden") + (show-line-numbers "Zeilennummern einblenden") + (show-line-numbers/menu "Zeilennummern einblenden") + (hide-line-numbers/menu "Zeilennummern ausblenden") + (limit-interactions-size "Umfang der Interaktionen einschränken") (background-color "Hintergrundfarbe") (default-text-color "Standard für Text") ;; used for configuring colors, but doesn't need the word "color" From 4c9794acc689b641a4b44667b9282b4cde18ac71 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 26 Nov 2010 08:50:41 -0600 Subject: [PATCH 125/255] drracket frames leak; add a test case --- collects/tests/drracket/leaky-frame.rkt | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) create mode 100644 collects/tests/drracket/leaky-frame.rkt diff --git a/collects/tests/drracket/leaky-frame.rkt b/collects/tests/drracket/leaky-frame.rkt new file mode 100644 index 0000000000..e208572bd0 --- /dev/null +++ b/collects/tests/drracket/leaky-frame.rkt @@ -0,0 +1,23 @@ +#lang racket +(require "drracket-test-util.rkt" + framework) + +(parameterize ([current-command-line-arguments '#()]) + (fire-up-drscheme-and-run-tests + (λ () + (define drs-frame1 (wait-for-drscheme-frame)) + (sync (system-idle-evt)) + (test:menu-select "File" "New") + (define drs-frame2b (make-weak-box (wait-for-new-frame drs-frame1))) + (sync (system-idle-evt)) + (test:menu-select "File" "Close") + (sync (system-idle-evt)) + (let loop ([n 30]) + (cond + [(zero? n) + (when (weak-box-value drs-frame2b) + (fprintf (current-error-port) "leak!\n"))] + [else + (collect-garbage) + (when (weak-box-value drs-frame2b) + (loop (- n 1)))]))))) From 1f61bbdc513ea7f07ae764cd0a6ae640e4e19479 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 26 Nov 2010 08:10:31 -0700 Subject: [PATCH 126/255] win32: frame size and iconize fixes --- collects/mred/private/wx/win32/const.rkt | 2 +- collects/mred/private/wx/win32/dialog.rkt | 6 ++++-- collects/mred/private/wx/win32/frame.rkt | 14 +++++++++----- collects/tests/gracket/windowing.rktl | 14 +++++++++++--- 4 files changed, 25 insertions(+), 11 deletions(-) diff --git a/collects/mred/private/wx/win32/const.rkt b/collects/mred/private/wx/win32/const.rkt index 6f8b4cb8ed..a72df0876c 100644 --- a/collects/mred/private/wx/win32/const.rkt +++ b/collects/mred/private/wx/win32/const.rkt @@ -400,7 +400,7 @@ (define BS_FLAT #x00008000) (define BS_RIGHTBUTTON BS_LEFTTEXT) -(define CW_USEDEFAULT #x80000000) +(define CW_USEDEFAULT (- #x80000000)) ; minus sign => int instead of uint (define WS_EX_LAYERED #x00080000) (define WS_EX_TRANSPARENT #x00000020) diff --git a/collects/mred/private/wx/win32/dialog.rkt b/collects/mred/private/wx/win32/dialog.rkt index c249f2f9b8..18ed2593e0 100644 --- a/collects/mred/private/wx/win32/dialog.rkt +++ b/collects/mred/private/wx/win32/dialog.rkt @@ -34,7 +34,7 @@ (class (dialog-mixin frame%) (super-new) - (define/override (create-frame parent label w h style) + (define/override (create-frame parent label x y w h style) (let ([hwnd (CreateDialogIndirectParamW hInstance (make-DLGTEMPLATE @@ -46,7 +46,9 @@ dialog-proc 0)]) (SetWindowTextW hwnd label) - (MoveWindow hwnd 0 0 w h #t) + (let ([x (if (= x -11111) 0 x)] + [y (if (= y -11111) 0 y)]) + (MoveWindow hwnd x y w h #t)) hwnd)) (define/override (is-dialog?) #t))) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index 058d5caaf4..4bbfcddf5a 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -108,7 +108,7 @@ pre-on-char pre-on-event reset-cursor-in-child) - (define/public (create-frame parent label w h style) + (define/public (create-frame parent label x y w h style) (CreateWindowExW (if (memq 'float style) (bitwise-ior WS_EX_TOOLWINDOW (if (memq 'no-caption style) @@ -131,7 +131,9 @@ 0 (bitwise-ior WS_CAPTION WS_MINIMIZEBOX))) - 0 0 w h + (if (= x -11111) CW_USEDEFAULT x) + (if (= y -11111) CW_USEDEFAULT y) + w h #f #f hInstance @@ -146,7 +148,7 @@ (define max-height #f) (super-new [parent #f] - [hwnd (create-frame parent label w h style)] + [hwnd (create-frame parent label x y w h style)] [style (cons 'deleted style)]) (define hwnd (get-hwnd)) @@ -185,7 +187,9 @@ (set! hidden-zoomed? (is-maximized?))) (super direct-show on? (if hidden-zoomed? SW_SHOWMAXIMIZED - SW_SHOW))) + SW_SHOW)) + (when (and on? (iconized?)) + (ShowWindow hwnd SW_RESTORE))) (define/public (destroy) (direct-show #f)) @@ -393,7 +397,7 @@ (define/public (iconize on?) (when (is-shown?) - (when (or on? (not (iconized?))) + (unless (eq? (and on? #t) (iconized?)) (ShowWindow hwnd (if on? SW_MINIMIZE SW_RESTORE))))) (define/private (get-placement) diff --git a/collects/tests/gracket/windowing.rktl b/collects/tests/gracket/windowing.rktl index 34e479a439..b90260e09a 100644 --- a/collects/tests/gracket/windowing.rktl +++ b/collects/tests/gracket/windowing.rktl @@ -259,6 +259,14 @@ (pause) (pause) (st #t f is-iconized?) + (stv f iconize #f) + (pause) + (pause) + (st #f f is-iconized?) + (stv f iconize #t) + (pause) + (pause) + (st #t f is-iconized?) (stv f show #t) (pause) (st #f f is-iconized?) @@ -277,16 +285,16 @@ (st 151 f get-height) (printf "Resize\n") - (stv f resize 56 57) + (stv f resize 156 57) (pause) (FAILS (st 34 f get-x)) (FAILS (st 37 f get-y)) - (st 56 f get-width) + (st 156 f get-width) (st 57 f get-height) (stv f center) (pause) - (st 56 f get-width) + (st 156 f get-width) (st 57 f get-height) (client->screen-tests) From 43e25a83f29b5832e0a66b69d8ee1842eeec0b7b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 26 Nov 2010 09:11:23 -0600 Subject: [PATCH 127/255] props --- collects/meta/props | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/meta/props b/collects/meta/props index d94a147965..86555507bf 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1416,6 +1416,7 @@ path/s is either such a string or a list of them. "collects/tests/drracket/hangman.rkt" responsible (robby matthias) drdr:command-line (gracket *) "collects/tests/drracket/io.rkt" drdr:command-line (gracket *) "collects/tests/drracket/language-test.rkt" responsible (robby matthias) drdr:command-line (gracket *) drdr:timeout 600 +"collects/tests/drracket/leaky-frame.rkt" drdr:command-line (gracket *) "collects/tests/drracket/memory-log.rkt" drdr:command-line (gracket *) "collects/tests/drracket/module-lang-test-utils.rkt" drdr:command-line (gracket-text "-t" *) "collects/tests/drracket/module-lang-test.rkt" drdr:command-line (gracket *) drdr:timeout 120 @@ -1474,10 +1475,10 @@ path/s is either such a string or a list of them. "collects/tests/gracket/random.rktl" drdr:command-line #f "collects/tests/gracket/showkey.rkt" drdr:command-line #f "collects/tests/gracket/sixlib.rktl" drdr:command-line #f -"collects/tests/gracket/unflushed-circle.rkt" drdr:command-line #f "collects/tests/gracket/test-editor-admin.rkt" drdr:command-line (gracket-text "-t" *) "collects/tests/gracket/testing.rktl" drdr:command-line (gracket "-f" *) "collects/tests/gracket/text-scale.rktl" drdr:command-line #f +"collects/tests/gracket/unflushed-circle.rkt" drdr:command-line #f "collects/tests/gracket/windowing.rktl" drdr:command-line (gracket "-f" *) "collects/tests/gracket/wxme-doc-random.rkt" drdr:command-line (mzc *) "collects/tests/gracket/wxme-random.rkt" drdr:command-line #f From 7da127227a3a493214b0878cd26bff6b51631115 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 26 Nov 2010 08:30:50 -0700 Subject: [PATCH 128/255] gtk & cocoa: frame iconize repairs In the "windowing.rktl" tests, for Gtk there are still race conditions between the program and the window manager. But for the first time ever, all platforms can pass the "windowing.rktl" test. --- collects/mred/private/wx/cocoa/frame.rkt | 4 +++- collects/mred/private/wx/gtk/frame.rkt | 2 ++ collects/tests/gracket/windowing.rktl | 24 ++++++++++++++++-------- 3 files changed, 21 insertions(+), 9 deletions(-) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 81972157be..eb2053c75c 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -520,7 +520,9 @@ (define/public (iconized?) (tell #:type _BOOL cocoa isMiniaturized)) (define/public (iconize on?) - (tellv cocoa miniaturize: cocoa)) + (if on? + (tellv cocoa miniaturize: cocoa) + (tellv cocoa deminiaturize: cocoa))) (define/public (set-title s) (tellv cocoa setTitle: #:type _NSString s)) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index c1c43315c6..994ab5f2d2 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -180,6 +180,7 @@ (connect-delete gtk) (connect-configure gtk) (connect-focus gtk) + (connect-window-state gtk) (define saved-title (or label "")) (define is-modified? #f) @@ -311,6 +312,7 @@ (hash-set! all-frames this #t) (hash-remove! all-frames this)) (super direct-show on?) + (when on? (gtk_window_deiconify gtk)) (register-frame-shown this on?)) (define/public (destroy) diff --git a/collects/tests/gracket/windowing.rktl b/collects/tests/gracket/windowing.rktl index b90260e09a..1f36d1d991 100644 --- a/collects/tests/gracket/windowing.rktl +++ b/collects/tests/gracket/windowing.rktl @@ -30,6 +30,17 @@ (thread (lambda () (sleep 0.01) (semaphore-post s))) (test s 'yield (yield s)))) +(define (iconize-pause) + (if (eq? 'unix (system-type)) + ;; iconization might take a while + ;; for the window manager to report back + (begin + (pause) + (when (regexp-match? #rx"darwin" (path->string (system-library-subpath))) + (sleep 0.75)) + (pause)) + (pause))) + (let ([s (make-semaphore 1)]) (test s 'yield-wrapped (yield s))) (let ([s (make-semaphore 1)]) @@ -256,21 +267,18 @@ (printf "Iconize\n") (stv f iconize #t) - (pause) - (pause) + (iconize-pause) (st #t f is-iconized?) (stv f iconize #f) - (pause) - (pause) + (iconize-pause) (st #f f is-iconized?) (stv f iconize #t) - (pause) - (pause) + (iconize-pause) (st #t f is-iconized?) (stv f show #t) - (pause) + (iconize-pause) (st #f f is-iconized?) - + (stv f maximize #t) (pause) (stv f maximize #f) From 2edadd611303978255f6ff53efa5b691a0f7f0a5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 26 Nov 2010 10:25:37 -0700 Subject: [PATCH 129/255] add pdf-dc%; make slideshow/pict depend on racket/draw, not racket/gui --- collects/mred/mred-sig.rkt | 1 + collects/racket/draw.rkt | 1 + collects/racket/draw/draw-sig.rkt | 32 ++++++++++ collects/racket/draw/draw-unit.rkt | 8 +++ .../racket/draw/private/post-script-dc.rkt | 57 +++++++++++------ collects/racket/draw/unsafe/cairo.rkt | 4 ++ collects/scribblings/draw/draw-unit.scrbl | 26 ++++++++ collects/scribblings/draw/pdf-dc-class.scrbl | 17 +++++ collects/scribblings/draw/pen-class.scrbl | 10 ++- .../draw/post-script-dc-class.scrbl | 2 +- collects/scribblings/draw/reference.scrbl | 2 + collects/slideshow/cmdline.rkt | 64 +++++++++++-------- collects/slideshow/core.rkt | 4 +- collects/slideshow/pict.rkt | 4 +- collects/slideshow/slides-to-picts.rkt | 4 +- collects/tests/gracket/draw.rkt | 24 +++---- collects/texpict/balloon.rkt | 2 +- collects/texpict/code.rkt | 2 +- collects/texpict/doc.txt | 2 +- collects/texpict/face.rkt | 2 +- collects/texpict/flash.rkt | 2 +- collects/texpict/mrpict-unit.rkt | 4 +- collects/texpict/mrpict.rkt | 8 +-- collects/texpict/private/common-unit.rkt | 2 +- collects/texpict/private/mrpict-extra.rkt | 9 +-- collects/texpict/utils.rkt | 15 +++-- doc/release-notes/racket/Draw_and_GUI_5_1.txt | 3 + 27 files changed, 222 insertions(+), 89 deletions(-) create mode 100644 collects/racket/draw/draw-sig.rkt create mode 100644 collects/racket/draw/draw-unit.rkt create mode 100644 collects/scribblings/draw/draw-unit.scrbl create mode 100644 collects/scribblings/draw/pdf-dc-class.scrbl diff --git a/collects/mred/mred-sig.rkt b/collects/mred/mred-sig.rkt index 1f8aa21788..0b5efef1eb 100644 --- a/collects/mred/mred-sig.rkt +++ b/collects/mred/mred-sig.rkt @@ -143,6 +143,7 @@ open-output-text-editor pane% panel% pasteboard% +pdf-dc% pen% pen-list% play-sound diff --git a/collects/racket/draw.rkt b/collects/racket/draw.rkt index db3c9f1ff3..03abf81407 100644 --- a/collects/racket/draw.rkt +++ b/collects/racket/draw.rkt @@ -27,6 +27,7 @@ dc<%> bitmap-dc% post-script-dc% + pdf-dc% ps-setup% current-ps-setup get-face-list get-family-builtin-face diff --git a/collects/racket/draw/draw-sig.rkt b/collects/racket/draw/draw-sig.rkt new file mode 100644 index 0000000000..0d29b7c2a0 --- /dev/null +++ b/collects/racket/draw/draw-sig.rkt @@ -0,0 +1,32 @@ +#lang racket/signature + +bitmap% +bitmap-dc% +brush% +brush-list% +color% +color-database<%> +current-ps-setup +dc<%> +dc-path% +font% +font-list% +font-name-directory<%> +get-face-list +get-family-builtin-face +gl-config% +gl-context<%> +make-bitmap +make-monochrome-bitmap +pdf-dc% +pen% +pen-list% +point% +post-script-dc% +ps-setup% +region% +the-brush-list +the-color-database +the-font-list +the-font-name-directory +the-pen-list diff --git a/collects/racket/draw/draw-unit.rkt b/collects/racket/draw/draw-unit.rkt new file mode 100644 index 0000000000..84c8f76393 --- /dev/null +++ b/collects/racket/draw/draw-unit.rkt @@ -0,0 +1,8 @@ +#lang racket/base +(require racket/unit + racket/draw + "draw-sig.rkt") + +(provide draw@) +(define-unit-from-context draw@ draw^) + diff --git a/collects/racket/draw/private/post-script-dc.rkt b/collects/racket/draw/private/post-script-dc.rkt index 287466a7c8..727375eb5a 100644 --- a/collects/racket/draw/private/post-script-dc.rkt +++ b/collects/racket/draw/private/post-script-dc.rkt @@ -14,9 +14,10 @@ "local.ss" "ps-setup.ss") -(provide post-script-dc%) +(provide post-script-dc% + pdf-dc%) -(define dc-backend% +(define (make-dc-backend pdf?) (class default-dc-backend% (init [interactive #t] [parent #f] @@ -35,11 +36,13 @@ [to-file? (eq? (send pss get-mode) 'file)] [get-file (lambda (fn) ((gui-dynamic-require 'put-file) - "Save PostScript As" + (if pdf? + "Save PDF As" + "Save PostScript As") parent (and fn (path-only fn)) (and fn (file-name-from-path fn)) - "ps"))] + (if pdf? "pdf" "ps")))] [fn (if to-file? (if interactive (get-file (send pss get-file)) @@ -54,18 +57,26 @@ [h (caddr paper)] [landscape? (eq? (send pss get-orientation) 'landscape)] [file (open-output-file - (or fn (make-temporary-file "draw~a.ps")) + (or fn (make-temporary-file (if pdf? + "draw~a.pdf" + "draw~a.ps"))) #:exists 'truncate/replace)] [port-box (make-immobile file)]) - (values - (cairo_ps_surface_create_for_stream write_port_bytes - port-box - w - h) - port-box ; needs to be accessible as long as `s' - w - h - landscape?))))] + (let-values ([(w h) (if (and pdf? landscape?) + (values h w) + (values w h))]) + (values + ((if pdf? + cairo_pdf_surface_create_for_stream + cairo_ps_surface_create_for_stream) + write_port_bytes + port-box + w + h) + port-box ; needs to be accessible as long as `s' + w + h + landscape?)))))] [else (values #f #f #f #f)]))) @@ -82,10 +93,11 @@ (send (current-ps-setup) get-translation xb yb) (values (unbox xb) (unbox yb)))) - (when (and s as-eps) - (cairo_ps_surface_set_eps s #t)) - (when (and s landscape?) - (cairo_ps_surface_dsc_comment s "%%Orientation: Landscape")) + (unless pdf? + (when (and s as-eps) + (cairo_ps_surface_set_eps s #t)) + (when (and s landscape?) + (cairo_ps_surface_dsc_comment s "%%Orientation: Landscape"))) (define c (and s (cairo_create s))) @@ -98,7 +110,7 @@ (def/override (get-size) (let ([w (exact->inexact (/ (- width margin-x margin-x) scale-x))] [h (exact->inexact (/ (- height margin-y margin-y) scale-y))]) - (if landscape? + (if (and (not pdf?) landscape?) (values h w) (values w h)))) @@ -112,7 +124,7 @@ (define/override (init-cr-matrix c) (cairo_translate c trans-x trans-y) - (if landscape? + (if (and landscape? (not pdf?)) (begin (cairo_translate c 0 height) (cairo_rotate c (/ pi -2)) @@ -138,7 +150,10 @@ (super-new))) -(define post-script-dc% (dc-mixin dc-backend%)) +(define post-script-dc% (class (dc-mixin (make-dc-backend #f)) + (super-new))) +(define pdf-dc% (class (dc-mixin (make-dc-backend #t)) + (super-new))) (define (write-port-bytes port-box bytes len) (write-bytes (scheme_make_sized_byte_string bytes len 0) diff --git a/collects/racket/draw/unsafe/cairo.rkt b/collects/racket/draw/unsafe/cairo.rkt index 78712b5b97..21d8956b08 100644 --- a/collects/racket/draw/unsafe/cairo.rkt +++ b/collects/racket/draw/unsafe/cairo.rkt @@ -201,6 +201,10 @@ ;; allocation. (_fun _fpointer _pointer _double* _double* -> _cairo_surface_t) #:wrap (allocator cairo_surface_destroy)) +(define-cairo cairo_pdf_surface_create_for_stream + ;; As above: + (_fun _fpointer _pointer _double* _double* -> _cairo_surface_t) + #:wrap (allocator cairo_surface_destroy)) (define/provide _cairo_write_func_t (_fun _pointer _pointer _uint -> _int)) (define-cairo cairo_ps_surface_set_eps (_fun _cairo_surface_t _bool -> _void) #:fail (lambda () diff --git a/collects/scribblings/draw/draw-unit.scrbl b/collects/scribblings/draw/draw-unit.scrbl new file mode 100644 index 0000000000..d3eac9b8ba --- /dev/null +++ b/collects/scribblings/draw/draw-unit.scrbl @@ -0,0 +1,26 @@ +#lang scribble/doc +@(require "common.ss" + (for-label racket/draw/draw-unit + racket/draw/draw-sig)) + +@title{Signature and Unit} + +The @racketmodname[racket/draw/draw-sig] and +@racketmodname[racket/draw/draw-unit] libraries define the +@racket[draw^] signature and @racket[draw@] implementation. + +@section{Draw Unit} + +@defmodule[racket/draw/draw-unit] + +@defthing[draw@ unit?]{ +Re-exports all of the exports of @racketmodname[racket/draw].} + + +@section{Draw Signature} + +@defmodule[racket/draw/draw-sig] + +@defsignature[draw^ ()] + +Includes all of the identifiers exported by @racketmodname[racket/draw]. diff --git a/collects/scribblings/draw/pdf-dc-class.scrbl b/collects/scribblings/draw/pdf-dc-class.scrbl new file mode 100644 index 0000000000..5847b8b6d4 --- /dev/null +++ b/collects/scribblings/draw/pdf-dc-class.scrbl @@ -0,0 +1,17 @@ +#lang scribble/doc +@(require "common.ss") + +@defclass/title[pdf-dc% object% (dc<%>)]{ + +Like @racket[post-script-dc%], but generates a PDF file instead of a + PostScript file. + +@defconstructor[([interactive any/c #t] + [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) false/c) #f] + [use-paper-bbox any/c #f] + [as-eps any/c #t])]{ + +See @racket[post-script-dc%] for information on the arguments. The +@racket[as-eps] argument is allowed for consistency with +@racket[post-script-dc%], but its value is ignored.}} + diff --git a/collects/scribblings/draw/pen-class.scrbl b/collects/scribblings/draw/pen-class.scrbl index 2f66d20cde..7ca9b0a576 100644 --- a/collects/scribblings/draw/pen-class.scrbl +++ b/collects/scribblings/draw/pen-class.scrbl @@ -95,17 +95,21 @@ A pen of size @scheme[0] uses the minimum line size for the [style (one-of/c 'transparent 'solid 'xor 'hilite 'dot 'long-dash 'short-dash 'dot-dash 'xor-dot 'xor-long-dash 'xor-short-dash - 'xor-dot-dash)]) + 'xor-dot-dash)] + [cap-style (one-of/c 'round 'projecting 'butt)] + [join-style (one-of/c 'round 'bevel 'miter)]) ([color-name string?] [width (real-in 0 255)] [style (one-of/c 'transparent 'solid 'xor 'dot 'hilite 'long-dash 'short-dash 'dot-dash 'xor-dot 'xor-long-dash 'xor-short-dash - 'xor-dot-dash)]))]{ + 'xor-dot-dash)] + [cap-style (one-of/c 'round 'projecting 'butt)] + [join-style (one-of/c 'round 'bevel 'miter)]))]{ When no argument are provided, the result is a solid black pen of width @scheme[0]. Otherwise, the result is a pen with the given - color, width, and style. For the case that the color is specified + color, width, style, cap style, and join style. For the case that the color is specified using a name, see @scheme[color-database<%>] for information about color names; if the name is not known, the pen's color is black. diff --git a/collects/scribblings/draw/post-script-dc-class.scrbl b/collects/scribblings/draw/post-script-dc-class.scrbl index b27b99beb8..8767e7e0c7 100644 --- a/collects/scribblings/draw/post-script-dc-class.scrbl +++ b/collects/scribblings/draw/post-script-dc-class.scrbl @@ -5,7 +5,7 @@ A @scheme[post-script-dc%] object is a PostScript device context, that can write PostScript files on any platform. See also - @scheme[ps-setup%]. + @scheme[ps-setup%] and @racket[pdf-dc%]. @|PrintNote| diff --git a/collects/scribblings/draw/reference.scrbl b/collects/scribblings/draw/reference.scrbl index f652399ddc..e8e05d6811 100644 --- a/collects/scribblings/draw/reference.scrbl +++ b/collects/scribblings/draw/reference.scrbl @@ -18,6 +18,7 @@ @include-section["font-name-directory-intf.scrbl"] @include-section["gl-config-class.scrbl"] @include-section["gl-context-intf.scrbl"] +@include-section["pdf-dc-class.scrbl"] @include-section["pen-class.scrbl"] @include-section["pen-list-class.scrbl"] @include-section["point-class.scrbl"] @@ -25,3 +26,4 @@ @include-section["ps-setup-class.scrbl"] @include-section["region-class.scrbl"] @include-section["draw-funcs.scrbl"] +@include-section["draw-unit.scrbl"] diff --git a/collects/slideshow/cmdline.rkt b/collects/slideshow/cmdline.rkt index d6b935cada..fe6a77d54e 100644 --- a/collects/slideshow/cmdline.rkt +++ b/collects/slideshow/cmdline.rkt @@ -26,8 +26,7 @@ (define-values (use-screen-w use-screen-h) (values actual-screen-w actual-screen-h)) (define condense? #f) - (define printing? #f) - (define native-printing? #f) + (define printing-mode #f) (define commentary? #f) (define commentary-on-slide? #f) (define show-gauge? #f) @@ -60,12 +59,13 @@ [once-each (("-d" "--preview") "show next-slide preview (useful on a non-mirroring display)" (set! two-frames? #t)) - (("-p" "--print") "print (always to PostScript, except under Windows and Mac OS)" - (set! printing? #t) - (set! native-printing? #t)) + (("-p" "--print") "print" + (set! printing-mode 'print)) (("-P" "--ps") "print to PostScript" - (set! printing? #t)) - (("-o") file "set output file for PostScript printing" + (set! printing-mode 'ps)) + (("-D" "--pdf") "print to PDF" + (set! printing-mode 'pdf)) + (("-o") file "set output file for PostScript or PDF printing" (set! print-target file)) (("-c" "--condense") "condense" (set! condense? #t)) @@ -138,40 +138,50 @@ (length slide-module-file) slide-module-file)])])) - (when (or printing? condense?) + (define printing? (and printing-mode #t)) + + (when (or printing-mode condense?) (set! use-transitions? #f)) - (when printing? + (when printing-mode (set! use-offscreen? #f) (set! use-prefetch? #f) (set! keep-titlebar? #t)) (dc-for-text-size - (if printing? + (if printing-mode (let ([p (let ([pss (make-object ps-setup%)]) (send pss set-mode 'file) (send pss set-file (if print-target print-target - (if file-to-load - (path-replace-suffix (file-name-from-path file-to-load) - (if quad-view? - "-4u.ps" - ".ps")) - "untitled.ps"))) + (let ([suffix + (if (eq? printing-mode 'pdf) + "pdf" + "ps")]) + (if file-to-load + (path-replace-suffix (file-name-from-path file-to-load) + (format + (if quad-view? + "-4u.~a" + ".~a") + suffix)) + (format "untitled.~a" suffix))))) (send pss set-orientation 'landscape) (parameterize ([current-ps-setup pss]) - (if native-printing? - ;; Make printer-dc% - (begin - (when (can-get-page-setup-from-user?) - (let ([v (get-page-setup-from-user)]) - (if v - (send pss copy-from v) - (exit)))) - (make-object printer-dc% #f)) - ;; Make ps-dc%: - (make-object post-script-dc% (not print-target) #f #t #f))))]) + (case printing-mode + [(print) + ;; Make printer-dc% + (when (can-get-page-setup-from-user?) + (let ([v (get-page-setup-from-user)]) + (if v + (send pss copy-from v) + (exit)))) + (make-object printer-dc% #f)] + [(ps) + (make-object post-script-dc% (not print-target) #f #t #f)] + [(pdf) + (make-object pdf-dc% (not print-target) #f #t #f)])))]) ;; Init page, set "screen" size, etc.: (unless (send p ok?) (exit)) (send p start-doc "Slides") diff --git a/collects/slideshow/core.rkt b/collects/slideshow/core.rkt index c343e583a7..f0b2e5987b 100644 --- a/collects/slideshow/core.rkt +++ b/collects/slideshow/core.rkt @@ -3,7 +3,7 @@ (require scheme/class scheme/unit scheme/file - mred + racket/draw texpict/mrpict texpict/utils scheme/math @@ -1019,7 +1019,7 @@ (+ x-space (* xs w))) (>= (send scroll-bm get-height) (+ y-space (* ys h)))) - (set! scroll-bm (make-screen-bitmap + (set! scroll-bm (make-bitmap (inexact->exact (ceiling (+ x-space (* xs w)))) (inexact->exact (ceiling (+ y-space (* ys h)))))) (if (send scroll-bm ok?) diff --git a/collects/slideshow/pict.rkt b/collects/slideshow/pict.rkt index 5f2994cbde..f307fa62ca 100644 --- a/collects/slideshow/pict.rkt +++ b/collects/slideshow/pict.rkt @@ -7,8 +7,8 @@ [pin-line t:pin-line] [pin-arrow-line t:pin-arrow-line] [pin-arrows-line t:pin-arrows-line]) - (only-in scheme/gui/base dc-path%) - (only-in scheme/class new send)) + (only-in racket/draw dc-path%) + (only-in racket/class new send)) (define (hline w h #:segment [seg #f]) (if seg diff --git a/collects/slideshow/slides-to-picts.rkt b/collects/slideshow/slides-to-picts.rkt index f14e2955d1..f4b1e221a3 100644 --- a/collects/slideshow/slides-to-picts.rkt +++ b/collects/slideshow/slides-to-picts.rkt @@ -1,6 +1,6 @@ (module slides-to-picts scheme/base - (require mred + (require racket/draw scheme/class scheme/unit "sig.ss" @@ -14,7 +14,7 @@ (define get-slides-as-picts (lambda (file w h c? [stop-after #f]) - (let ([ns (make-gui-namespace)] + (let ([ns (make-base-namespace)] [orig-ns (namespace-anchor->empty-namespace anchor)] [slides null] [xs (/ w 1024)] diff --git a/collects/tests/gracket/draw.rkt b/collects/tests/gracket/draw.rkt index 389223493b..882d0cb9a1 100644 --- a/collects/tests/gracket/draw.rkt +++ b/collects/tests/gracket/draw.rkt @@ -263,7 +263,7 @@ [on-paint (case-lambda [() (time (on-paint #f))] - [(ps?) + [(kind) (let* ([can-dc (get-dc)] [pen0s (make-object pen% "BLACK" 0 'solid)] [pen1s (make-object pen% "BLACK" 1 'solid)] @@ -811,7 +811,7 @@ (send dc draw-rectangle 180 205 20 20) (send dc set-brush brushs)))) - (when (and pixel-copy? last? (not (or ps? (eq? dc can-dc)))) + (when (and pixel-copy? last? (not (or kind (eq? dc can-dc)))) (let* ([x 100] [y 170] [x2 245] [y2 188] @@ -941,7 +941,7 @@ (send dc draw-rectangle 187 310 20 20) (send dc set-pen p))) - (when (and last? (not (or ps? (eq? dc can-dc))) + (when (and last? (not (or kind (eq? dc can-dc))) (send mem-dc get-bitmap)) (send can-dc draw-bitmap (send mem-dc get-bitmap) 0 0 'opaque))) @@ -950,10 +950,11 @@ (send (get-dc) set-scale 1 1) (send (get-dc) set-origin 0 0) - (let ([dc (if ps? - (let ([dc (if (eq? ps? 'print) - (make-object printer-dc%) - (make-object post-script-dc%))]) + (let ([dc (if kind + (let ([dc (case kind + [(print) (make-object printer-dc%)] + [(ps) (make-object post-script-dc%)] + [(pdf) (make-object pdf-dc%)])]) (and (send dc ok?) dc)) (if (and use-bitmap?) (begin @@ -1112,7 +1113,7 @@ (let-values ([(w h) (send dc get-size)]) (unless (cond - [ps? #t] + [kind #t] [use-bad? #t] [use-bitmap? (and (= w (* xscale DRAW-WIDTH)) (= h (* yscale DRAW-HEIGHT)))] [else (and (= w (* 2 DRAW-WIDTH)) (= h (* 2 DRAW-HEIGHT)))]) @@ -1143,10 +1144,10 @@ '(horizontal)) (make-object button% "PS" hp (lambda (self event) - (send canvas on-paint #t))) - (make-object button% "Print" hp + (send canvas on-paint 'ps))) + (make-object button% "PDF" hp (lambda (self event) - (send canvas on-paint 'print))) + (send canvas on-paint 'pdf))) (make-object choice% #f '("1" "*2" "/2" "1,*2" "*2,1") hp (lambda (self event) (send canvas set-scale @@ -1243,6 +1244,7 @@ (send canvas refresh))))]) (set! do-clock clock) (make-object button% "Clip Clock" hp3 (lambda (b e) (clock #t))) + (make-object button% "Print" hp4 (lambda (self event) (send canvas on-paint 'print))) (make-object button% "Print Setup" hp4 (lambda (b e) (let ([c (get-page-setup-from-user)]) (when c (send (current-ps-setup) copy-from c))))) diff --git a/collects/texpict/balloon.rkt b/collects/texpict/balloon.rkt index d099f4b7f3..efbd448328 100644 --- a/collects/texpict/balloon.rkt +++ b/collects/texpict/balloon.rkt @@ -1,7 +1,7 @@ (module balloon mzscheme (require "mrpict.ss" "utils.ss" - mred + racket/draw mzlib/class mzlib/etc mzlib/math) diff --git a/collects/texpict/code.rkt b/collects/texpict/code.rkt index 3db6931c05..43563488bb 100644 --- a/collects/texpict/code.rkt +++ b/collects/texpict/code.rkt @@ -4,7 +4,7 @@ mzlib/class mzlib/list (only scheme/list last) - mred + racket/draw mzlib/unit) (provide define-code code^ code-params^ code@) diff --git a/collects/texpict/doc.txt b/collects/texpict/doc.txt index afc95dbd2c..8d90e46fcf 100644 --- a/collects/texpict/doc.txt +++ b/collects/texpict/doc.txt @@ -67,7 +67,7 @@ GRacket (or PostScript) output The GRacket texpict function set is loaded by the _mrpict.ss_ library. The library is available in unit form via _mrpict-unit.ss_, which -exports a `mrpict@' unit that imports mred^ and exports +exports a `mrpict@' unit that imports draw^ and exports `texpict-common^' and `mrpict-extra^'. The _mrpict-sig.ss_ library file provides both signatures. diff --git a/collects/texpict/face.rkt b/collects/texpict/face.rkt index 328c2d3cbb..cad9bc968a 100644 --- a/collects/texpict/face.rkt +++ b/collects/texpict/face.rkt @@ -1,5 +1,5 @@ (module face mzscheme - (require mred + (require racket/draw texpict/mrpict texpict/utils mzlib/class diff --git a/collects/texpict/flash.rkt b/collects/texpict/flash.rkt index d86771d678..b58330f7b6 100644 --- a/collects/texpict/flash.rkt +++ b/collects/texpict/flash.rkt @@ -3,7 +3,7 @@ (require "mrpict.ss" mzlib/math mzlib/etc - mred + racket/draw mzlib/class) (provide filled-flash diff --git a/collects/texpict/mrpict-unit.rkt b/collects/texpict/mrpict-unit.rkt index 076bcebeda..135e832706 100644 --- a/collects/texpict/mrpict-unit.rkt +++ b/collects/texpict/mrpict-unit.rkt @@ -2,7 +2,7 @@ (module mrpict-unit mzscheme (require mzlib/unit) - (require mred/mred-sig) + (require racket/draw/draw-sig) (require "private/mrpict-sig.ss" "private/common-sig.ss" @@ -11,6 +11,6 @@ (provide mrpict@) (define-compound-unit/infer mrpict@ - (import mred^) + (import draw^) (export texpict-common^ mrpict-extra^) (link common@ mrpict-extra@))) diff --git a/collects/texpict/mrpict.rkt b/collects/texpict/mrpict.rkt index 6554bb087f..e39bcd73b1 100644 --- a/collects/texpict/mrpict.rkt +++ b/collects/texpict/mrpict.rkt @@ -3,10 +3,10 @@ (require mzlib/unit mzlib/contract mzlib/class - mred) + racket/draw) - (require mred/mred-sig - mred/mred-unit) + (require racket/draw/draw-sig + racket/draw/draw-unit) (require "private/mrpict-sig.ss" "private/common-sig.ss") (require "mrpict-sig.ss" @@ -15,7 +15,7 @@ (define-compound-unit/infer mrpict+mred@ (import) (export texpict-common^ mrpict-extra^) - (link standard-mred@ mrpict@)) + (link draw@ mrpict@)) (define-values/invoke-unit/infer mrpict+mred@) diff --git a/collects/texpict/private/common-unit.rkt b/collects/texpict/private/common-unit.rkt index ddaa775245..bb764d09c6 100644 --- a/collects/texpict/private/common-unit.rkt +++ b/collects/texpict/private/common-unit.rkt @@ -1,6 +1,6 @@ #lang racket/unit - (require racket/gui/base + (require racket/draw racket/class racket/list) diff --git a/collects/texpict/private/mrpict-extra.rkt b/collects/texpict/private/mrpict-extra.rkt index c5195d0593..4e6fd12930 100644 --- a/collects/texpict/private/mrpict-extra.rkt +++ b/collects/texpict/private/mrpict-extra.rkt @@ -4,12 +4,13 @@ (require mzlib/class mzlib/etc) - (require mred/mred-sig) + (require racket/draw/draw-sig + racket/gui/dynamic) (require "mrpict-sig.ss" "common-sig.ss") - (import mred^ + (import draw^ texpict-common^ texpict-internal^) (export mrpict-extra^ @@ -21,7 +22,7 @@ (define pict-drawer (make-pict-drawer the-pict)) (define no-redraw? #f) (define pict-frame% - (class frame% + (class (gui-dynamic-require 'frame%) (define/public (set-pict p) (set! the-pict p) (set! pict-drawer (make-pict-drawer the-pict)) @@ -34,7 +35,7 @@ (send c on-paint)) (super-instantiate ()))) (define pict-canvas% - (class canvas% + (class (gui-dynamic-require 'canvas%) (inherit get-dc) (define/override (on-paint) (unless no-redraw? diff --git a/collects/texpict/utils.rkt b/collects/texpict/utils.rkt index 506549ef46..4fedf0d5f9 100644 --- a/collects/texpict/utils.rkt +++ b/collects/texpict/utils.rkt @@ -1,6 +1,11 @@ -#lang scheme/gui +#lang racket/base - (require "mrpict.ss") + (require racket/contract + racket/class + racket/draw + racket/math + racket/gui/dynamic + "mrpict.ss") ;; Utilities for use with mrpict @@ -886,8 +891,10 @@ (let ([bm (cond [(bitmap-draft-mode) #f] [(filename . is-a? . bitmap%) filename] - [(filename . is-a? . image-snip%) (send filename get-bitmap)] - [else (make-object bitmap% filename 'unknown/mask)])]) + [(path-string? filename) (make-object bitmap% filename 'unknown/mask)] + [(and (gui-available?) + (filename . is-a? . (gui-dynamic-require 'image-snip%))) + (send filename get-bitmap)])]) (if (and bm (send bm ok?)) (let ([w (send bm get-width)] [h (send bm get-height)]) diff --git a/doc/release-notes/racket/Draw_and_GUI_5_1.txt b/doc/release-notes/racket/Draw_and_GUI_5_1.txt index 36c1d1ef75..4c1688c8d3 100644 --- a/doc/release-notes/racket/Draw_and_GUI_5_1.txt +++ b/doc/release-notes/racket/Draw_and_GUI_5_1.txt @@ -112,6 +112,9 @@ that it is installed as a clipping region. The old 'xor mode for pens and brushes is no longer available (since it is not supported by Cairo). +The new `pdf-dc%' drawing context is like `post-script-dc%', but it +generates PDF output. + Editor Changes -------------- From bd0ca0bcece3b996afdbc59b6ef5827fcfee9e5b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 26 Nov 2010 10:53:45 -0700 Subject: [PATCH 130/255] add file/convertible --- collects/file/convertible.rkt | 13 ++++++ collects/file/scribblings/convertible.scrbl | 52 +++++++++++++++++++++ collects/file/scribblings/file.scrbl | 1 + 3 files changed, 66 insertions(+) create mode 100644 collects/file/convertible.rkt create mode 100644 collects/file/scribblings/convertible.scrbl diff --git a/collects/file/convertible.rkt b/collects/file/convertible.rkt new file mode 100644 index 0000000000..6af83fb1d5 --- /dev/null +++ b/collects/file/convertible.rkt @@ -0,0 +1,13 @@ +#lang racket/base + +(provide prop:convertible convertible? convert) + +(define-values (prop:convertible convertible? convertible-ref) + (make-struct-type-property 'convertible)) + +(define (convert v target [default #f]) + (unless (convertible? v) + (raise-type-error 'convert "convertible" 0 v target)) + (unless (symbol? target) + (raise-type-error 'convert "symbol" 1 v target)) + ((convertible-ref v) v target default)) diff --git a/collects/file/scribblings/convertible.scrbl b/collects/file/scribblings/convertible.scrbl new file mode 100644 index 0000000000..7f73554127 --- /dev/null +++ b/collects/file/scribblings/convertible.scrbl @@ -0,0 +1,52 @@ +#lang scribble/doc +@(require scribble/manual + (for-label file/convertible)) + +@title[#:tag "convertible"]{Convertible: Data-Conversion Protocol} + +@defmodule[file/convertible] + +The @schememodname[file/convertible] library provides a protocol to +mediate between providers of data in different possible formats and +consumers of the formats. For example, a datatype that implements +@racket[prop:convertible] might be able to convert itself to a GIF or +PDF stream, in which case it would produce data for +@racket['gif-bytes] or @racket['pdf-bytes] requests. + +Any symbol can be used for a conversion request, but the following +should be considered standard: + +@itemlist[ + #:style 'compact + + @item{@scheme['text] --- a string for human-readable text} + @item{@scheme['gif-bytes] --- a byte string containing a GIF image encoding} + @item{@scheme['png-bytes] --- a byte string containing a PNG image encoding} + @item{@scheme['ps-bytes] --- a byte string containing a PostScript document} + @item{@scheme['pdf-bytes] --- a byte string containing a PDF document} +] + +@defthing[prop:convertible struct-type-property?]{ + +A property whose value should be a procedure of three arguments. The +procedure is called when a structure with the property is passed to +@racket[convert]; the first argument to the procedure is the +structure, the second argument is a symbol for the requested +conversion, and the third argument is a value to return (typically +@racket[#f] if the conversion is not supported. The procedure's result +depends on the requested conversion.} + +@defproc[(convertible? [v any/c]) boolean?]{ + +Returns @racket[#t] if @racket[v] supports the conversion protocol, +@racket[#f] otherwise.} + +@defproc[(convert [v convertible?] [request symbol?] [default any/c #f]) + any]{ + + +Requests a data conversion from @racket[v], where @racket[request] +indicates the type of requested data and @racket[default] is the value +that the converter should return if it cannot produce data in the +format indicated by @racket[request].} + diff --git a/collects/file/scribblings/file.scrbl b/collects/file/scribblings/file.scrbl index be439ecf01..e9ccc91601 100644 --- a/collects/file/scribblings/file.scrbl +++ b/collects/file/scribblings/file.scrbl @@ -5,6 +5,7 @@ @table-of-contents[] +@include-section["convertible.scrbl"] @include-section["gzip.scrbl"] @include-section["gunzip.scrbl"] @include-section["zip.scrbl"] From 5aff70029abb6bd804c156b412f1a2ab70ebfa23 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 26 Nov 2010 11:20:15 -0700 Subject: [PATCH 131/255] centralize glib loading as used by racket/draw and Gtk racket/gui --- collects/mred/private/wx/gtk/utils.rkt | 29 +++---------------------- collects/racket/draw/unsafe/glib.rkt | 30 ++++++++++++++++++++++++++ collects/racket/draw/unsafe/pango.rkt | 25 +++------------------ src/racket/include/mzwin.def | 1 + src/racket/include/mzwin3m.def | 1 + src/racket/include/racket.exp | 1 + src/racket/include/racket3m.exp | 1 + src/racket/src/error.c | 5 +++++ src/racket/src/schemef.h | 1 + src/racket/src/schemex.h | 1 + src/racket/src/schemex.inc | 1 + src/racket/src/schemexm.h | 1 + 12 files changed, 49 insertions(+), 48 deletions(-) create mode 100644 collects/racket/draw/unsafe/glib.rkt diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt index 16d569ef4f..069e4d42ed 100644 --- a/collects/mred/private/wx/gtk/utils.rkt +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -2,16 +2,17 @@ (require ffi/unsafe ffi/unsafe/define ffi/unsafe/alloc + racket/draw/unsafe/glib (only-in '#%foreign ctype-c->scheme) "../common/utils.rkt" "types.rkt") (provide define-mz + define-gobj + define-glib (protect-out define-gtk define-gdk - define-gobj - define-glib define-gdk_pixbuf g_object_ref @@ -56,27 +57,6 @@ (ffi-lib "libgdk_pixbuf-2.0-0") (ffi-lib "libgdk-win32-2.0-0")] [else (ffi-lib "libgdk-x11-2.0" '("0"))])) -(define gobj-lib - (case (system-type) - [(windows) - (ffi-lib "libgobject-2.0-0")] - [(unix) - (ffi-lib "libgobject-2.0" '("0"))] - [else gdk-lib])) -(define glib-lib - (case (system-type) - [(windows) - (ffi-lib "libglib-2.0-0")] - [(unix) - (ffi-lib "libglib-2.0" '("0"))] - [else gdk-lib])) -(define gmodule-lib - (case (system-type) - [(windows) - (ffi-lib "libgmodule-2.0-0")] - [(unix) - (ffi-lib "libgmodule-2.0" '("0"))] - [else gdk-lib])) (define gdk_pixbuf-lib (case (system-type) [(windows) @@ -91,9 +71,6 @@ [else (ffi-lib "libgtk-x11-2.0" '("0"))])) (define-ffi-definer define-gtk gtk-lib) -(define-ffi-definer define-gobj gobj-lib) -(define-ffi-definer define-glib glib-lib) -(define-ffi-definer define-gmodule gmodule-lib) (define-ffi-definer define-gdk gdk-lib) (define-ffi-definer define-gdk_pixbuf gdk_pixbuf-lib) diff --git a/collects/racket/draw/unsafe/glib.rkt b/collects/racket/draw/unsafe/glib.rkt new file mode 100644 index 0000000000..2b3ae40af4 --- /dev/null +++ b/collects/racket/draw/unsafe/glib.rkt @@ -0,0 +1,30 @@ +#lang scheme/base +(require ffi/unsafe + ffi/unsafe/define + "../private/libs.rkt") + +(provide (protect-out + define-glib + define-gmodule + define-gobj)) + +(define-runtime-lib glib-lib + [(unix) (ffi-lib "libglib-2.0" '("0"))] + [(macosx) (ffi-lib "libglib-2.0.0")] + [(windows) (ffi-lib "libglib-2.0-0.dll")]) + +(define-runtime-lib gmodule-lib + [(unix) (ffi-lib "libgmodule-2.0" '("0"))] + [(macosx) + (ffi-lib "libgmodule-2.0.0.dylib")] + [(windows) + (ffi-lib "libgmodule-2.0-0.dll")]) + +(define-runtime-lib gobj-lib + [(unix) (ffi-lib "libgobject-2.0" '("0"))] + [(macosx) (ffi-lib "libgobject-2.0.0")] + [(windows) (ffi-lib "libgobject-2.0-0.dll")]) + +(define-ffi-definer define-glib glib-lib) +(define-ffi-definer define-gmodule gmodule-lib) +(define-ffi-definer define-gobj gobj-lib) diff --git a/collects/racket/draw/unsafe/pango.rkt b/collects/racket/draw/unsafe/pango.rkt index f5e282ca6d..7779deadb9 100644 --- a/collects/racket/draw/unsafe/pango.rkt +++ b/collects/racket/draw/unsafe/pango.rkt @@ -4,6 +4,7 @@ ffi/unsafe/alloc ffi/unsafe/atomic setup/dirs + "glib.rkt" "cairo.rkt" "../private/utils.rkt" "../private/libs.rkt") @@ -11,15 +12,9 @@ (define-runtime-lib pango-lib [(unix) (ffi-lib "libpango-1.0" '("0"))] [(macosx) - (ffi-lib "libglib-2.0.0.dylib") - (ffi-lib "libgmodule-2.0.0.dylib") - (ffi-lib "libgobject-2.0.0.dylib") (ffi-lib "libintl.8.dylib") (ffi-lib "libpango-1.0.0.dylib")] [(windows) - (ffi-lib "libglib-2.0-0.dll") - (ffi-lib "libgmodule-2.0-0.dll") - (ffi-lib "libgobject-2.0-0.dll") (ffi-lib "libpango-1.0-0.dll")]) (define-runtime-lib pangowin32-lib @@ -40,26 +35,12 @@ (ffi-lib "libpangoft2-1.0-0.dll") (ffi-lib "libpangocairo-1.0-0.dll")]) -(define-runtime-lib glib-lib - [(unix) (ffi-lib "libglib-2.0" '("0"))] - [(macosx) (ffi-lib "libglib-2.0.0")] - [(windows) (ffi-lib "libglib-2.0-0.dll")]) - -(define-runtime-lib gobj-lib - [(unix) (ffi-lib "libgobject-2.0" '("0"))] - [(macosx) (ffi-lib "libgobject-2.0.0")] - [(windows) (ffi-lib "libgobject-2.0-0.dll")]) - (define-ffi-definer define-pango pango-lib #:provide provide) (define-ffi-definer define-pangocairo pangocairo-lib #:provide provide) (define-ffi-definer define-pangowin32 pangowin32-lib #:provide provide) -(define-ffi-definer define-glib glib-lib - #:provide provide) -(define-ffi-definer define-gobj gobj-lib - #:provide provide) (define PangoContext (_cpointer 'PangoContext)) (define PangoLayout (_cpointer 'PangoLayout)) @@ -124,7 +105,7 @@ [glyphs _PangoGlyphString-pointer])) (provide (struct-out PangoGlyphItem)) - +(provide g_object_unref g_free) (define-gobj g_object_unref (_fun _pointer -> _void) #:wrap (deallocator)) (define-glib g_free (_fun _pointer -> _void) @@ -230,7 +211,7 @@ -> (begin0 (for/list ([i (in-range len)]) (ptr-ref fams PangoFontFamily i)) - (g_free fams)))) + (free fams)))) (define-pango pango_font_description_free (_fun PangoFontDescription -> _void) #:wrap (deallocator)) diff --git a/src/racket/include/mzwin.def b/src/racket/include/mzwin.def index 52d64b2895..5f2ef7a294 100644 --- a/src/racket/include/mzwin.def +++ b/src/racket/include/mzwin.def @@ -99,6 +99,7 @@ EXPORTS scheme_log scheme_log_message scheme_log_abort + scheme_log_warning scheme_out_of_memory_abort scheme_wrong_count scheme_wrong_count_m diff --git a/src/racket/include/mzwin3m.def b/src/racket/include/mzwin3m.def index 3b31068276..8dffd3241a 100644 --- a/src/racket/include/mzwin3m.def +++ b/src/racket/include/mzwin3m.def @@ -99,6 +99,7 @@ EXPORTS scheme_log scheme_log_message scheme_log_abort + scheme_log_warning scheme_out_of_memory_abort scheme_wrong_count scheme_wrong_count_m diff --git a/src/racket/include/racket.exp b/src/racket/include/racket.exp index 241132e9de..015e172cad 100644 --- a/src/racket/include/racket.exp +++ b/src/racket/include/racket.exp @@ -97,6 +97,7 @@ scheme_log_level_p scheme_log scheme_log_message scheme_log_abort +scheme_log_warning scheme_out_of_memory_abort scheme_wrong_count scheme_wrong_count_m diff --git a/src/racket/include/racket3m.exp b/src/racket/include/racket3m.exp index a5393f4eff..adf0535742 100644 --- a/src/racket/include/racket3m.exp +++ b/src/racket/include/racket3m.exp @@ -97,6 +97,7 @@ scheme_log_level_p scheme_log scheme_log_message scheme_log_abort +scheme_log_warning scheme_out_of_memory_abort scheme_wrong_count scheme_wrong_count_m diff --git a/src/racket/src/error.c b/src/racket/src/error.c index 91a19005de..bd4550b191 100644 --- a/src/racket/src/error.c +++ b/src/racket/src/error.c @@ -2872,6 +2872,11 @@ void scheme_log_abort(char *buffer) scheme_log_message(&logger, SCHEME_LOG_FATAL, buffer, strlen(buffer), scheme_false); } +void scheme_log_warning(char *buffer) +{ + scheme_log_message(scheme_main_logger, SCHEME_LOG_WARNING, buffer, strlen(buffer), scheme_false); +} + static int extract_level(const char *who, int which, int argc, Scheme_Object **argv) { Scheme_Object *v; diff --git a/src/racket/src/schemef.h b/src/racket/src/schemef.h index 4b231f9a15..6d862c26c0 100644 --- a/src/racket/src/schemef.h +++ b/src/racket/src/schemef.h @@ -204,6 +204,7 @@ MZ_EXTERN void scheme_log(Scheme_Logger *logger, int level, int flags, char *msg, ...); MZ_EXTERN void scheme_log_message(Scheme_Logger *logger, int level, char *buffer, long len, Scheme_Object *data); MZ_EXTERN void scheme_log_abort(char *buffer); +MZ_EXTERN void scheme_log_warning(char *buffer); MZ_EXTERN void scheme_out_of_memory_abort(); MZ_EXTERN void scheme_wrong_count(const char *name, int minc, int maxc, diff --git a/src/racket/src/schemex.h b/src/racket/src/schemex.h index 5e2f87caf1..01e41905d4 100644 --- a/src/racket/src/schemex.h +++ b/src/racket/src/schemex.h @@ -161,6 +161,7 @@ void (*scheme_log)(Scheme_Logger *logger, int level, int flags, char *msg, ...); void (*scheme_log_message)(Scheme_Logger *logger, int level, char *buffer, long len, Scheme_Object *data); void (*scheme_log_abort)(char *buffer); +void (*scheme_log_warning)(char *buffer); void (*scheme_out_of_memory_abort)(); void (*scheme_wrong_count)(const char *name, int minc, int maxc, int argc, Scheme_Object **argv); diff --git a/src/racket/src/schemex.inc b/src/racket/src/schemex.inc index e27756dde3..caac19eeaf 100644 --- a/src/racket/src/schemex.inc +++ b/src/racket/src/schemex.inc @@ -105,6 +105,7 @@ scheme_extension_table->scheme_log = scheme_log; scheme_extension_table->scheme_log_message = scheme_log_message; scheme_extension_table->scheme_log_abort = scheme_log_abort; + scheme_extension_table->scheme_log_warning = scheme_log_warning; scheme_extension_table->scheme_out_of_memory_abort = scheme_out_of_memory_abort; scheme_extension_table->scheme_wrong_count = scheme_wrong_count; scheme_extension_table->scheme_wrong_count_m = scheme_wrong_count_m; diff --git a/src/racket/src/schemexm.h b/src/racket/src/schemexm.h index 2db158e7fd..fa082c493f 100644 --- a/src/racket/src/schemexm.h +++ b/src/racket/src/schemexm.h @@ -105,6 +105,7 @@ #define scheme_log (scheme_extension_table->scheme_log) #define scheme_log_message (scheme_extension_table->scheme_log_message) #define scheme_log_abort (scheme_extension_table->scheme_log_abort) +#define scheme_log_warning (scheme_extension_table->scheme_log_warning) #define scheme_out_of_memory_abort (scheme_extension_table->scheme_out_of_memory_abort) #define scheme_wrong_count (scheme_extension_table->scheme_wrong_count) #define scheme_wrong_count_m (scheme_extension_table->scheme_wrong_count_m) From 8ecd179cb5dc96def9c4c92648ee7401b6a8c472 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 26 Nov 2010 11:21:48 -0700 Subject: [PATCH 132/255] fix interactive cancel in post-script-dc% --- collects/racket/draw/private/post-script-dc.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/racket/draw/private/post-script-dc.rkt b/collects/racket/draw/private/post-script-dc.rkt index 727375eb5a..cb2ab554e0 100644 --- a/collects/racket/draw/private/post-script-dc.rkt +++ b/collects/racket/draw/private/post-script-dc.rkt @@ -78,7 +78,7 @@ h landscape?)))))] [else - (values #f #f #f #f)]))) + (values #f #f #f #f #f)]))) (define-values (margin-x margin-y) (let ([xb (box 0)] [yb (box 0.0)]) From f73e8c31e870ac58d325412e83ecb195def902c1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 26 Nov 2010 11:31:38 -0700 Subject: [PATCH 133/255] doc contract fix --- collects/scribblings/draw/bitmap-class.scrbl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/scribblings/draw/bitmap-class.scrbl b/collects/scribblings/draw/bitmap-class.scrbl index 261b1bd3eb..dfccaf6923 100644 --- a/collects/scribblings/draw/bitmap-class.scrbl +++ b/collects/scribblings/draw/bitmap-class.scrbl @@ -221,12 +221,12 @@ Returns @scheme[#t] if the bitmap is usable (created or changed } -@defmethod[(save-file [name path-string?] +@defmethod[(save-file [name (or/c path-string? output-port?)] [kind (one-of/c 'png 'jpeg 'xbm 'xpm 'bmp)] [quality (integer-in 0 100) 75]) boolean?]{ -Saves a bitmap in the named file. +Writes a bitmap to the named file or output stream. The @scheme[kind] argument determined the type of file that is created, one of: From 7cb15899ae205b21dc10896c8e4433210143e23c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 26 Nov 2010 11:47:24 -0700 Subject: [PATCH 134/255] add `output' argument to post-script-dc% and pdf-dc% for a byte string insteda of writing to a file --- .../racket/draw/private/post-script-dc.rkt | 39 ++++++++++++------- .../draw/post-script-dc-class.scrbl | 12 ++++-- 2 files changed, 34 insertions(+), 17 deletions(-) diff --git a/collects/racket/draw/private/post-script-dc.rkt b/collects/racket/draw/private/post-script-dc.rkt index cb2ab554e0..449165002b 100644 --- a/collects/racket/draw/private/post-script-dc.rkt +++ b/collects/racket/draw/private/post-script-dc.rkt @@ -22,9 +22,15 @@ (init [interactive #t] [parent #f] [use-paper-bbox #f] - [as-eps #t]) + [as-eps #t] + [output #f]) - (define-values (s port-box width height landscape?) + (unless (or (not output) + (path-string? output) + (output-port? output)) + (raise-type-error (init-name (if pdf? 'pdf-dc% 'post-script-dc%)) "path string, output port, or #f" output)) + + (define-values (s port-box close-port? width height landscape?) (let ([su (if interactive ((gui-dynamic-require 'get-ps-setup-from-user) #f parent) (current-ps-setup))]) @@ -44,23 +50,26 @@ (and fn (file-name-from-path fn)) (if pdf? "pdf" "ps")))] [fn (if to-file? - (if interactive - (get-file (send pss get-file)) - (let ([fn (send pss get-file)]) - (or fn (get-file #f)))) + (or output + (if interactive + (get-file (send pss get-file)) + (let ([fn (send pss get-file)]) + (or fn (get-file #f))))) #f)]) (if (and to-file? (not fn)) - (values #f #f #f #f #f) + (values #f #f #f #f #f #f) (let* ([paper (assoc (send pss get-paper-name) paper-sizes)] [w (cadr paper)] [h (caddr paper)] [landscape? (eq? (send pss get-orientation) 'landscape)] - [file (open-output-file - (or fn (make-temporary-file (if pdf? - "draw~a.pdf" - "draw~a.ps"))) - #:exists 'truncate/replace)] + [file (if (output-port? fn) + fn + (open-output-file + (or fn (make-temporary-file (if pdf? + "draw~a.pdf" + "draw~a.ps"))) + #:exists 'truncate/replace))] [port-box (make-immobile file)]) (let-values ([(w h) (if (and pdf? landscape?) (values h w) @@ -74,11 +83,12 @@ w h) port-box ; needs to be accessible as long as `s' + (not (output-port? fn)) w h landscape?)))))] [else - (values #f #f #f #f #f)]))) + (values #f #f #f #f #f #f)]))) (define-values (margin-x margin-y) (let ([xb (box 0)] [yb (box 0.0)]) @@ -119,7 +129,8 @@ (cairo_destroy c) (set! c #f) (set! s #f) - (close-output-port (ptr-ref port-box _racket)) + (when close-port? + (close-output-port (ptr-ref port-box _racket))) (set! port-box #f)) (define/override (init-cr-matrix c) diff --git a/collects/scribblings/draw/post-script-dc-class.scrbl b/collects/scribblings/draw/post-script-dc-class.scrbl index 8767e7e0c7..721849ba07 100644 --- a/collects/scribblings/draw/post-script-dc-class.scrbl +++ b/collects/scribblings/draw/post-script-dc-class.scrbl @@ -15,7 +15,8 @@ See also @scheme[printer-dc%]. @defconstructor[([interactive any/c #t] [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) false/c) #f] [use-paper-bbox any/c #f] - [as-eps any/c #t])]{ + [as-eps any/c #t] + [output (or/c path-string? output-port? #f) #f])]{ If @scheme[interactive] is true, the user is given a dialog for setting printing parameters (see @scheme[get-ps-setup-from-user]); @@ -31,8 +32,8 @@ If @scheme[parent] is not @scheme[#f], it is used as the parent window of If @scheme[interactive] is @scheme[#f], then the settings returned by @scheme[current-ps-setup] are used. A file dialog is still presented to the user if the @method[ps-setup% get-file] method returns - @scheme[#f], and the user may hit cancel in that case so that - @method[dc<%> ok?] returns @scheme[#f]. + @scheme[#f] and @racket[output] is @racket[#f], and the user may + hit @onscreen{Cancel} in that case so that @method[dc<%> ok?] returns @scheme[#f]. If @scheme[use-paper-bbox] is @scheme[#f], then the PostScript bounding box for the output is determined by drawing commands issued @@ -49,6 +50,11 @@ If @scheme[use-paper-bbox] is @scheme[#f], then the PostScript PostScript header. Otherwise, the generated PostScript includes a header that identifiers it as EPS. +When @racket[output] is not @racket[#f], then file-mode output is + written to @racket[output]. If @racket[output] is @racket[#f], then + the destination is determined via @racket[current-ps-setup] or by + prompting the user for a pathname. + See also @scheme[ps-setup%] and @scheme[current-ps-setup]. The settings for a particular @scheme[post-script-dc%] object are fixed to the values in the current configuration when the object is created From 1b56d84155c5443cd1d40eceba7bbab128546444 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 26 Nov 2010 11:50:07 -0700 Subject: [PATCH 135/255] have the pict datatype support conversion to PNG, EPS, or PDF bytes --- collects/file/scribblings/convertible.scrbl | 1 + collects/scribblings/slideshow/picts.scrbl | 4 +++ collects/texpict/private/common-sig.rkt | 3 ++- collects/texpict/private/common-unit.rkt | 7 ++++-- collects/texpict/private/mrpict-extra.rkt | 27 +++++++++++++++++++++ collects/texpict/private/texpict-extra.rkt | 2 ++ 6 files changed, 41 insertions(+), 3 deletions(-) diff --git a/collects/file/scribblings/convertible.scrbl b/collects/file/scribblings/convertible.scrbl index 7f73554127..40b9bbf39f 100644 --- a/collects/file/scribblings/convertible.scrbl +++ b/collects/file/scribblings/convertible.scrbl @@ -23,6 +23,7 @@ should be considered standard: @item{@scheme['gif-bytes] --- a byte string containing a GIF image encoding} @item{@scheme['png-bytes] --- a byte string containing a PNG image encoding} @item{@scheme['ps-bytes] --- a byte string containing a PostScript document} + @item{@scheme['eps-bytes] --- a byte string containing an Encapsulated PostScript document} @item{@scheme['pdf-bytes] --- a byte string containing a PDF document} ] diff --git a/collects/scribblings/slideshow/picts.scrbl b/collects/scribblings/slideshow/picts.scrbl index 37b4927a9e..d7add187ca 100644 --- a/collects/scribblings/slideshow/picts.scrbl +++ b/collects/scribblings/slideshow/picts.scrbl @@ -65,6 +65,10 @@ picts. The functions @racket[pict-width], @racket[pict-height], @racket[pict-descent], and @racket[pict-ascent] extract bounding-box information from a pict. +A pict is a convertible datatype through the @racket[file/convertible] +protocol. Supported conversions include @racket['png-bytes], +@racket['eps-bytes], and @racket['pdf-bytes]. + @defstruct[pict ([draw any/c] [width real?] diff --git a/collects/texpict/private/common-sig.rkt b/collects/texpict/private/common-sig.rkt index ac0d1e52b7..ed1029b527 100644 --- a/collects/texpict/private/common-sig.rkt +++ b/collects/texpict/private/common-sig.rkt @@ -123,7 +123,8 @@ (provide texpict-common-setup^) (define-signature texpict-common-setup^ (connect - ~connect)) + ~connect + convert-pict)) (provide texpict-internal^) (define-signature texpict-internal^ diff --git a/collects/texpict/private/common-unit.rkt b/collects/texpict/private/common-unit.rkt index bb764d09c6..66afc4c0ff 100644 --- a/collects/texpict/private/common-unit.rkt +++ b/collects/texpict/private/common-unit.rkt @@ -2,7 +2,8 @@ (require racket/draw racket/class - racket/list) + racket/list + file/convertible) (require "common-sig.ss") @@ -20,7 +21,9 @@ children ; list of child records panbox ; panorama box, computed on demand last) ; a descendent for the bottom-right - #:mutable) + #:mutable + #:property prop:convertible (lambda (v mode default) + (convert-pict v mode default))) (define-struct child (pict dx dy sx sy)) (define-struct bbox (x1 y1 x2 y2 ay dy)) diff --git a/collects/texpict/private/mrpict-extra.rkt b/collects/texpict/private/mrpict-extra.rkt index 4e6fd12930..dad3ec4b66 100644 --- a/collects/texpict/private/mrpict-extra.rkt +++ b/collects/texpict/private/mrpict-extra.rkt @@ -442,3 +442,30 @@ (define (draw-pict p dc dx dy) ((make-pict-drawer p) dc dx dy)) + + + (define (convert-pict p format default) + (case format + [(png-bytes) + (let* ([bm (make-bitmap (max 1 (pict-width p)) (max 1 (pict-height p)))] + [dc (make-object bitmap-dc% bm)]) + (draw-pict p dc 0 0) + (send dc set-bitmap #f) + (let ([s (open-output-bytes)]) + (send bm save-file s 'png) + (get-output-bytes s)))] + [(eps-bytes pdf-bytes) + (let ([s (open-output-bytes)]) + (let ([dc (new (if (eq? format 'eps-bytes) post-script-dc% pdf-dc%) + [interactive #f] + [as-eps #t] + [output s])]) + (send dc start-doc "pict") + (send dc start-page) + (draw-pict p dc 0 0) + (send dc end-page) + (send dc end-doc)) + (get-output-bytes s))] + [else default])) + + diff --git a/collects/texpict/private/texpict-extra.rkt b/collects/texpict/private/texpict-extra.rkt index 30c427e952..1697f89853 100644 --- a/collects/texpict/private/texpict-extra.rkt +++ b/collects/texpict/private/texpict-extra.rkt @@ -466,3 +466,5 @@ [else (error 'pict->string "bad tag: ~s" tag)]))))) (define pict->commands pict->command-list) + + (define (convert-pict p v d) d) From 04a4ad269fb446000bb463e793e6e8e16457499d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 26 Nov 2010 11:55:32 -0700 Subject: [PATCH 136/255] cocoa & gtk: fix set-label with bitmap on message% Closes PR 11462 --- collects/mred/private/mritem.rkt | 10 +++++++--- collects/mred/private/wx/cocoa/message.rkt | 6 +++++- collects/mred/private/wx/gtk/message.rkt | 11 ++++++++++- 3 files changed, 22 insertions(+), 5 deletions(-) diff --git a/collects/mred/private/mritem.rkt b/collects/mred/private/mritem.rkt index 6d2a89f530..0302d72b08 100644 --- a/collects/mred/private/mritem.rkt +++ b/collects/mred/private/mritem.rkt @@ -58,7 +58,7 @@ ;; for keyword use [font no-val]) (rename [super-set-label set-label]) - (private-field [label lbl][callback cb]) + (private-field [label lbl][callback cb] [is-bitmap? (lbl . is-a? . wx:bitmap%)]) (override [get-label (lambda () label)] [get-plain-label (lambda () (and (string? label) (wx:label->plain-label label)))] @@ -69,8 +69,12 @@ (let ([l (if (string? l) (string->immutable-string l) l)]) - (send wx set-label l) - (set! label l))))]) + (when (or (and is-bitmap? + (l . is-a? . wx:bitmap%)) + (and (not is-bitmap?) + (string? l))) + (send wx set-label l) + (set! label l)))))]) (public [hidden-child? (lambda () #f)] ; module-local method [label-checker (lambda () check-label-string/false)] ; module-local method diff --git a/collects/mred/private/wx/cocoa/message.rkt b/collects/mred/private/wx/cocoa/message.rkt index 1a3896ef1f..bd9ef2a085 100644 --- a/collects/mred/private/wx/cocoa/message.rkt +++ b/collects/mred/private/wx/cocoa/message.rkt @@ -94,7 +94,11 @@ [no-show? (memq 'deleted style)]) (define/override (set-label label) - (tellv (get-cocoa) setTitleWithMnemonic: #:type _NSString label)) + (cond + [(string? label) + (tellv (get-cocoa) setTitleWithMnemonic: #:type _NSString label)] + [else + (tellv (get-cocoa) setImage: (bitmap->image label))])) (define/override (gets-focus?) #f) diff --git a/collects/mred/private/wx/gtk/message.rkt b/collects/mred/private/wx/gtk/message.rkt index fd47ac52cd..587f3291a3 100644 --- a/collects/mred/private/wx/gtk/message.rkt +++ b/collects/mred/private/wx/gtk/message.rkt @@ -2,6 +2,7 @@ (require racket/class ffi/unsafe "../../syntax.rkt" + "../../lock.rkt" "item.rkt" "utils.rkt" "types.rkt" @@ -21,6 +22,7 @@ (define-gtk gtk_label_set_text_with_mnemonic (_fun _GtkWidget _string -> _void)) (define-gtk gtk_image_new_from_stock (_fun _string _int -> _GtkWidget)) (define-gtk gtk_misc_set_alignment (_fun _GtkWidget _float _float -> _void)) +(define-gtk gtk_image_set_from_pixbuf (_fun _GtkWidget _GdkPixbuf -> _void)) (define (mnemonic-string s) (if (regexp-match? #rx"&" s) @@ -75,6 +77,13 @@ (set-auto-size) (define/override (set-label s) - (gtk_label_set_text_with_mnemonic (get-gtk) (mnemonic-string s))) + (cond + [(string? s) + (gtk_label_set_text_with_mnemonic (get-gtk) (mnemonic-string s))] + [else + (let ([pixbuf (bitmap->pixbuf s)]) + (atomically + (gtk_image_set_from_pixbuf (get-gtk) pixbuf) + (release-pixbuf pixbuf)))])) (def/public-unimplemented get-font)) From e7e504741e3e760ba5dc5a48d1abaf943c002cc2 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Fri, 12 Nov 2010 11:46:16 -0600 Subject: [PATCH 137/255] Fixes definition of evaluation contexts --- collects/redex/examples/delim-cont/grammar.rkt | 2 +- collects/redex/examples/delim-cont/test.rkt | 10 ++++++++++ 2 files changed, 11 insertions(+), 1 deletion(-) diff --git a/collects/redex/examples/delim-cont/grammar.rkt b/collects/redex/examples/delim-cont/grammar.rkt index bfe5918dc5..671a66e516 100644 --- a/collects/redex/examples/delim-cont/grammar.rkt +++ b/collects/redex/examples/delim-cont/grammar.rkt @@ -43,7 +43,7 @@ (E W (in-hole W (dw x e E e))) ;; Evaluation context without `dw': (W M (wcm w M)) - (M hole (v ... W e ...) (begin W e) (% v W v)) + (M hole (v ... W e ...) (begin W e) (% W e e) (% v e W) (% v W v)) ;; Context ending on a dw boundary: (D hole (in-hole E (dw x e hole e)))) diff --git a/collects/redex/examples/delim-cont/test.rkt b/collects/redex/examples/delim-cont/test.rkt index 7d2bad03f1..14e932336b 100644 --- a/collects/redex/examples/delim-cont/test.rkt +++ b/collects/redex/examples/delim-cont/test.rkt @@ -141,6 +141,16 @@ 0) (λ (x) (+ x 1)))) '(<> () (1 3) 8)) + (test "abort tag eval" + '(<> + () [] + (% (print 1) 2 3)) + '(<> () [1] 2)) + (test "abort handler eval" + '(<> + () [] + (% 1 2 (print 3))) + '(<> () [3] 2)) (test "call/cc 2 levels dw" '(<> () From 11473184269cf0532a774fdac7593afc0a89264e Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Mon, 15 Nov 2010 07:34:05 -0600 Subject: [PATCH 138/255] Fixes bug with `in-hole' generation --- collects/redex/private/rg.rkt | 7 ++++--- collects/redex/tests/rg-test.rkt | 4 ++++ 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/collects/redex/private/rg.rkt b/collects/redex/private/rg.rkt index b4d636f11b..941bec0e0e 100644 --- a/collects/redex/private/rg.rkt +++ b/collects/redex/private/rg.rkt @@ -307,12 +307,13 @@ (let ([ctx (recur context)] [ctm (recur contractum)]) (λ (r s a e h) - (let-values ([(term env) (ctm r s a e h)]) - (ctx r s a env term))))] + (let*-values ([(tctm env) (ctm r s a e h)] + [(tctx env) (ctx r s a env the-hole)]) + (values (plug tctx tctm) env))))] [`(hide-hole ,pattern) (let ([g (recur pattern)]) (λ (r s a e h) - (g r s a e the-hole)))] + (g r s a e the-not-hole)))] [`any (λ (r s a e h) (let*-values ([(lang nt) ((next-any-decision) langc sexpc)] diff --git a/collects/redex/tests/rg-test.rkt b/collects/redex/tests/rg-test.rkt index 3bf80b5506..6983ae4a21 100644 --- a/collects/redex/tests/rg-test.rkt +++ b/collects/redex/tests/rg-test.rkt @@ -412,6 +412,10 @@ #:num (build-list 5 (λ (x) (λ (_) x))))) '(+ (+ 1 2) (+ 0 (+ 3 4)))) + (test (let/ec k + (generate-term lang (side-condition (in-hole C_1 1) (k (term C_1))) 5)) + (term hole)) + (test (generate-term lang (in-hole (in-hole (1 hole) hole) 5) 5) '(1 5)) (test (generate-term lang (hole 4) 5) (term (hole 4))) (test (generate-term/decisions From d0e03bf53aa0b5f5941572ab06de1fb1506468de Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Mon, 15 Nov 2010 14:30:37 -0600 Subject: [PATCH 139/255] Updates context matching with missing % contexts --- collects/redex/examples/delim-cont/meta.rkt | 6 +++- collects/redex/examples/delim-cont/test.rkt | 40 ++++++++++++++++++++- 2 files changed, 44 insertions(+), 2 deletions(-) diff --git a/collects/redex/examples/delim-cont/meta.rkt b/collects/redex/examples/delim-cont/meta.rkt index 01b0424177..8184bf66ec 100644 --- a/collects/redex/examples/delim-cont/meta.rkt +++ b/collects/redex/examples/delim-cont/meta.rkt @@ -63,7 +63,9 @@ [(noPrompt v_1 (begin E_1 e_2)) (noPrompt v_1 E_1)] [(noPrompt v_1 (set! x E_1)) (noPrompt v_1 E_1)] [(noPrompt v_1 (wcm w E_1)) (noPrompt v_1 E_1)] - [(noPrompt v_1 (dw x e_0 E_1 e_1)) (noPrompt v_1 E_1)]) + [(noPrompt v_1 (dw x e_0 E_1 e_1)) (noPrompt v_1 E_1)] + [(noPrompt v_1 (% v_2 e E_1)) (noPrompt v_1 E_1)] + [(noPrompt v_1 (% E_1 e_1 e_2)) (noPrompt v_1 E_1)]) (define-metafunction grammar [(get-marks-core (in-hole hole hole) v e_2) e_2] @@ -72,6 +74,8 @@ [(get-marks-core (v ... E_1 e ...) v_1 e_2) (get-marks E_1 v_1 e_2)] [(get-marks-core (begin E_1 e) v_1 e_2) (get-marks E_1 v_1 e_2)] [(get-marks-core (% v_2 E_1 v_3) v_1 e_2) (get-marks E_1 v_1 e_2)] + [(get-marks-core (% v_2 e_1 E_1) v_1 e_2) (get-marks E_1 v_1 e_2)] + [(get-marks-core (% E_1 e_1 e_3) v_1 e_2) (get-marks E_1 v_1 e_2)] [(get-marks-core (dw x e E_1 e) v_1 e_2) (get-marks E_1 v_1 e_2)]) (define-metafunction grammar diff --git a/collects/redex/examples/delim-cont/test.rkt b/collects/redex/examples/delim-cont/test.rkt index 14e932336b..aebebb9e8b 100644 --- a/collects/redex/examples/delim-cont/test.rkt +++ b/collects/redex/examples/delim-cont/test.rkt @@ -324,7 +324,45 @@ '(<> () [1 2 1 2] - (λ (v) 10)))) + (λ (v) 10))) + (test "prompt enclosing prompt-tag expression" + '(<> () [] + (% 0 + (% (abort 0 1) 2 3) + (λ (x) x))) + '(<> () [] 1)) + (test "prompt enclosing prompt-handler expression" + '(<> () [] + (% 0 + (begin + (% 0 1 (abort 0 2)) + (print 3)) + (λ (x) x))) + '(<> () [] 2)) + (test "prompt-tag position in continuation-marks context" + '(<> () [] + (% 0 + (call/cm + 1 2 + (λ () + (% (abort 0 (current-marks 1 0)) + 3 + 4))) + (λ (x) x))) + '(<> () [] (list 2))) + (test "prompt-handler position in continuation-marks context" + '(<> () [] + (% 0 + (call/cm + 1 2 + (λ () + (call/cm + 1 3 + (% 0 + 4 + (abort 0 (current-marks 1 0)))))) + (λ (x) x))) + '(<> () [] (list 2)))) ;; R6RS dynamic-wind ---------------------------------------- From 48a5c19a4e54f6ff96554e1123689eceee198d4a Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Wed, 17 Nov 2010 10:41:45 -0600 Subject: [PATCH 140/255] Fixes another bug in continuation mark collection --- collects/redex/examples/delim-cont/meta.rkt | 1 + collects/redex/examples/delim-cont/test.rkt | 9 +++++++++ 2 files changed, 10 insertions(+) diff --git a/collects/redex/examples/delim-cont/meta.rkt b/collects/redex/examples/delim-cont/meta.rkt index 8184bf66ec..a0da71b7e4 100644 --- a/collects/redex/examples/delim-cont/meta.rkt +++ b/collects/redex/examples/delim-cont/meta.rkt @@ -72,6 +72,7 @@ [(get-marks-core (wcm (name w_1 ((v_4 v_5) ... (v_1 v_3) (v_6 v_7) ...)) E_1) v_1 e_2) (get-marks E_1 v_1 (cons v_3 e_2))] [(get-marks-core (wcm w_1 E_1) v_1 e_2) (get-marks E_1 v_1 e_2) (side-condition (term (notInDom (v_1 w_1))))] [(get-marks-core (v ... E_1 e ...) v_1 e_2) (get-marks E_1 v_1 e_2)] + [(get-marks-core (if E_1 e_1 e_3) v_1 e_2) (get-marks E_1 v_1 e_2)] [(get-marks-core (begin E_1 e) v_1 e_2) (get-marks E_1 v_1 e_2)] [(get-marks-core (% v_2 E_1 v_3) v_1 e_2) (get-marks E_1 v_1 e_2)] [(get-marks-core (% v_2 e_1 E_1) v_1 e_2) (get-marks E_1 v_1 e_2)] diff --git a/collects/redex/examples/delim-cont/test.rkt b/collects/redex/examples/delim-cont/test.rkt index aebebb9e8b..6b928664fe 100644 --- a/collects/redex/examples/delim-cont/test.rkt +++ b/collects/redex/examples/delim-cont/test.rkt @@ -362,6 +362,15 @@ 4 (abort 0 (current-marks 1 0)))))) (λ (x) x))) + '(<> () [] (list 2))) + (test "if-test position in continuation-marks context" + '(<> () + [] + (% 0 + (call/cm + 1 2 + (λ () (if (abort 0 (current-marks 1 0)) 3 4))) + (λ (x) x))) '(<> () [] (list 2)))) ;; R6RS dynamic-wind ---------------------------------------- From 8e69aa6ac2b111ac42b1a681748a16efd468cb52 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Wed, 17 Nov 2010 10:58:48 -0600 Subject: [PATCH 141/255] Fixes minor bugs in two core reduction rules --- collects/redex/examples/delim-cont/reduce.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/redex/examples/delim-cont/reduce.rkt b/collects/redex/examples/delim-cont/reduce.rkt index 90873e0b53..ad5cf95f45 100644 --- a/collects/redex/examples/delim-cont/reduce.rkt +++ b/collects/redex/examples/delim-cont/reduce.rkt @@ -12,7 +12,7 @@ grammar ;; beta - (~~> ((λ (x_1 ...) e_1) v_1 ...) + (~~> ((λ (x_1 ..._1) e_1) v_1 ..._1) (subst* (x_1 ...) (v_1 ...) e_1) "beta") @@ -25,7 +25,7 @@ "zero?") (~~> (zero? v_1) #f - (side-condition (not (zero? (term v_1)))) + (side-condition (not (equal? 0 (term v_1)))) "non-zero") ;; lists From 6bfbdfd5820220a9321b528013a3c0f15a213fce Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Wed, 17 Nov 2010 21:03:30 -0600 Subject: [PATCH 142/255] Fixes another bug in continuation mark collection --- collects/redex/examples/delim-cont/meta.rkt | 2 +- collects/redex/examples/delim-cont/test.rkt | 12 ++++++++++++ 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/collects/redex/examples/delim-cont/meta.rkt b/collects/redex/examples/delim-cont/meta.rkt index a0da71b7e4..84f947c4d1 100644 --- a/collects/redex/examples/delim-cont/meta.rkt +++ b/collects/redex/examples/delim-cont/meta.rkt @@ -77,7 +77,7 @@ [(get-marks-core (% v_2 E_1 v_3) v_1 e_2) (get-marks E_1 v_1 e_2)] [(get-marks-core (% v_2 e_1 E_1) v_1 e_2) (get-marks E_1 v_1 e_2)] [(get-marks-core (% E_1 e_1 e_3) v_1 e_2) (get-marks E_1 v_1 e_2)] - [(get-marks-core (dw x e E_1 e) v_1 e_2) (get-marks E_1 v_1 e_2)]) + [(get-marks-core (dw x e_1 E_1 e_3) v_1 e_2) (get-marks E_1 v_1 e_2)]) (define-metafunction grammar [(get-marks (if E_1 e e) v_1 e_2) (get-marks E_1 v_1 e_2)] diff --git a/collects/redex/examples/delim-cont/test.rkt b/collects/redex/examples/delim-cont/test.rkt index 6b928664fe..155bc2804d 100644 --- a/collects/redex/examples/delim-cont/test.rkt +++ b/collects/redex/examples/delim-cont/test.rkt @@ -371,6 +371,18 @@ 1 2 (λ () (if (abort 0 (current-marks 1 0)) 3 4))) (λ (x) x))) + '(<> () [] (list 2))) + (test "dw in continuation-marks context" + '(<> () + [] + (% 0 + (call/cm 1 2 + (λ () + (dynamic-wind + (λ () #f) + (λ () (current-marks 1 0)) + (λ () #t)))) + (λ (x) x))) '(<> () [] (list 2)))) ;; R6RS dynamic-wind ---------------------------------------- From abf257418907c640699da123ff84ca49349caf9f Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Sat, 20 Nov 2010 06:22:07 -0600 Subject: [PATCH 143/255] Fixes a bug introduces while updating to newer version of Redex --- collects/redex/examples/delim-cont/meta.rkt | 2 +- collects/redex/examples/delim-cont/test.rkt | 12 +++++++++++- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/collects/redex/examples/delim-cont/meta.rkt b/collects/redex/examples/delim-cont/meta.rkt index 84f947c4d1..fb817fac76 100644 --- a/collects/redex/examples/delim-cont/meta.rkt +++ b/collects/redex/examples/delim-cont/meta.rkt @@ -70,7 +70,7 @@ (define-metafunction grammar [(get-marks-core (in-hole hole hole) v e_2) e_2] [(get-marks-core (wcm (name w_1 ((v_4 v_5) ... (v_1 v_3) (v_6 v_7) ...)) E_1) v_1 e_2) (get-marks E_1 v_1 (cons v_3 e_2))] - [(get-marks-core (wcm w_1 E_1) v_1 e_2) (get-marks E_1 v_1 e_2) (side-condition (term (notInDom (v_1 w_1))))] + [(get-marks-core (wcm w_1 E_1) v_1 e_2) (get-marks E_1 v_1 e_2) (side-condition (term (notInDom v_1 w_1)))] [(get-marks-core (v ... E_1 e ...) v_1 e_2) (get-marks E_1 v_1 e_2)] [(get-marks-core (if E_1 e_1 e_3) v_1 e_2) (get-marks E_1 v_1 e_2)] [(get-marks-core (begin E_1 e) v_1 e_2) (get-marks E_1 v_1 e_2)] diff --git a/collects/redex/examples/delim-cont/test.rkt b/collects/redex/examples/delim-cont/test.rkt index 155bc2804d..d90bdcb2b2 100644 --- a/collects/redex/examples/delim-cont/test.rkt +++ b/collects/redex/examples/delim-cont/test.rkt @@ -383,7 +383,17 @@ (λ () (current-marks 1 0)) (λ () #t)))) (λ (x) x))) - '(<> () [] (list 2)))) + '(<> () [] (list 2))) + (test "wcm without key in continuation-marks context" + '(<> () + [] + (% 0 + (wcm ([1 2]) + ((λ (x) x) + (wcm ([3 4]) + (current-marks 3 0)))) + (λ (x) x))) + '(<> () [] (list 4)))) ;; R6RS dynamic-wind ---------------------------------------- From d927bc117eea9dbdda7261027a413414ffbae117 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Wed, 24 Nov 2010 12:58:07 -0600 Subject: [PATCH 144/255] Fixes the bug with named contexts in a better way --- collects/redex/private/rg.rkt | 174 ++++++++++++++++++------------- collects/redex/tests/rg-test.rkt | 42 +++++++- 2 files changed, 142 insertions(+), 74 deletions(-) diff --git a/collects/redex/private/rg.rkt b/collects/redex/private/rg.rkt index 941bec0e0e..abf9381651 100644 --- a/collects/redex/private/rg.rkt +++ b/collects/redex/private/rg.rkt @@ -155,19 +155,19 @@ (define-values/invoke-unit (generation-decisions) (import) (export decisions^)) - (define (gen-nt lang name cross? retries size attempt in-hole) + (define (gen-nt lang name cross? retries size attempt fillers) (let*-values ([(productions) (hash-ref ((if cross? rg-lang-cross rg-lang-non-cross) lang) name)] - [(term _) + [(terms _) (let ([gen (pick-from-list (if (zero? size) (min-prods name productions ((if cross? base-cases-cross base-cases-non-cross) (rg-lang-base-cases lang))) ((next-non-terminal-decision) productions)))]) - (gen retries (max 0 (sub1 size)) attempt empty-env in-hole))]) - term)) + (gen retries (max 0 (sub1 size)) attempt empty-env fillers))]) + terms)) (define (generate/pred name gen pred init-sz init-att retries) (let ([pre-threshold-incr @@ -184,9 +184,9 @@ [attempt init-att]) (if (zero? remaining) (raise-gen-fail what (format "pattern ~a" name) retries) - (let-values ([(term env) (gen size attempt)]) - (if (pred term env) - (values term env) + (let-values ([(terms env) (gen size attempt)]) + (if (pred (unfilled-term terms) env) + (values terms env) (retry (sub1 remaining) (if (incr-size? remaining) (add1 size) size) (+ attempt @@ -198,9 +198,9 @@ (let* ([none (gensym)] [prior (hash-ref env name none)]) (if (eq? prior none) - (let-values ([(term env) (gen)]) - (values term (hash-set env name term))) - (values prior env)))) + (let-values ([(terms env) (gen)]) + (values terms (hash-set env name (unfilled-term terms)))) + (values (unfilled prior) env)))) (define (generate-sequence gen env vars length) (define (split-environment env) @@ -215,15 +215,18 @@ (hash-set env var (map (λ (seq-env) (hash-ref seq-env var)) seq-envs))) env vars)) (let-values - ([(seq envs) + ([(seqs envs) (let recur ([envs (split-environment env)]) (if (null? envs) - (values null null) + (values (unfilled null) null) (let*-values - ([(term env) (gen (car envs) the-hole)] - [(terms envs) (recur (cdr envs))]) - (values (cons term terms) (cons env envs)))))]) - (values seq (merge-environments envs)))) + ([(hds env) (gen (car envs))] + [(tls envs) (recur (cdr envs))]) + (values (combine cons hds tls) (cons env envs)))))]) + (values seqs (merge-environments envs)))) + + (define ((unfilled-generator/attempts g) r s a e f) + (values (unfilled (g a)) e)) (define (mismatches-satisfied? env) (let ([groups (make-hasheq)]) @@ -248,6 +251,17 @@ (cons (make-bind (binder-name key) val) bindings) bindings)))) + (define (combine f ts us) + (match* (ts us) + [((list t) _) + (map (λ (u) (f t u)) us)] + [(_ (list u)) + (map (λ (t) (f t u)) ts)] + [(_ _) (map f ts us)])) + + (define unfilled-term first) + (define unfilled list) + (let*-values ([(langp lits lang-bases) (prepare-lang lang)] [(sexpp _ sexp-bases) (prepare-lang sexp)] [(lit-syms) (compiled-lang-literals lang)]) @@ -256,115 +270,129 @@ (λ (pat any?) (let* ([nt? (is-nt? (if any? sexpp langp))] [mismatches? #f] - [generator ; retries size attempt env in-hole -> (values term env) + [generator + ; retries size attempt env hole-fillers -> (values terms env) + ; hole-fillers = (non-empty-listof term) + ; terms = (non-empty-listof term) + ; + ; Patterns like (in-hole C_1 p) require constructing both an unfilled context + ; (exposed via the C_1 binding) and a filled context (exposed as the result). + ; These terms can be constructed by fist generating the unfilled context then + ; constructing the filled one from it, via something like `plug', but + ; 1. the repeated plugging required for patterns like + ; (in-hole (in-hole (in-hole C_1 C_2) C_3) C_4) + ; can be expensive (since it grows with the size of the output, not the + ; size of the pattern), and + ; 2. care must be taken to avoid filling holes generated within `in-hole' patterns + ; (and to avoid exposing the dreaded `the-not-hole'). + ; Instead, generators construct the filled and unfilled contexts simultaneously, + ; taking multiple fillers as input (one of which can be `hole') and producing + ; multiple terms as output. As an optimization, generators produce singleton + ; lists when the constructed term contained no fillable position. (let recur ([pat pat]) (match pat - [`number (λ (r s a e h) (values ((next-number-decision) a) e))] - [`natural (λ (r s a e h) (values ((next-natural-decision) a) e))] - [`integer (λ (r s a e h) (values ((next-integer-decision) a) e))] - [`real (λ (r s a e h) (values ((next-real-decision) a) e))] + [`number (unfilled-generator/attempts (λ (a) ((next-number-decision) a)))] + [`natural (unfilled-generator/attempts (λ (a) ((next-natural-decision) a)))] + [`integer (unfilled-generator/attempts (λ (a) ((next-integer-decision) a)))] + [`real (unfilled-generator/attempts (λ (a) ((next-real-decision) a)))] [`(variable-except ,vars ...) (let ([g (recur 'variable)]) - (λ (r s a e h) + (λ (r s a e f) (generate/pred pat - (λ (s a) (g r s a e h)) + (λ (s a) (g r s a e f)) (λ (var _) (not (memq var vars))) s a r)))] - [`variable - (λ (r s a e h) - (values ((next-variable-decision) lits a) e))] + [`variable (unfilled-generator/attempts (λ (a) ((next-variable-decision) lits a)))] [`variable-not-otherwise-mentioned (let ([g (recur 'variable)]) - (λ (r s a e h) + (λ (r s a e f) (generate/pred pat - (λ (s a) (g r s a e h)) + (λ (s a) (g r s a e f)) (λ (var _) (not (memq var lit-syms))) s a r)))] [`(variable-prefix ,prefix) (define (symbol-append prefix suffix) (string->symbol (string-append (symbol->string prefix) (symbol->string suffix)))) (let ([g (recur 'variable)]) - (λ (r s a e h) - (let-values ([(term _) (g r s a e h)]) - (values (symbol-append prefix term) e))))] - [`string - (λ (r s a e h) - (values ((next-string-decision) lits a) e))] + (λ (r s a e f) + (let-values ([(ts e) (g r s a e f)]) + (values (unfilled (symbol-append prefix (unfilled-term ts))) e))))] + [`string (unfilled-generator/attempts (λ (a) ((next-string-decision) lits a)))] [`(side-condition ,pat ,(? procedure? condition) ,guard-src-loc) (let ([g (recur pat)]) - (λ (r s a e h) + (λ (r s a e f) (generate/pred `(side-condition ,(unparse-pattern pat) ,guard-src-loc) - (λ (s a) (g r s a e h)) + (λ (s a) (g r s a e f)) (λ (_ env) (condition (bindings env))) s a r)))] [`(name ,(? symbol? id) ,p) (let ([g (recur p)]) - (λ (r s a e h) - (let-values ([(term env) (g r s a e h)]) - (values term (hash-set env (make-binder id) term)))))] - [`hole (λ (r s a e h) (values h e))] - [`(in-hole ,context ,contractum) - (let ([ctx (recur context)] - [ctm (recur contractum)]) - (λ (r s a e h) - (let*-values ([(tctm env) (ctm r s a e h)] - [(tctx env) (ctx r s a env the-hole)]) - (values (plug tctx tctm) env))))] + (λ (r s a e f) + (let-values ([(ts env) (g r s a e f)]) + (values ts (hash-set env (make-binder id) (unfilled-term ts))))))] + [`hole (λ (r s a e f) (values f e))] + [`(in-hole ,context ,filler) + (let ([c-context (recur context)] + [c-filler (recur filler)]) + (λ (r s a e f) + (let*-values ([(fillers env) (c-filler r s a e f)] + [(filled env) (c-context r s a env (cons the-hole fillers))]) + (values (if (empty? (rest filled)) filled (rest filled)) env))))] [`(hide-hole ,pattern) (let ([g (recur pattern)]) - (λ (r s a e h) - (g r s a e the-not-hole)))] + (λ (r s a e f) + (g r s a e (list the-hole))))] [`any - (λ (r s a e h) + (λ (r s a e f) (let*-values ([(lang nt) ((next-any-decision) langc sexpc)] - [(term) (gen-nt lang nt #f r s a the-hole)]) + [(term) (gen-nt lang nt #f r s a (list the-hole))]) (values term e)))] [(or (? symbol? (? nt? p)) `(cross ,(? symbol? p))) (let ([cross? (not (symbol? pat))]) - (λ (r s a e h) - (values (gen-nt (if any? sexpc langc) p cross? r s a h) e)))] + (λ (r s a e f) + (values (gen-nt (if any? sexpc langc) p cross? r s a f) e)))] [(struct binder ((or (app (symbol-match named-nt-rx) (? symbol? p)) p))) (let ([g (recur p)]) - (λ (r s a e h) - (generate/prior pat e (λ () (g r s a e h)))))] + (λ (r s a e f) + (generate/prior pat e (λ () (g r s a e f)))))] [(struct mismatch (_ (app (symbol-match mismatch-nt-rx) p))) (let ([g (recur p)]) (set! mismatches? #t) - (λ (r s a e h) - (let-values ([(term _) (g r s a e h)]) - (values term (hash-set e pat term)))))] + (λ (r s a e f) + (let-values ([(ts e) (g r s a e f)]) + (values ts (hash-set e pat (unfilled-term ts))))))] [(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) - (λ (r s a e h) (values pat e))] + (λ (r s a e f) (values (unfilled pat) e))] [(list-rest (struct ellipsis (name sub-pat class vars)) rest) (let ([elemg (recur sub-pat)] [tailg (recur rest)]) (when (mismatch? name) (set! mismatches? #t)) - (λ (r s a e h) + (λ (r s a e f) (let*-values ([(len) (let ([prior (hash-ref e class #f)]) (if prior prior (if (zero? s) 0 ((next-sequence-decision) a))))] - [(seq env) - (generate-sequence (λ (e h) (elemg r s a e h)) e vars len)] - [(tail env) + [(seqs env) + (generate-sequence (λ (e) (elemg r s a e f)) e vars len)] + [(tails env) (let ([e (hash-set (hash-set env class len) name len)]) - (tailg r s a e h))]) - (values (append seq tail) env))))] + (tailg r s a e f))]) + (values (combine append seqs tails) env))))] [(list-rest hdp tlp) (let ([hdg (recur hdp)] [tlg (recur tlp)]) - (λ (r s a e h) + (λ (r s a e f) (let*-values - ([(hd env) (hdg r s a e h)] - [(tl env) (tlg r s a env h)]) - (values (cons hd tl) env))))] + ([(hds env) (hdg r s a e f)] + [(tls env) (tlg r s a env f)]) + (values (combine cons hds tls) env))))] [else (error what "unknown pattern ~s\n" pat)]))]) (if mismatches? - (λ (r s a e h) - (let ([g (λ (s a) (generator r s a e h))] + (λ (r s a e f) + (let ([g (λ (s a) (generator r s a e f))] [p? (λ (_ e) (mismatches-satisfied? e))]) (generate/pred (unparse-pattern pat) g p? s a r))) generator)))] @@ -389,8 +417,8 @@ (λ (pat) (let ([g (compile-pattern (reassign-classes (parse-pattern pat lang 'top-level)))]) (λ (size attempt retries) - (let-values ([(term env) (g retries size attempt empty-env the-hole)]) - (values term (bindings env))))))))) + (let-values ([(ts e) (g retries size attempt empty-env (list the-hole))]) + (values (unfilled-term ts) (bindings e))))))))) (define-struct base-cases (cross non-cross)) diff --git a/collects/redex/tests/rg-test.rkt b/collects/redex/tests/rg-test.rkt index 6983ae4a21..9b640835bc 100644 --- a/collects/redex/tests/rg-test.rkt +++ b/collects/redex/tests/rg-test.rkt @@ -433,6 +433,45 @@ (test (generate-term/decisions lang h 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 3)))) '((2 ((3 (2 1)) 3)) 1))) +(let () + (define-language L + (C (c hole)) + (D (d hole)) + (E (e hole)) + (F (f hole))) + + (test (generate-term L (in-hole 3 4) 5) 3) + (test (generate-term L (in-hole (hole hole) 4) 5) '(4 4)) + (test (generate-term/decisions L (in-hole (hole ... hole) 4) 5 0 (decisions #:seq (list (λ (_) 1)))) + '(4 4)) + + (let-syntax ([test-sequence-holes + (λ (stx) + (syntax-case stx () + [(_ l) + #`(let ([length l] + [bindings #f]) + (test (generate-term/decisions + L + (side-condition (in-hole ((name x (q C)) (... ...)) 4) + (set! bindings (term ((x C) (... ...))))) + 5 0 (decisions #:seq (list (λ (_) length)))) + #,(syntax/loc stx (build-list length (λ (_) '(q (c 4)))))) + (test bindings + #,(syntax/loc stx (build-list length (λ (_) (term ((q (c hole)) (c hole))))))))]))]) + (test-sequence-holes 3) + (test-sequence-holes 0)) + + (let ([bindings #f]) + (test (generate-term + L + (side-condition (name CDEF (in-hole (name CDE (in-hole (name CD (in-hole C D)) E)) F)) + (set! bindings (term (C D E F CD CDE CDEF)))) + 0) + (term (c (d (e (f hole)))))) + (test bindings (term ((c hole) (d hole) (e hole) (f hole) + (c (d hole)) (c (d (e hole))) (c (d (e (f hole))))))))) + (let () (define-language lc (e (e e) (+ e e) x v) @@ -473,7 +512,8 @@ (let () (define-language lang (e (hide-hole (in-hole ((hide-hole hole) hole) 1)))) - (test (generate-term lang e 5) (term (hole 1)))) + (test (generate-term lang e 5) (term (hole 1))) + (test (plug (generate-term lang (hide-hole hole) 0) 3) 3)) (define (output-error-port thunk) (let ([port (open-output-string)]) From b616ac3cd45141d05f6250723185efa2ed066cc4 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Thu, 25 Nov 2010 13:44:06 -0600 Subject: [PATCH 145/255] Fixes substitution bugs --- collects/redex/examples/delim-cont/meta.rkt | 2 +- collects/redex/examples/delim-cont/test.rkt | 19 +++++++++++++++++-- 2 files changed, 18 insertions(+), 3 deletions(-) diff --git a/collects/redex/examples/delim-cont/meta.rkt b/collects/redex/examples/delim-cont/meta.rkt index fb817fac76..569c2ef592 100644 --- a/collects/redex/examples/delim-cont/meta.rkt +++ b/collects/redex/examples/delim-cont/meta.rkt @@ -14,7 +14,7 @@ [(subst x_1 x_2 (λ (x_3 ...) e_1)) ; shortcut; x_1 != any x_3 (λ (x_3 ...) (subst x_1 x_2 e_1))] [(subst x_1 e_1 (λ (x_2 ...) e_2)) ; x_1 != any x_2 - ,(term-let ([(x_new ...) (variables-not-in (term e_1) (term (x_2 ...)))]) + ,(term-let ([(x_new ...) (variables-not-in (term (x_1 e_1 e_2)) (term (x_2 ...)))]) (term (λ (x_new ...) (subst x_1 e_1 (subst* (x_2 ...) (x_new ...) e_2)))))] [(subst x_1 e_1 x_1) e_1] diff --git a/collects/redex/examples/delim-cont/test.rkt b/collects/redex/examples/delim-cont/test.rkt index d90bdcb2b2..6463f314a1 100644 --- a/collects/redex/examples/delim-cont/test.rkt +++ b/collects/redex/examples/delim-cont/test.rkt @@ -35,6 +35,21 @@ ;; Basic ---------------------------------------- (define (basic-tests) + (test "(λx.e)[y←v] ≠ λy.(e[x←y][y←v])" + '(<> + ([k 4]) [] + (((λ (k1) (λ (k) k)) + (λ () k)) + 0)) + '(<> ([k 4]) [] 0)) + (test "(λx.e)[y←v] ≠ λz.(e[x←z][y←v]) if z ∈ FV(e)" + '(<> + ([k2 5]) + () + (((λ (k1) (λ (k) k2)) + (λ () k)) + 0)) + '(<> ([k2 5]) [] 5)) (test "basic dw" '(<> () [] @@ -995,7 +1010,7 @@ (λ (x) x))))) hole)) 100) - (λ (x) x))))) + (λ (x1) x1))))) (test "similar way to get stuck, but using the pre thunk" '(<> ([output (list)] @@ -1059,7 +1074,7 @@ hole)) 100) 0) - (λ (x) x))))) + (λ (x1) x1))))) (test "loop" '(<> ([counter (list 4 3 2 1 0)]) From 8ff358b5592ce1a39ed057d8e10a0990e6d70a34 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Fri, 26 Nov 2010 10:34:28 -0600 Subject: [PATCH 146/255] Abstracts randomized testing forms over the underlying PRG --- collects/redex/private/rg.rkt | 44 +++++++++++++++----------- collects/redex/redex.scrbl | 7 +++- collects/redex/reduction-semantics.rkt | 3 +- collects/redex/tests/rg-test.rkt | 18 +++++++++++ 4 files changed, 52 insertions(+), 20 deletions(-) diff --git a/collects/redex/private/rg.rkt b/collects/redex/private/rg.rkt index abf9381651..f0124eea40 100644 --- a/collects/redex/private/rg.rkt +++ b/collects/redex/private/rg.rkt @@ -12,8 +12,14 @@ (for-syntax "keyword-macros.ss") mrlib/tex-table) -(define (exotic-choice? [random random]) (= 0 (random 5))) -(define (use-lang-literal? [random random]) (= 0 (random 20))) +(define redex-pseudo-random-generator + (make-parameter (current-pseudo-random-generator))) +(define (generator-random . arg) + (parameterize ([current-pseudo-random-generator (redex-pseudo-random-generator)]) + (apply random arg))) + +(define (exotic-choice? [random generator-random]) (= 0 (random 5))) +(define (use-lang-literal? [random generator-random]) (= 0 (random 20))) (define default-check-attempts 1000) @@ -21,11 +27,11 @@ (define tex-chars-threshold 1500) (define chinese-chars-threshold 2500) -(define (pick-var lang-lits attempt [random random]) +(define (pick-var lang-lits attempt [random generator-random]) (let ([length (add1 (random-natural 4/5 random))]) (string->symbol (random-string lang-lits length attempt random)))) -(define (pick-char attempt [random random]) +(define (pick-char attempt [random generator-random]) (cond [(or (< attempt ascii-chars-threshold) (not (exotic-choice? random))) (let ([i (random (add1 (- (char->integer #\z) (char->integer #\a))))] [cap? (zero? (random 2))]) @@ -39,18 +45,18 @@ [else (integer->char (+ #x4E00 (random (- #x9FCF #x4E00))))])) -(define (random-string lang-lits length attempt [random random]) +(define (random-string lang-lits length attempt [random generator-random]) (if (and (not (null? lang-lits)) (use-lang-literal? random)) (pick-from-list lang-lits random) (list->string (build-list length (λ (_) (pick-char attempt random)))))) -(define (pick-any lang sexp [random random]) +(define (pick-any lang sexp [random generator-random]) (if (and (> (dict-count (rg-lang-non-cross lang)) 0) (zero? (random 5))) (let ([nts (rg-lang-non-cross lang)]) (values lang (pick-from-list (dict-map nts (λ (nt _) nt)) random))) (values sexp 'sexp))) -(define (pick-string lang-lits attempt [random random]) +(define (pick-string lang-lits attempt [random generator-random]) (random-string lang-lits (random-natural 1/5 random) attempt random)) ;; next-non-terminal-decision selects a subset of a non-terminal's productions. @@ -58,7 +64,8 @@ ;; generator's test cases restrict the productions. (define pick-nts values) -(define (pick-from-list l [random random]) (list-ref l (random (length l)))) +(define (pick-from-list l [random generator-random]) + (list-ref l (random (length l)))) ;; Chooses a random (exact) natural number from the "shifted" geometric distribution: ;; P(random-natural = k) = p(1-p)^k @@ -66,22 +73,22 @@ ;; P(random-natural >= k) = (1-p)^(k+1) ;; E(random-natural) = (1-p)/p ;; Var(random-natural) = (1-p)/p^2 -(define (random-natural p [random random]) +(define (random-natural p [random generator-random]) (sub1 (inexact->exact (ceiling (real-part (/ (log (random)) (log (- 1 p)))))))) (define (negative? random) (zero? (random 2))) -(define (random-integer p [random random]) +(define (random-integer p [random generator-random]) (* (if (negative? random) -1 1) (random-natural p random))) -(define (random-rational p [random random]) +(define (random-rational p [random generator-random]) (/ (random-integer p random) (add1 (random-natural p random)))) -(define (random-real p [random random]) +(define (random-real p [random generator-random]) (* (random) 2 (random-integer p random))) -(define (random-complex p [random random]) +(define (random-complex p [random generator-random]) (let ([randoms (list random-integer random-rational random-real)]) (make-rectangular ((pick-from-list randoms random) p random) ((pick-from-list randoms random) p random)))) @@ -109,7 +116,7 @@ (define attempt->size (make-parameter default-attempt->size)) -(define (pick-number attempt #:top-threshold [top-threshold complex-threshold] [random random]) +(define (pick-number attempt #:top-threshold [top-threshold complex-threshold] [random generator-random]) (let loop ([threshold 0] [generator random-natural] [levels `((,integer-threshold . ,random-integer) @@ -123,13 +130,13 @@ (generator (expected-value->p ((attempt->size) (- attempt threshold))) random) (loop (caar levels) (cdar levels) (cdr levels))))) -(define (pick-natural attempt [random random]) +(define (pick-natural attempt [random generator-random]) (pick-number attempt #:top-threshold 0 random)) -(define (pick-integer attempt [random random]) +(define (pick-integer attempt [random generator-random]) (pick-number attempt #:top-threshold integer-threshold random)) -(define (pick-real attempt [random random]) +(define (pick-real attempt [random generator-random]) (pick-number attempt #:top-threshold real-threshold random)) (define (pick-sequence-length attempt) @@ -991,7 +998,8 @@ generate-term check-reduction-relation check-metafunction - exn:fail:redex:generation-failure?) + exn:fail:redex:generation-failure? + redex-pseudo-random-generator) (provide (struct-out ellipsis) (struct-out mismatch) diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index b81af99ac4..c49da45c59 100644 --- a/collects/redex/redex.scrbl +++ b/collects/redex/redex.scrbl @@ -1454,7 +1454,12 @@ produces and consumes argument lists.} @racket[redex-check], etc. when those forms are unable to produce a term matching some pattern. } - + +@defparam[redex-pseudo-random-generator generator pseudo-random-generator?]{ +@racket[generate-term] and the randomized testing forms (e.g., @racket[redex-check]) +use the parameter @racket[generator] to construct random terms. The parameter's +initial value is @racket[(current-pseudo-random-generator)].} + @deftech{Debugging PLT Redex Programs} It is easy to write grammars and reduction rules that are diff --git a/collects/redex/reduction-semantics.rkt b/collects/redex/reduction-semantics.rkt index 9e1351b7f1..278087beaa 100644 --- a/collects/redex/reduction-semantics.rkt +++ b/collects/redex/reduction-semantics.rkt @@ -76,4 +76,5 @@ (-> bindings? symbol? any) (-> bindings? symbol? (-> any) any))] [relation-coverage (parameter/c (listof coverage?))] - [covered-cases (-> coverage? (listof (cons/c string? natural-number/c)))]) + [covered-cases (-> coverage? (listof (cons/c string? natural-number/c)))] + [redex-pseudo-random-generator (parameter/c pseudo-random-generator?)]) diff --git a/collects/redex/tests/rg-test.rkt b/collects/redex/tests/rg-test.rkt index 9b640835bc..246c9fd0f4 100644 --- a/collects/redex/tests/rg-test.rkt +++ b/collects/redex/tests/rg-test.rkt @@ -1257,4 +1257,22 @@ '(x ..._1 x ..._2 variable ..._2 variable ..._3 variable_1 ..._3 variable_1 ..._4) '((..._1 . ..._4) (..._2 . ..._4) (..._3 . ..._4)))) +;; redex-test-seed +(let ([seed 0]) + (define-language L) + (define (generate) + (generate-term L (number ...) 10000000 #:attempt-num 10000000)) + (test (begin (random-seed seed) (generate)) + (begin (random-seed seed) (generate))) + (let ([prg (make-pseudo-random-generator)]) + (define (seed-effect-generate effect) + (begin + (parameterize ([current-pseudo-random-generator prg]) + (random-seed seed)) + (effect) + (parameterize ([redex-pseudo-random-generator prg]) + (generate)))) + (test (seed-effect-generate void) + (seed-effect-generate random)))) + (print-tests-passed 'rg-test.ss) From 1ccd6e7a2c1cc7ae577516ef5bf4931b604d3a67 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Fri, 26 Nov 2010 13:24:21 -0600 Subject: [PATCH 147/255] Randomized tests for the delimited control model. Tests in randomized-tests.rkt are deliberately not run by DrDr at the moment because they fail too consistently. --- collects/meta/props | 2 + .../redex/examples/delim-cont/model-impl.rkt | 76 ++++ .../delim-cont/randomized-tests-test.rkt | 147 +++++++ .../examples/delim-cont/randomized-tests.rkt | 385 ++++++++++++++++++ 4 files changed, 610 insertions(+) create mode 100644 collects/redex/examples/delim-cont/model-impl.rkt create mode 100644 collects/redex/examples/delim-cont/randomized-tests-test.rkt create mode 100644 collects/redex/examples/delim-cont/randomized-tests.rkt diff --git a/collects/meta/props b/collects/meta/props index 86555507bf..9677c869e6 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1198,6 +1198,8 @@ path/s is either such a string or a list of them. "collects/redex/examples/church.rkt" drdr:command-line (mzc *) "collects/redex/examples/combinators.rkt" drdr:command-line (mzc *) "collects/redex/examples/compatible-closure.rkt" drdr:command-line (mzc *) +"collects/redex/examples/delim-cont/randomized-tests-test.rkt" drdr:timeout 120 drdr:random #t +"collects/redex/examples/delim-cont/randomized-tests.rkt" drdr:random #t "collects/redex/examples/delim-cont/test.rkt" drdr:command-line (mzc *) "collects/redex/examples/letrec.rkt" drdr:command-line (mzc *) "collects/redex/examples/omega.rkt" drdr:command-line (mzc *) diff --git a/collects/redex/examples/delim-cont/model-impl.rkt b/collects/redex/examples/delim-cont/model-impl.rkt new file mode 100644 index 0000000000..8118d7668b --- /dev/null +++ b/collects/redex/examples/delim-cont/model-impl.rkt @@ -0,0 +1,76 @@ +#lang racket + +(provide % abort call/comp call/cm current-marks + (rename-out [_call/cc call/cc] + [_if if] + [_+ +] + [_print print] + [_cons cons] + [_set! set!] + [_zero? zero?])) + +(define tag + (let ([tags (make-hash)]) + (λ (v) + (hash-ref tags v + (λ () + (let ([t (make-continuation-prompt-tag)]) + (hash-set! tags v t) + t)))))) + +(define-syntax-rule (% tag-val expr handler) + (call-with-continuation-prompt + (λ () expr) + (let ([v tag-val]) + (if (let comparable? ([v v]) + (cond [(procedure? v) #f] + [(list? v) (andmap comparable? v)] + [else #t])) + (tag v) + (raise-type-error '% "non-procedure" v))) + (let ([h handler]) + (λ (x) (h x))))) + +(define (abort tag-val result) + (abort-current-continuation (tag tag-val) result)) + +(define ((force-unary f) x) (f x)) + +(define (_call/cc proc tag-val) + (call/cc (compose proc force-unary) (tag tag-val))) + +(define (call/comp proc tag-val) + (call-with-composable-continuation (compose proc force-unary) (tag tag-val))) + +(define (call/cm key val thunk) + (with-continuation-mark key val (thunk))) + +(define (current-marks key tag-val) + (continuation-mark-set->list + (current-continuation-marks (tag tag-val)) + key)) + +(define-syntax-rule (_if e1 e2 e3) + (let ([v1 e1]) + (case v1 + [(#t) e2] + [(#f) e3] + [else (raise-type-error 'if "#t or #f" v1)]))) + +(define (_+ x y) (+ x y)) + +(define (_print n) + (if (number? n) + (begin (print n) #f) + (raise-type-error 'print "number" n))) + +(define (_cons x xs) + (if (list? xs) + (cons x xs) + (raise-type-error 'cons "list?" 1 x xs))) + +(define-syntax-rule (_set! x e) + (begin (set! x e) #f)) + +(define (_zero? x) + (equal? 0 x)) \ No newline at end of file diff --git a/collects/redex/examples/delim-cont/randomized-tests-test.rkt b/collects/redex/examples/delim-cont/randomized-tests-test.rkt new file mode 100644 index 0000000000..a55b39a6bf --- /dev/null +++ b/collects/redex/examples/delim-cont/randomized-tests-test.rkt @@ -0,0 +1,147 @@ +#lang racket + +(require "randomized-tests.rkt" + "reduce.rkt" + "grammar.rkt" + rackunit + (except-in redex/reduction-semantics plug)) + +(define-syntax (test-transformation stx) + (syntax-case stx () + [(_ program expected-output expected-result) + #`(match-let ([(answer actual-output actual-result) + (model-eval (transform-intermediate (term program)))]) + (begin + #,(syntax/loc #'expected-output + (check-equal? actual-output expected-output)) + #,(syntax/loc #'expected-result + (check-equal? actual-result 'expected-result))))])) + +(test-transformation + (<> () + () + (% 0 + (wcm () + ((λ (k) + (begin (k 7) (print 1))) + (cont 0 hole))) + (λ (x) x))) + "" 7) + +(test-transformation + (<> () + () + (cont 1 (begin hole (print 3)))) + "" procedure) + +(test-transformation + (<> () + () + (% 0 + (print + (wcm () + ((λ (k) (begin (k 1) 2)) + (comp (print hole))))) + (λ (x) x))) + "12" #f) + +(test-transformation + (<> () + (1) + (% 1 + (dw + x_1 + (print 1) + (wcm () + ((λ (k) (k 3)) + (cont 1 (dw x_1 (print 1) hole (print 2))))) + (print 2)) + (λ (x) x))) + "12" 3) + +(test-transformation + (<> () + (1) + (% 0 + ((% 0 + (dw + x_1 + (print 1) + (wcm () + ((λ (k) k) + (cont 0 (dw x_1 (print 1) hole (print 2))))) + (print 2)) + (λ (x) x)) + 3) + (λ (x) x))) + "1212" 3) + +(test-transformation + (<> () [] + (% 0 + (wcm ([1 2] [3 4]) + ((λ (x) x) + (wcm ([1 5] [3 6]) + (cons (current-marks 1 0) + (cons (current-marks 3 0) + (list)))))) + (λ (x) x))) + "" ((5 2) (6 4))) + +(test-transformation + (<> + () + () + (dw + ra + (print 1) + (print 2) + (print 3))) + "23" #f) + +(test-transformation + (<> () + () + (% + 1 + (dw x_1 + (print 1) + (abort 1 (cont 1 (dw x_1 (print 1) hole (print 3)))) + (print 3)) + (λ (k) (% 1 (k 4) (λ (x) x))))) + "313" 4) + +(test-transformation + (<> + () + () + ((comp + (dw + ra + (print 1) + hole + (dw q (print 2) (print 3) (print 4)))) + 5)) + "134" 5) + +(define (transformation-preserves-meaning? p) + (let ([original-result (parameterize ([model-eval-steps 1000]) (model-eval p))] + [transformed (transform-intermediate p)] + [warn (λ () (eprintf "Long test:\n") (pretty-write p (current-error-port)))] + [threshold (* 60 2)]) + (or (timeout? original-result) + (let ([transformed-result + (timeout-warn threshold (model-eval transformed) (warn))]) + (if (answer? original-result) + (equal? original-result transformed-result) + (not (answer? transformed-result)))) + ; filters bad tests + (bad-test? (timeout-warn threshold (impl-eval (impl-program transformed)) (warn)))))) + +(define-syntax-rule (test-transformation/randomized . kw-args) + (let ([test-number 1]) + (redex-check grammar p (transformation-preserves-meaning? (term p)) + #:prepare fix-prog + #:source :-> . kw-args))) + +(time (test-transformation/randomized #:attempts 1 #:attempt-size (const 3))) \ No newline at end of file diff --git a/collects/redex/examples/delim-cont/randomized-tests.rkt b/collects/redex/examples/delim-cont/randomized-tests.rkt new file mode 100644 index 0000000000..775a76e515 --- /dev/null +++ b/collects/redex/examples/delim-cont/randomized-tests.rkt @@ -0,0 +1,385 @@ +#lang racket + +(require "grammar.ss" + "reduce.rkt" + (except-in redex/reduction-semantics plug) + racket/runtime-path) + +(provide (all-defined-out)) + +(define (main [seed-arg #f]) + (define seed + (if seed-arg + (string->number seed-arg) + (add1 (random (sub1 (expt 2 31)))))) + (printf "Test seed: ~s\n" seed) + (parameterize ([current-pseudo-random-generator test-prg]) + (random-seed seed)) + (parameterize ([redex-pseudo-random-generator test-prg]) + (time (test #:attempts 3000)) + (time (test #:source :-> #:attempts 3000)))) + +(define-syntax-rule (test . kw-args) + (redex-check grammar p (same-behavior? (term p)) + #:prepare fix-prog . kw-args)) + +(define fix-prog + (match-lambda + [`(<> ,s ,_ ,e) + (match-let ([`([,xs ,vs] ...) (remove-duplicates s #:key first)]) + `(<> ,(map list xs (map (fix-expr xs) vs)) [] ,((fix-expr xs) e)))])) + +(define (fix-expr top-vars) + (compose drop-duplicate-binders + proper-wcms + consistent-dws + (curry close top-vars '()))) + +(struct error (cause) #:transparent) +(struct answer (output result) #:transparent) +(struct bad-test (reason) #:transparent) +(struct timeout ()) + +(define (same-behavior? prog) + (let ([impl-behavior (timeout-kill 15 (impl-eval (impl-program (transform-intermediate prog))))]) + (or (bad-test? impl-behavior) + (timeout? impl-behavior) + (let ([model-behavior (timeout-warn 30 (model-eval prog) (pretty-write prog))]) + (or (timeout? model-behavior) + (if (error? impl-behavior) + (error? model-behavior) + (and (answer? model-behavior) + (equal? impl-behavior model-behavior)))))))) + +(define impl-program + (match-lambda + [`(<> ,s [] ,e) + `(letrec ,s ,e)] + [e e])) + +(define-runtime-module-path model-impl "model-impl.rkt") + +(define impl-eval + (let ([ns (make-base-empty-namespace)]) + (parameterize ([current-namespace ns]) + (namespace-require 'racket) + (namespace-require (resolved-module-path-name model-impl))) + (define show + (match-lambda + [(? procedure?) 'procedure] + [(? list? vs) (map show vs)] + [v v])) + (λ (test) + (define output (open-output-string)) + (define result + (with-handlers ([exn:fail? + (λ (e) + (match (exn-message e) + [(regexp #rx"%: expected argument of type ") + (bad-test "procedure as tag")] + [_ (error e)]))]) + (parameterize ([current-output-port output]) + (eval test ns)))) + (if (or (error? result) (bad-test? result)) + result + (answer (get-output-string output) + (show result)))))) + +(define model-eval-steps (make-parameter +inf.0)) + +(define (model-eval prog) + (let/ec return + (define show + (match-lambda + [(? number? n) n] + [(? boolean? b) b] + [`(list . ,vs) (map show vs)] + [v 'procedure])) + (define (eval prog steps) + (define ns (set)) + (let recur ([p prog] [d steps] [s (set)]) + (define qs (apply-reduction-relation :-> p)) + (if (empty? qs) + (set! ns (set-add ns p)) + (if (< d 0) + (return (timeout)) + (for ([q qs]) + (if (set-member? s q) + (return (timeout)) + (recur q (sub1 d) (set-add s p))))))) + (set-map ns values)) + (match (eval prog (model-eval-steps)) + [(list (and p `(<> ,_ ,output ,result))) + (if (v? result) + (answer + (apply string-append (map (curry format "~v") output)) + (show result)) + (error p))]))) + +(define (with-timeout thunk timeout on-timeout) + (let ([c (make-channel)]) + (struct raised (value)) + (let ([t (thread + (λ () + (channel-put + c (with-handlers ([exn:fail? raised]) + (thunk)))))]) + (match (sync/timeout timeout c) + [#f (on-timeout t c)] + [(raised v) (raise v)] + [x x])))) + +(define-syntax-rule (timeout-kill time expr) + (with-timeout (λ () expr) time + (λ (t _) + (kill-thread t) + (timeout)))) +(define-syntax-rule (timeout-warn time expr warn) + (with-timeout (λ () expr) time + (λ (_ c) + warn + (sync c)))) + +(define (close top-vars loc-vars expr) + (match expr + [(? x? x) + (let ([bound (append top-vars loc-vars)]) + (cond [(memq x bound) x] + [(not (empty? bound)) + (random-member bound)] + [else (random-literal)]))] + [`(set! ,x ,e) + (if (empty? top-vars) + (close top-vars loc-vars e) + `(set! ,(random-member top-vars) + ,(close top-vars loc-vars e)))] + [`(λ ,xs ,e) + `(λ ,xs + ,(close (filter (negate (curryr member xs)) top-vars) + (append xs loc-vars) + e))] + [`(dw ,x ,e_1 ,e_2 ,e_3) + `(dw ,x + ,(close top-vars loc-vars e_1) + ,(close top-vars loc-vars e_2) + ,(close top-vars loc-vars e_3))] + ; substitution does not recur inside continuation values + ; (not sure why it bothers to recur within dw expression) + [`(cont ,v ,E) + `(cont ,(close top-vars '() v) + ,(close top-vars '() E))] + [`(cont ,E) + `(comp ,(close top-vars '() E))] + [(? list?) + (map (curry close top-vars loc-vars) expr)] + [_ expr])) + +(define drop-duplicate-binders + (match-lambda + [`(λ ,xs ,e) + `(λ ,(remove-duplicates xs) ,(drop-duplicate-binders e))] + [(? list? es) + (map drop-duplicate-binders es)] + [e e])) + +(define (consistent-dws p) + (define pre-post + (let ([h (make-hash)]) + (λ (id pre post) + (match (hash-ref h id #f) + [#f + (hash-set! h id (list pre post)) + (list pre post)] + [x x])))) + (let recur ([x p] [excluded '()]) + (match x + [`(dw ,x ,e1 ,e2 ,e3) + (if (member x excluded) + (recur e2 excluded) + (match-let ([(list e1’ e3’) (pre-post x e1 e3)]) + `(dw ,x + ,(recur e1’ (cons x excluded)) + ,(recur e2 excluded) + ,(recur e3’ (cons x excluded)))))] + [(? list?) (map (curryr recur excluded) x)] + [_ x]))) + +(define (proper-wcms e) + (let fix ([ok? #t] [e e]) + (match e + [`(wcm ,w ,e) + (if ok? + `(wcm ,(remove-duplicates (fix #t w) #:key first) + ,(fix #f e)) + (fix #f e))] + [`(list . ,vs) + `(list . ,(map (curry fix #t) vs))] + [`(λ ,xs ,e) + ; #f in case applied with a continuation that's already marked + `(λ ,xs ,(fix #f e))] + [`(cont ,v ,E) + `(cont ,(fix #t v) ,(fix #t E))] + [`(comp ,E) + `(comp ,(fix #t E))] + [`(begin ,e1 ,e2) + `(begin ,(fix #t e1) + ,(fix ok? e2))] + [`(% ,e1 ,e2 ,e3) + `(% ,(fix #t e1) ,(fix ok? e2) ,(fix #t e3))] + [`(dw ,x ,e1 ,e2 ,e3) + `(dw ,x ,(fix #t e1) ,(fix ok? e2) ,(fix #t e3))] + [`(if ,e1 ,e2 ,e3) + `(if ,(fix #t e1) + ,(fix ok? e2) + ,(fix ok? e3))] + [`(set! ,x ,e) + `(set! ,x ,(fix #t e))] + [(? list?) + (map (curry fix #t) e)] + [_ e]))) + +(define transform-intermediate + (match-lambda + [(and p `(<> ,s ,o ,e)) + (define fresh (make-fresh p)) + (define allocated (map first s)) + (define (alloc-cell prefix) + (define cell (fresh prefix)) + (set! allocated (cons cell allocated)) + cell) + (define no-dw? (alloc-cell "handlers-disabled?")) + (define dw-frame-locs + (let ([locs (make-hash)]) + (λ (x) + (hash-ref + locs x + (λ () (let ([ys (list (alloc-cell (format "~s-allocated?" x)) + (alloc-cell (format "~s-skip-pre?" x)) + (alloc-cell (format "~s-comp-cont" x)))]) + (hash-set! locs x ys) + ys)))))) + (define transform + (match-lambda + [`(wcm () ,m) + (transform m)] + [`(wcm ([,k ,v] . ,w) ,m) + `(call/cm ,(transform k) ,(transform v) + (λ () ,(transform `(wcm ,w ,m))))] + [(and e `(dw ,x ,e1 ,e2 ,e3)) + (match-let ([(list a? s? c) (dw-frame-locs x)] + [t (fresh "t")]) + `((λ (,t) + (if ,a? + (begin (if ,no-dw? #f (set! ,s? #t)) (,c ,t)) + (% 1 + (dynamic-wind + (λ () + (if ,no-dw? + #f + (if ,a? + (if ,s? (set! ,s? #f) ,(transform e1)) + #f))) + (λ () + ((call/comp + (λ (k) + (begin + (set! ,c k) + (abort 1 k))) + 1))) + (λ () + (if ,no-dw? + (set! ,a? #t) + (if ,a? + ,(transform e3) + (set! ,a? #t))))) + (λ (k) (begin (if ,no-dw? #f (set! ,s? #t)) (k ,t)))))) + (λ () ,(transform e2))))] + [`(cont ,v ,E) + (let ([x (fresh "v")]) + `(begin + (set! ,no-dw? #t) + ((λ (,x) + (% ,x + ,(transform + (term (plug ,E (call/cc (λ (k) (abort ,x k)) ,x)))) + (λ (x) (begin (set! ,no-dw? #f) x)))) + ,(transform v))))] + [`(comp ,E) + (define numbers + (match-lambda + [(? integer? n) (list n)] + [(? list? l) (append-map numbers l)] + [_ (list)])) + (define t (add1 (apply max 0 (numbers E)))) + `(begin + (set! ,no-dw? #t) + (% ,t + ,(transform + (term (plug ,E (call/comp (λ (k) (abort ,t k)) ,t)))) + (λ (x) (begin (set! ,no-dw? #f) x))))] + [`(list ,vs ...) + `(list ,@(map transform-value vs))] + [(? list? xs) + (map transform xs)] + [e e])) + (define transform-value + (match-lambda + [(and e (or `(cont ,_ ,_) `(comp ,_))) + `(λ (x) (,(transform e) x))] + [e (transform e)])) + (define e’ (transform e)) + (define s’ (map (match-lambda [(list x v) (list x (transform-value v))]) s)) + `(<> ,(map (λ (x) (match (assoc x s’) + [#f (list x #f)] + [(list _ v’) (list x v’)])) + allocated) + ,o + ,e’)])) + +;; The built-in `plug' sometimes chooses the wrong hole. +(define-metafunction grammar + [(plug hole any) any] + [(plug (in-hole W (dw x e_1 E e_2)) any) + (in-hole W (dw x e_1 (plug E any) e_2))] + [(plug (wcm w M) any) + (wcm w (plug M any))] + [(plug (v ... W e ...) any) + (v ... (plug W any) e ...)] + [(plug (begin W e) any) + (begin (plug W any) e)] + [(plug (% W e_1 e_2) any) + (% (plug W any) e_1 e_2)] + [(plug (% v e W) any) + (% v e (plug W any))] + [(plug (% v_1 W v_2) any) + (% v_1 (plug W any) v_2)] + [(plug (set! x W) any) + (set! x (plug W any))] + [(plug (if W e_1 e_2) any) + (if (plug W any) e_1 e_2)]) + +(define (make-fresh p) + (define suffix + (let recur ([x p] [s 0]) + (cond [(symbol? x) + (match (regexp-match #rx"_(.+)$" (symbol->string x)) + [(list _ n) (max s (add1 (string->number n)))] + [#f s])] + [(pair? x) (recur (cdr x) (recur (car x) s))] + [else s]))) + (λ (prefix) + (begin0 (string->symbol (format "~a_~a" prefix suffix)) + (set! suffix (add1 suffix))))) + +(define (random-literal) + (random-member + '(dynamic-wind abort current-marks cons + -inf.0 +inf.0 -1 0 1 1/3 -1/4 .33 -.25 4-3i 3+4i + call/cc call/comp call/cm + #f #t zero? print + first rest))) + +(define (random-member xs) + (parameterize ([current-pseudo-random-generator test-prg]) + (list-ref xs (random (length xs))))) + +(define test-prg (make-pseudo-random-generator)) \ No newline at end of file From e999daa87176a732586fdbd79d2e1a1d5fae0842 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 26 Nov 2010 16:50:37 -0500 Subject: [PATCH 148/255] Adding page and get-binding --- collects/web-server/page/page.rkt | 77 +++++++++++++++++++++++++++++++ 1 file changed, 77 insertions(+) create mode 100644 collects/web-server/page/page.rkt diff --git a/collects/web-server/page/page.rkt b/collects/web-server/page/page.rkt new file mode 100644 index 0000000000..011c34e4ab --- /dev/null +++ b/collects/web-server/page/page.rkt @@ -0,0 +1,77 @@ +#lang racket/base +(require web-server/servlet + racket/stxparam + (for-syntax racket/base)) + +(define-syntax-parameter embed/url + (λ (stx) (raise-syntax-error stx 'embed/url "Used outside page"))) + +(define-syntax-rule (page e ...) + (send/suspend/dispatch + (λ (this-embed/url) + (syntax-parameterize ([embed/url (make-rename-transformer #'this-embed/url)]) + e ...)))) + +(define current-request (make-parameter #f)) + +(define-syntax-rule (lambda/page formals e ...) + (lambda (req . formals) + (parameterize ([current-request req]) + (page e ...)))) + +(define-syntax-rule (define/page (id . formals) e ...) + (define id + (lambda/page formals e ...))) + +(define binding-id/c (or/c bytes? string? symbol?)) +(define (binding-id->bytes id) + (cond [(bytes? id) + id] + [(string? id) + (string->bytes/utf-8 id)] + [(symbol? id) + (binding-id->bytes (symbol->string id))])) + +(define binding-format/c (symbols 'string 'bytes 'file 'binding)) +(define (convert-binding format b) + (case format + [(string) + (and (binding:form? b) + (with-handlers ([exn:fail? (λ (x) #f)]) + (bytes->string/utf-8 (binding:form-value b))))] + [(bytes) + (and (binding:form? b) + (binding:form-value b))] + [(file) + (and (binding:file? b) + (binding:file-content b))] + [(binding) + b])) + +(define (get-binding id #:format [format 'string]) + (convert-binding + format + (bindings-assq + (binding-id->bytes id) + (request-bindings/raw (current-request))))) + +(define (get-bindings id #:format [format 'string]) + (define id-bs (binding-id->bytes id)) + (filter-map + (λ (b) + (and (bytes=? id-bs (binding-id b)) + (convert-binding format b))) + (request-bindings/raw (current-request)))) + +(provide embed/url + page + lambda/page + define/page) +(provide/contract + [current-request (parameter/c (or/c false/c request?))] + [binding-id/c contract?] + [binding-format/c contract?] + [get-binding (->* (binding-id/c) (#:format binding-format/c) + (or/c false/c string? bytes? binding?))] + [get-bindings (->* (binding-id/c) (#:format binding-format/c) + (listof (or/c string? bytes? binding?)))]) \ No newline at end of file From 83205171921ee28e0104e0eaff79a7805ca5d4ee Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 26 Nov 2010 17:35:17 -0500 Subject: [PATCH 149/255] Adding page --- .../dispatchers/dispatch-servlets-test.rkt | 2 + .../htdocs/servlets/examples/add-page.rkt | 27 +++++++ collects/web-server/page.rkt | 3 + collects/web-server/page/page.rkt | 16 +++-- collects/web-server/scribblings/page.scrbl | 70 +++++++++++++++++++ .../web-server/scribblings/web-server.scrbl | 4 +- 6 files changed, 114 insertions(+), 8 deletions(-) create mode 100644 collects/web-server/default-web-root/htdocs/servlets/examples/add-page.rkt create mode 100644 collects/web-server/page.rkt create mode 100644 collects/web-server/scribblings/page.scrbl diff --git a/collects/tests/web-server/dispatchers/dispatch-servlets-test.rkt b/collects/tests/web-server/dispatchers/dispatch-servlets-test.rkt index d9a5b2e97a..afd0df4a68 100644 --- a/collects/tests/web-server/dispatchers/dispatch-servlets-test.rkt +++ b/collects/tests/web-server/dispatchers/dispatch-servlets-test.rkt @@ -69,6 +69,8 @@ (build-path example-servlets "add-ssd.rkt")) (test-add-two-numbers mkd "add-formlets.rkt - send/formlet" (build-path example-servlets "add-formlets.rkt")) + (test-add-two-numbers mkd "add-page.rkt" + (build-path example-servlets "add-page.rkt")) (test-equal? "count.rkt - state" (let* ([d (mkd (build-path example-servlets "count.rkt"))] [ext (lambda (c) diff --git a/collects/web-server/default-web-root/htdocs/servlets/examples/add-page.rkt b/collects/web-server/default-web-root/htdocs/servlets/examples/add-page.rkt new file mode 100644 index 0000000000..fdbdd340c3 --- /dev/null +++ b/collects/web-server/default-web-root/htdocs/servlets/examples/add-page.rkt @@ -0,0 +1,27 @@ +#lang racket/base +(require web-server/servlet + web-server/page) +(provide (all-defined-out)) +(define interface-version 'v1) +(define timeout +inf.0) + +(define (request-number which-number) + (let/ec esc + (page + `(html (head (title "Enter a Number to Add")) + (body ([bgcolor "white"]) + (form ([action ,(embed/url + (lambda/page () + (esc + (string->number + (get-binding 'number)))))] + [method "post"]) + "Enter the " ,which-number " number to add: " + (input ([type "text"] [name "number"] [value ""])) + (input ([type "submit"] [name "enter"] [value "Enter"])))))))) + +(define/page (start) + `(html (head (title "Sum")) + (body ([bgcolor "white"]) + (p "The answer is " + ,(number->string (+ (request-number "first") (request-number "second"))))))) diff --git a/collects/web-server/page.rkt b/collects/web-server/page.rkt new file mode 100644 index 0000000000..c6829d25cf --- /dev/null +++ b/collects/web-server/page.rkt @@ -0,0 +1,3 @@ +#lang racket/base +(require "page/page.rkt") +(provide (all-from-out "page/page.rkt")) \ No newline at end of file diff --git a/collects/web-server/page/page.rkt b/collects/web-server/page/page.rkt index 011c34e4ab..25319de91f 100644 --- a/collects/web-server/page/page.rkt +++ b/collects/web-server/page/page.rkt @@ -1,6 +1,8 @@ #lang racket/base (require web-server/servlet racket/stxparam + racket/list + racket/contract (for-syntax racket/base)) (define-syntax-parameter embed/url @@ -48,20 +50,22 @@ [(binding) b])) -(define (get-binding id #:format [format 'string]) +(define (get-binding id [req (current-request)] + #:format [format 'string]) (convert-binding format (bindings-assq (binding-id->bytes id) - (request-bindings/raw (current-request))))) + (request-bindings/raw req)))) -(define (get-bindings id #:format [format 'string]) +(define (get-bindings id [req (current-request)] + #:format [format 'string]) (define id-bs (binding-id->bytes id)) (filter-map (λ (b) (and (bytes=? id-bs (binding-id b)) (convert-binding format b))) - (request-bindings/raw (current-request)))) + (request-bindings/raw req))) (provide embed/url page @@ -71,7 +75,7 @@ [current-request (parameter/c (or/c false/c request?))] [binding-id/c contract?] [binding-format/c contract?] - [get-binding (->* (binding-id/c) (#:format binding-format/c) + [get-binding (->* (binding-id/c) (request? #:format binding-format/c) (or/c false/c string? bytes? binding?))] - [get-bindings (->* (binding-id/c) (#:format binding-format/c) + [get-bindings (->* (binding-id/c) (request? #:format binding-format/c) (listof (or/c string? bytes? binding?)))]) \ No newline at end of file diff --git a/collects/web-server/scribblings/page.scrbl b/collects/web-server/scribblings/page.scrbl new file mode 100644 index 0000000000..89df9bd592 --- /dev/null +++ b/collects/web-server/scribblings/page.scrbl @@ -0,0 +1,70 @@ +#lang scribble/doc +@(require "web-server.rkt") +@(require (for-label web-server/servlet + web-server/page + racket/promise + racket/list + xml)) + +@title[#:tag "page"]{Page: Short-hand for Common Patterns} + +@defmodule[web-server/page] + +The @web-server provides a simple utility library for building Web applications that consistent mostly of @racket[send/suspend/dispatch]-created pages and request handling. + +Most Web applications rely heavily on @racket[send/suspend/dispatch] and typically use the pattern: +@racketblock[ + (send/suspend/dispatch + (λ (my-embed/url) + .... (my-embed/url other-page) ....))] + +@defform[(page e ...)]{ + +The @racket[page] macro automates this by expanding @racket[(page e ...)] to a usage of @racket[send/suspend/dispatch] where the syntax parameter @racket[embed/url] is bound to the argument of @racket[send/suspend/dispatch]. + +} + +@defidform[embed/url]{ +When used inside @racket[page] syntactically, a rename transformer for the procedure embedding function; otherwise, a syntax error.} + +A simple example: +@racketblock[ + (page + `(html + (body + (a ([href + ,(embed/url + (λ (req) + "You clicked!"))]) + "Click me"))))] + +Similarly, many Web applications make use almost exclusively of functions that are arguments to @racket[embed/url] and immediately invoke @racket[send/suspend/dispatch]. + +@deftogether[[@defform[(lambda/page formals e ...)] + @defform[(define/page (id . formals) e ...)]]]{ +The @racket[lambda/page] and @racket[define/page] automate this by expanding to functions that accept a request as the first argument (followed by any arguments specified in @racket[formals]) and immediately wrap their body in @racket[page]. This functions also cooperate with @racket[get-binding] by binding the request to the @racket[current-request] parameter. +} + +The binding interface of @racketmodname[web-server/http] is powerful, but subtle to use conveniently due to its protection against hostile clients. + +@deftogether[[ +@defparam[current-request req request?] +@defthing[binding-id/c contract?] +@defthing[binding-format/c contract?] +@defproc[(get-binding [id binding-id/c] [req request? (current-request)] [#:format format binding-format/c 'string]) + (or/c false/c string? bytes? binding?)] +@defproc[(get-bindings [id binding-id/c] [req request? (current-request)] [#:format format binding-format/c 'string]) + (listof (or/c string? bytes? binding?))] +]]{ + + The @racket[get-binding](s) interface attempts to resolve this by providing a powerful interface with convenient defaults. + + @racket[get-binding] extracts the first binding of a form input from a request, while @racket[get-bindings] extracts them all. + + They accept a form identifier (@racket[id]) as either a byte string, a string, or a symbol. In each case, the user input is compared in a case-sensitive way with the form input. + + They accept an optional request argument (@racket[req]) that defaults to the value of the @racket[current-request] parameter used by @racket[lambda/page] and @racket[define/page]. + + Finally, they accept an optional keyword argument (@racket[format]) that specifies the desired return format. The default, @racket['string], produces a UTF-8 string (or @racket[#f] if the byte string cannot be converted to UTF-8.) The @racket['bytes] format always produces the raw byte string. The @racket['file] format produces the file upload content (or @racket[#f] if the form input was not an uploaded file.) The @racket['binding] format produces the binding object. + +} diff --git a/collects/web-server/scribblings/web-server.scrbl b/collects/web-server/scribblings/web-server.scrbl index abbb140488..cdac7e0fdf 100644 --- a/collects/web-server/scribblings/web-server.scrbl +++ b/collects/web-server/scribblings/web-server.scrbl @@ -16,8 +16,7 @@ This manual describes the Racket libraries for building Web applications. The @secref["http"] section describes the common library function for manipulating HTTP requests and creating HTTP responses. In particular, this section covers cookies, authentication, and request bindings. -The final three sections (@secref["dispatch"], @secref["formlets"], and @secref["templates"]) cover utility libraries that -ease the creation of typical Web applications. +The final four sections (@secref["dispatch"], @secref["formlets"], @secref["templates"], and @secref["page"]) cover utility libraries that ease the creation of typical Web applications. This manual closes with a frequently asked questions section: @secref["faq"]. @@ -33,6 +32,7 @@ This manual closes with a frequently asked questions section: @secref["faq"]. @include-section["dispatch.scrbl"] @include-section["formlets.scrbl"] @include-section["templates.scrbl"] +@include-section["page.scrbl"] @include-section["faq.scrbl"] From 4a4b3ae64c77c84f65d8634757c15362f605792c Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 26 Nov 2010 17:36:48 -0500 Subject: [PATCH 150/255] Adding doc clarification from Eli --- collects/web-server/scribblings/servlet-env.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/web-server/scribblings/servlet-env.scrbl b/collects/web-server/scribblings/servlet-env.scrbl index c231a4b7ce..65c202efbd 100644 --- a/collects/web-server/scribblings/servlet-env.scrbl +++ b/collects/web-server/scribblings/servlet-env.scrbl @@ -169,7 +169,7 @@ Like always, you don't even need to save the file. @racket[start] is loaded as a servlet and responds to requests that match @racket[servlet-regexp]. The current directory of servlet execution is @racket[servlet-current-directory]. - If @racket[launch-browser?] is true, then a web browser is opened to @filepath{http://localhost:}. + If @racket[launch-browser?] is true, then a web browser is opened to @filepath{http://localhost:}. @racket[servlet-path] has no other purpose, if @racket[servlet-regexp] is provided. If @racket[quit?] is true, then the URL @filepath["/quit"] ends the server. From eee5c6b14aed59aa3ba64adc7c2228947ba0b972 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 26 Nov 2010 17:50:41 -0500 Subject: [PATCH 151/255] Adding response/port --- .../dispatchers/dispatch-servlets-test.rkt | 5 ++++ .../htdocs/servlets/examples/port.rkt | 15 ++++++++++++ collects/web-server/http/response-structs.rkt | 12 +++++++++- collects/web-server/http/response.rkt | 2 ++ collects/web-server/scribblings/http.scrbl | 24 ++++++++++++++++++- 5 files changed, 56 insertions(+), 2 deletions(-) create mode 100644 collects/web-server/default-web-root/htdocs/servlets/examples/port.rkt diff --git a/collects/tests/web-server/dispatchers/dispatch-servlets-test.rkt b/collects/tests/web-server/dispatchers/dispatch-servlets-test.rkt index afd0df4a68..b27aaa9092 100644 --- a/collects/tests/web-server/dispatchers/dispatch-servlets-test.rkt +++ b/collects/tests/web-server/dispatchers/dispatch-servlets-test.rkt @@ -54,6 +54,11 @@ [t0 (simple-xpath* '(p) (call d url0 empty))]) t0) "Hello, Web!") + (test-equal? "port.rkt" + (let* ([d (mkd (build-path example-servlets "port.rkt"))] + [t0 (simple-xpath* '(p) (call d url0 empty))]) + t0) + "Hello, Web!") (test-equal? "response.rktd - loading" (parameterize ([xexpr-drop-empty-attributes #t]) (let* ([d (mkd (build-path example-servlets "response.rktd"))]) diff --git a/collects/web-server/default-web-root/htdocs/servlets/examples/port.rkt b/collects/web-server/default-web-root/htdocs/servlets/examples/port.rkt new file mode 100644 index 0000000000..21955dc509 --- /dev/null +++ b/collects/web-server/default-web-root/htdocs/servlets/examples/port.rkt @@ -0,0 +1,15 @@ +#lang racket/base +(require web-server/servlet + racket/list) +(provide (all-defined-out)) +(define interface-version 'v1) +(define timeout +inf.0) + +(define (start initial-request) + (response/port + 200 #"Okay" (current-seconds) #"text/html" empty + (λ (op) + (display #<

Hello, Web!

+END + op)))) \ No newline at end of file diff --git a/collects/web-server/http/response-structs.rkt b/collects/web-server/http/response-structs.rkt index 3f9da98183..84f71e26eb 100644 --- a/collects/web-server/http/response-structs.rkt +++ b/collects/web-server/http/response-structs.rkt @@ -9,6 +9,7 @@ (define-struct response/basic (code message seconds mime headers)) (define-struct (response/full response/basic) (body)) (define-struct (response/incremental response/basic) (generator)) +(define-struct (response/port response/basic) (output)) (define response/c (or/c response/basic? @@ -30,6 +31,8 @@ (list* (make-header #"Content-Length" (string->bytes/utf-8 (number->string (response/full->size resp)))) (response/basic-headers resp)) (response/full-body resp))] + [(response/port? resp) + resp] [(response/incremental? resp) (if close? resp @@ -104,10 +107,17 @@ [mime bytes?] [headers (listof header?)] [generator ((() () #:rest (listof bytes?) . ->* . any) . -> . any)])] + [struct (response/port response/basic) + ([code number?] + [message bytes?] + [seconds number?] + [mime bytes?] + [headers (listof header?)] + [output (output-port? . -> . void)])] [response/c contract?] [make-xexpr-response ((pretty-xexpr/c) (#:code number? #:message bytes? #:seconds number? #:mime-type bytes? #:headers (listof header?) #:preamble bytes?) . ->* . response/full?)] - [normalize-response ((response/c) (boolean?) . ->* . (or/c response/full? response/incremental?))] + [normalize-response ((response/c) (boolean?) . ->* . (or/c response/full? response/incremental? response/port?))] [TEXT/HTML-MIME-TYPE bytes?]) diff --git a/collects/web-server/http/response.rkt b/collects/web-server/http/response.rkt index 2a7868cf33..51ee1eea14 100644 --- a/collects/web-server/http/response.rkt +++ b/collects/web-server/http/response.rkt @@ -103,6 +103,8 @@ (for-each (lambda (str) (display str o-port)) (response/full-body bresp))] + [(? response/port?) + ((response/port-output bresp) o-port)] [(? response/incremental?) (if (connection-close? conn) ((response/incremental-generator bresp) diff --git a/collects/web-server/scribblings/http.scrbl b/collects/web-server/scribblings/http.scrbl index 1233240086..00304bbdf4 100644 --- a/collects/web-server/scribblings/http.scrbl +++ b/collects/web-server/scribblings/http.scrbl @@ -199,6 +199,28 @@ Here is an example typical of what you will find in many applications: #"

")) ] } + +@defstruct[(response/port response/basic) + ([output (output-port? . -> . void)])]{ + As with @racket[response/basic], except where @racket[output] generates the response + body. This response type is not as safe and efficient for clients as @racket[response/incremental], + but can be convenient on the server side. + + Example: + @racketblock[ + (make-response/full + 301 #"Moved Permanently" + (current-seconds) TEXT/HTML-MIME-TYPE + (list (make-header #"Location" + #"http://racket-lang.org/downloads")) + (λ (op) + (write-bytes #"

" op) + (write-bytes #"Please go to here instead." op) + (write-bytes #"

" op))) + ] +} @defstruct[(response/incremental response/basic) ([generator ((() () #:rest (listof bytes?) . ->* . any) . -> . any)])]{ @@ -248,7 +270,7 @@ Here is an example typical of what you will find in many applications: ]} @defproc[(normalize-response [response response/c] [close? boolean? #f]) - (or/c response/full? response/incremental?)]{ + (or/c response/full? response/incremental? response/port?)]{ Coerces @racket[response] into a full response, filling in additional details where appropriate. @racket[close?] represents whether the connection will be closed after the response is sent (i.e. if HTTP 1.0 is being used.) The accuracy of this only matters if From ee2b11630f9d98be9c60e81890be23d04972ef4e Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 26 Nov 2010 19:47:43 -0500 Subject: [PATCH 152/255] Adding containers --- collects/tests/web-server/dispatch-test.rkt | 111 +++++++++++------- collects/web-server/dispatch.rkt | 6 +- collects/web-server/dispatch/container.rkt | 56 +++++++++ .../web-server/scribblings/dispatch.scrbl | 12 ++ 4 files changed, 138 insertions(+), 47 deletions(-) create mode 100644 collects/web-server/dispatch/container.rkt diff --git a/collects/tests/web-server/dispatch-test.rkt b/collects/tests/web-server/dispatch-test.rkt index 1bd4189869..6108839e20 100644 --- a/collects/tests/web-server/dispatch-test.rkt +++ b/collects/tests/web-server/dispatch-test.rkt @@ -10,7 +10,8 @@ web-server/dispatch/pattern web-server/dispatch/url-patterns web-server/dispatch/syntax - web-server/dispatch/serve) + web-server/dispatch/serve + web-server/dispatch/container) (provide all-dispatch-tests) (define (test-request url) @@ -308,52 +309,72 @@ (test-blog-dispatch/exn "http://www.example.com/archive/2008/post") (test-blog-dispatch/exn "http://www.example.com/foo")) - (local - [(define (list-posts req) `(list-posts)) - (define (review-post req p) `(review-post ,p)) - (define (review-archive req y m) `(review-archive ,y ,m)) - (define-values (blog-dispatch blog-url) - (dispatch-rules - [("") list-posts] - [() list-posts] - [("posts" (string-arg)) review-post] - [("archive" (integer-arg) (integer-arg)) review-archive])) - (define (test-blog-dispatch url res) - (test-equal? url (blog-dispatch (test-request (string->url url))) res)) - (define (test-blog-url url . args) - (test-equal? (format "~S" args) - (apply blog-url args) - url)) - (define (test-blog-url/exn . args) - (test-exn (format "~S" args) - exn? - (lambda () - (apply blog-url args)))) - (define (test-blog-dispatch/exn url) - (test-exn url exn:dispatcher? (lambda () (blog-dispatch (test-request (string->url url))))))] + (let () + (define (list-posts req) `(list-posts)) + (define (review-post req p) `(review-post ,p)) + (define (review-archive req y m) `(review-archive ,y ,m)) + + (define (make-dispatch-test-suite blog-dispatch blog-url) + (define (test-blog-dispatch url res) + (test-equal? url (blog-dispatch (test-request (string->url url))) res)) + (define (test-blog-url url . args) + (test-equal? (format "~S" args) + (apply blog-url args) + url)) + (define (test-blog-url/exn . args) + (test-exn (format "~S" args) + exn? + (lambda () + (apply blog-url args)))) + (define (test-blog-dispatch/exn url) + (test-exn url exn:dispatcher? (lambda () (blog-dispatch (test-request (string->url url)))))) + + (test-suite + "blog" + + (test-blog-dispatch "http://www.example.com" `(list-posts)) + (test-blog-dispatch "http://www.example.com/" `(list-posts)) + (test-blog-dispatch "http://www.example.com/posts/hello-world" `(review-post "hello-world")) + (test-blog-dispatch "http://www.example.com/archive/2008/02" `(review-archive 2008 02)) + (test-blog-dispatch/exn "http://www.example.com/posts") + (test-blog-dispatch/exn "http://www.example.com/archive/post/02") + (test-blog-dispatch/exn "http://www.example.com/archive/2008/post") + (test-blog-dispatch/exn "http://www.example.com/foo") + + (test-blog-url "/" list-posts) + (test-blog-url "/posts/hello-world" review-post "hello-world") + (test-blog-url "/archive/2008/2" review-archive 2008 02) + (test-blog-url/exn list-posts 50) + (test-blog-url/exn +) + (test-blog-url/exn review-post 50) + (test-blog-url/exn review-post "hello" "world") + (test-blog-url/exn review-archive 2008 02 1) + (test-blog-url/exn review-archive "2008" 02) + (test-blog-url/exn review-archive 2008 "02"))) (test-suite - "blog" + "dispatch" + (let () + (define-values (blog-dispatch blog-url) + (dispatch-rules + [("") list-posts] + [() list-posts] + [("posts" (string-arg)) review-post] + [("archive" (integer-arg) (integer-arg)) review-archive])) + (make-dispatch-test-suite blog-dispatch blog-url)) - (test-blog-dispatch "http://www.example.com" `(list-posts)) - (test-blog-dispatch "http://www.example.com/" `(list-posts)) - (test-blog-dispatch "http://www.example.com/posts/hello-world" `(review-post "hello-world")) - (test-blog-dispatch "http://www.example.com/archive/2008/02" `(review-archive 2008 02)) - (test-blog-dispatch/exn "http://www.example.com/posts") - (test-blog-dispatch/exn "http://www.example.com/archive/post/02") - (test-blog-dispatch/exn "http://www.example.com/archive/2008/post") - (test-blog-dispatch/exn "http://www.example.com/foo") - - (test-blog-url "/" list-posts) - (test-blog-url "/posts/hello-world" review-post "hello-world") - (test-blog-url "/archive/2008/2" review-archive 2008 02) - (test-blog-url/exn list-posts 50) - (test-blog-url/exn +) - (test-blog-url/exn review-post 50) - (test-blog-url/exn review-post "hello" "world") - (test-blog-url/exn review-archive 2008 02 1) - (test-blog-url/exn review-archive "2008" 02) - (test-blog-url/exn review-archive 2008 "02"))) + (let () + (define-container blog-container + (blog-dispatch blog-url)) + (dispatch-rules! blog-container + [("") list-posts]) + (dispatch-rules! blog-container + [() list-posts]) + (dispatch-rules! blog-container + [("posts" (string-arg)) review-post]) + (dispatch-rules! blog-container + [("archive" (integer-arg) (integer-arg)) review-archive]) + (make-dispatch-test-suite blog-dispatch blog-url)))) (local [(define (sum req as) (apply + as)) @@ -454,4 +475,4 @@ `(html (head (title "Sum")) (h1 ,(number->string (+ fst snd))))) - (serve/dispatch start)) + (serve/dispatch start)) \ No newline at end of file diff --git a/collects/web-server/dispatch.rkt b/collects/web-server/dispatch.rkt index 0ac1eb1000..6abdf49184 100644 --- a/collects/web-server/dispatch.rkt +++ b/collects/web-server/dispatch.rkt @@ -1,7 +1,9 @@ #lang racket (require web-server/dispatch/syntax web-server/dispatch/serve - web-server/dispatch/url-patterns) + web-server/dispatch/url-patterns + web-server/dispatch/container) (provide (all-from-out web-server/dispatch/syntax web-server/dispatch/serve - web-server/dispatch/url-patterns)) + web-server/dispatch/url-patterns + web-server/dispatch/container)) diff --git a/collects/web-server/dispatch/container.rkt b/collects/web-server/dispatch/container.rkt new file mode 100644 index 0000000000..2aa453760e --- /dev/null +++ b/collects/web-server/dispatch/container.rkt @@ -0,0 +1,56 @@ +#lang racket/base +(require web-server/dispatchers/dispatch + racket/list + racket/contract + racket/match + "syntax.rkt") + +(struct container (bunches) #:mutable) +(struct bunch (dispatch url)) + +(define (container-dispatch c) + (λ (req) + (let/ec esc + (for ([d*u (in-list (container-bunches c))]) + (with-handlers ([exn:dispatcher? void]) + (esc ((bunch-dispatch d*u) req)))) + (next-dispatcher)))) + +(define (container-url c) + (λ args + (let/ec esc + (for ([d*u (in-list (container-bunches c))]) + (with-handlers ([exn:misc:match? void]) + (esc (apply (bunch-url d*u) args)))) + (match args)))) + +(define-syntax-rule (define-container container-id (container-dispatch-id container-url-id)) + (begin + (define container-id + (container empty)) + (define container-dispatch-id + (container-dispatch container-id)) + (define container-url-id + (container-url container-id)))) + +(define (container-cons! c d u) + (set-container-bunches! + c + (cons (bunch d u) (container-bunches c)))) + +#;(define (snoc l x) (append l (list x))) +#;(define (container-snoc! c d u) + (set-container-bunches! + c + (snoc (container-bunches c) (bunch d u)))) + +(define-syntax-rule (dispatch-rules! container-expr [pat fun] ...) + (let-values ([(dispatch url) (dispatch-rules [pat fun] ...)]) + (container-cons! container-expr + dispatch url))) + +(provide + define-container + dispatch-rules!) +(provide/contract + [container? (any/c . -> . boolean?)]) diff --git a/collects/web-server/scribblings/dispatch.scrbl b/collects/web-server/scribblings/dispatch.scrbl index 35693a281c..ca2cdc3dca 100644 --- a/collects/web-server/scribblings/dispatch.scrbl +++ b/collects/web-server/scribblings/dispatch.scrbl @@ -165,6 +165,18 @@ After mastering the world of blogging software, you decide to put the ubiquitous Calls @racket[serve/servlet] with a @racket[#:servlet-regexp] argument (@racket[#rx""]) so that every request is handled by @racket[dispatch]. } +@section{Imperative Dispatch Containers} + +@racket[dispatch-rules] is purely functional. This presents a more declarative interface, but inhibits some programming and modularity patterns. @deftech{Containers} provide an imperative overlay atop @racket[dispatch-rules]. + +@defproc[(container? [x any/c]) boolean?]{ Identifies @tech{containers}. } + +@defform[(define-container container-id (dispatch-id url-id))]{ + Defines @racket[container-id] as a container as well as @racket[dispatch-id] as its dispatching function and @racket[url-id] as its URL lookup function.} + +@defform[(dispatch-rules! container-expr [dispatch-pattern dispatch-fun] ...)]{ + Like @racket[dispatch-rules], but imperatively adds the patterns to the container specified by @racket[container-expr]. The new rules are consulted @emph{before} any rules already in the container. } + @section{Built-in URL patterns} @racketmodname[web-server/dispatch] builds in a few useful URL component patterns. From bc9a5e4b4871dd0d74e55545a36cb8bf39e04d7a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 26 Nov 2010 19:31:48 -0600 Subject: [PATCH 153/255] plugged a leak in drracket (thanks to Matthew for finding it!) --- collects/planet/planet.scrbl | 23 ++++++++++++++++++----- collects/planet/terse-info.rkt | 23 +++++++++++++---------- 2 files changed, 31 insertions(+), 15 deletions(-) diff --git a/collects/planet/planet.scrbl b/collects/planet/planet.scrbl index 31d0e87e7c..fd3c4fee09 100644 --- a/collects/planet/planet.scrbl +++ b/collects/planet/planet.scrbl @@ -734,8 +734,11 @@ is saved in the namespace, making the listening and information producing namespace-specific. @defproc[(planet-terse-register - [proc (-> (or/c 'download 'install 'docs-build 'finish) string? any/c)] - [namespace namespace? (current-namespace)]) void?]{ + [proc (-> (or/c 'download 'install 'docs-build 'finish) + string? + any/c)] + [key symbol? (planet-terse-log-key-param)]) + void?]{ Registers @racket[proc] as a function to be called when @racket[planet-terse-log] is called with a matching namespace argument. Note that @racket[proc] is called @@ -744,9 +747,19 @@ asynchronously (ie, on some thread other than the one calling @racket[planet-ter @defproc[(planet-terse-log [id (or/c 'download 'install 'finish)] [msg string?] - [namespace namespace? (current-namespace)]) void?]{ - This function is called by PLaneT to announce when things are happening. -The namespace passed along is used to identify the procs to notify. + [key symbol? (planet-terse-log-key-param)]) void?]{ +This function is called by PLaneT to announce when things are happening. +The namespace passed along is used to identify the procs to notify. This function +invokes all of the callbacks registered with @racket[key], and when PLaneT invokes it, +the @racket[key] argument is always @racket[(planet-terse-log-key-param)]. +} + +@defparam[planet-terse-log-key-param key symbol?]{ + Holds the current value of the key used for getting and setting the @PLaneT logging information. +} + +@defproc[(planet-terse-set-key [key symbol?]) void?]{ + Equivalent to @racket[(planet-terse-log-key-param new-key)]. } @section{Developing Packages for PLaneT} diff --git a/collects/planet/terse-info.rkt b/collects/planet/terse-info.rkt index 6c0a212e41..51519fb078 100644 --- a/collects/planet/terse-info.rkt +++ b/collects/planet/terse-info.rkt @@ -12,13 +12,14 @@ seems little point to that). |# -(provide planet-terse-register +(provide planet-terse-register planet-terse-log - planet-terse-set-key) + planet-terse-set-key + planet-terse-log-key-param) (define terse-log-message-chan (make-channel)) (define terse-log-proc-chan (make-channel)) -(define terse-log-key-param (make-parameter (gensym))) +(define planet-terse-log-key-param (make-parameter (gensym))) (define thd (thread @@ -33,7 +34,7 @@ seems little point to that). [id (list-ref msg 1)] [str (list-ref msg 2)]) (for-each (lambda (eph) - (let ([proc (ephemeron-value eph)]) + (let ([proc (weak-box-value eph)]) (when proc (proc id str)))) (hash-ref procs registry '()))) @@ -45,15 +46,17 @@ seems little point to that). [proc (list-ref rp 1)]) (hash-update! procs registry - (lambda (x) (cons (make-ephemeron registry proc) x)) + (lambda (x) (cons (make-weak-box proc) x)) '()) (loop)))))))))) -(define (planet-terse-log id str [key (terse-log-key-param)]) - (sync (channel-put-evt terse-log-message-chan (list key id str)))) +(define (planet-terse-log id str [key (planet-terse-log-key-param)]) + (sync (channel-put-evt terse-log-message-chan (list key id str))) + (void)) -(define (planet-terse-register proc [key (terse-log-key-param)]) - (sync (channel-put-evt terse-log-proc-chan (list key proc)))) +(define (planet-terse-register proc [key (planet-terse-log-key-param)]) + (sync (channel-put-evt terse-log-proc-chan (list key proc))) + (void)) (define (planet-terse-set-key new-key) - (terse-log-key-param new-key)) + (planet-terse-log-key-param new-key)) From de9538d1eb3633e6a9bffc9766d4e8badf4b18e2 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Thu, 11 Nov 2010 21:59:41 -0700 Subject: [PATCH 154/255] macro-debugger: refine position of mouse events --- .../macro-debugger/syntax-browser/text.rkt | 29 +++++++++++-------- 1 file changed, 17 insertions(+), 12 deletions(-) diff --git a/collects/macro-debugger/syntax-browser/text.rkt b/collects/macro-debugger/syntax-browser/text.rkt index 7d005312bf..55796a5111 100644 --- a/collects/macro-debugger/syntax-browser/text.rkt +++ b/collects/macro-debugger/syntax-browser/text.rkt @@ -115,14 +115,16 @@ find-position) (define/override (on-default-event ev) - (define gx (send ev get-x)) - (define gy (send ev get-y)) - (define-values (x y) (dc-location-to-editor-location gx gy)) - (define pos (find-position x y)) (super on-default-event ev) (case (send ev get-event-type) ((enter motion leave) - (update-hover-position pos)))) + (define-values (x y) + (let ([gx (send ev get-x)] + [gy (send ev get-y)]) + (dc-location-to-editor-location gx gy))) + (define on-it? (box #f)) + (define pos (find-position x y #f on-it?)) + (update-hover-position (and (unbox on-it?) pos))))) (define/public (update-hover-position pos) (void)) @@ -344,10 +346,13 @@ Like clickbacks, but: (interval-map-remove! clickbacks start end))) (define/private (get-event-position ev) - (define gx (send ev get-x)) - (define gy (send ev get-y)) - (define-values (x y) (dc-location-to-editor-location gx gy)) - (find-position x y)) + (define-values (x y) + (let ([gx (send ev get-x)] + [gy (send ev get-y)]) + (dc-location-to-editor-location gx gy))) + (define on-it? (box #f)) + (define pos (find-position x y #f on-it?)) + (and (unbox on-it?) pos)) (define/override (on-default-event ev) (define admin (get-admin)) @@ -355,11 +360,11 @@ Like clickbacks, but: (define pos (get-event-position ev)) (case (send ev get-event-type) ((left-down) - (set! tracking (interval-map-ref clickbacks pos #f)) + (set! tracking (and pos (interval-map-ref clickbacks pos #f))) (send admin update-cursor)) ((left-up) (when tracking - (let ([cb (interval-map-ref clickbacks pos #f)] + (let ([cb (and pos (interval-map-ref clickbacks pos #f))] [tracking* tracking]) (set! tracking #f) (when (eq? tracking* cb) @@ -369,7 +374,7 @@ Like clickbacks, but: (define/override (adjust-cursor ev) (define pos (get-event-position ev)) - (define cb (interval-map-ref clickbacks pos #f)) + (define cb (and pos (interval-map-ref clickbacks pos #f))) (if cb arrow-cursor (super adjust-cursor ev))))) From c50ab191d68b4d6edfa8374e85099f4adfc46c2f Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 17 Nov 2010 11:49:57 -0700 Subject: [PATCH 155/255] fixed gvector typo --- collects/data/gvector.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/data/gvector.rkt b/collects/data/gvector.rkt index 837d7a2865..45a339d31d 100644 --- a/collects/data/gvector.rkt +++ b/collects/data/gvector.rkt @@ -137,7 +137,7 @@ [[(var ...) (in-gv gv-expr)] (with-syntax ([gv-expr-c (wrap-expr/c #'gvector? #'gv-expr #:macro #'in-gv)]) (syntax/loc stx - [(var ...) (in-vector gv-expr-c)]))] + [(var ...) (in-gvector gv-expr-c)]))] [_ #f]))) (define-syntax (for/gvector stx) From eb1c164aca02f575c5903d1e39382fefb8c7ee59 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 17 Nov 2010 13:25:15 -0700 Subject: [PATCH 156/255] macro-stepper: extra guard in on-demand id-only popup submenu --- collects/macro-debugger/syntax-browser/keymap.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/macro-debugger/syntax-browser/keymap.rkt b/collects/macro-debugger/syntax-browser/keymap.rkt index 6544f7d902..4949134b54 100644 --- a/collects/macro-debugger/syntax-browser/keymap.rkt +++ b/collects/macro-debugger/syntax-browser/keymap.rkt @@ -118,7 +118,7 @@ (demand-callback (lambda (i) (let ([stx (selected-syntax)]) - (when stx + (when (identifier? stx) (send i set-label (format "Format ~s ~a" (syntax-e stx) (cadr sym+desc))))))) (callback From 8605fecaf32d0739e9922c6c6d1c11599a220ac4 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 26 Nov 2010 19:05:40 -0700 Subject: [PATCH 157/255] syntax/parse: fixed bug in #:do (with expression) --- collects/syntax/parse/private/runtime.rkt | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/collects/syntax/parse/private/runtime.rkt b/collects/syntax/parse/private/runtime.rkt index 1648fbf6d5..fb1284e495 100644 --- a/collects/syntax/parse/private/runtime.rkt +++ b/collects/syntax/parse/private/runtime.rkt @@ -308,15 +308,15 @@ [(no-shadow e) (let ([ee (local-expand #'e (syntax-local-context) (kernel-form-identifier-list))]) - (syntax-case ee (begin define-values defines-syntaxes) + (syntax-case ee (begin define-values define-syntaxes) [(begin d ...) #'(begin (no-shadow d) ...)] [(define-values . _) - (check-shadow ee) - ee] + (begin (check-shadow ee) + ee)] [(define-syntaxes . _) - (check-shadow ee) - ee] + (begin (check-shadow ee) + ee)] [_ ee]))])) From e6cf77b61c4f262ea1b7405cfe62557d82da85bb Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 26 Nov 2010 19:09:29 -0700 Subject: [PATCH 158/255] macro-debugger: fixed image creator --- .../macro-debugger/syntax-browser/image.rkt | 9 +++---- .../macro-debugger/syntax-browser/text.rkt | 25 ++++++++++++++++++- .../macro-debugger/syntax-browser/widget.rkt | 23 ----------------- 3 files changed, 28 insertions(+), 29 deletions(-) diff --git a/collects/macro-debugger/syntax-browser/image.rkt b/collects/macro-debugger/syntax-browser/image.rkt index 1ecf6f788f..bcda3f65e7 100644 --- a/collects/macro-debugger/syntax-browser/image.rkt +++ b/collects/macro-debugger/syntax-browser/image.rkt @@ -5,7 +5,8 @@ framework "prefs.rkt" "controller.rkt" - "display.rkt") + "display.rkt" + "text.rkt") #| @@ -36,12 +37,10 @@ TODO: tacked arrows ;; print-syntax-columns : (parameter-of (U number 'infinity)) (define print-syntax-columns (make-parameter 40)) -(define standard-text% (text:foreground-color-mixin (editor:standard-style-list-mixin text:basic%))) - ;; print-syntax-to-png : syntax path -> void (define (print-syntax-to-png stx file #:columns [columns (print-syntax-columns)]) - (let ([bmp (print-syntax-to-bitmap stx columns)]) + (let ([bmp (print-syntax-to-bitmap stx #:columns columns)]) (send bmp save-file file 'png)) (void)) @@ -87,7 +86,7 @@ TODO: tacked arrows (send t print #f #f 'postscript #f #f #t))) (define (prepare-editor stx columns) - (define t (new standard-text%)) + (define t (new browser-text%)) (define sl (send t get-style-list)) (send t change-style (send sl find-named-style (editor:get-default-color-style-name))) (print-syntax-to-editor stx t diff --git a/collects/macro-debugger/syntax-browser/text.rkt b/collects/macro-debugger/syntax-browser/text.rkt index 55796a5111..334bac4976 100644 --- a/collects/macro-debugger/syntax-browser/text.rkt +++ b/collects/macro-debugger/syntax-browser/text.rkt @@ -17,7 +17,8 @@ text:tacking-mixin text:arrows-mixin text:region-data-mixin - text:clickregion-mixin) + text:clickregion-mixin + browser-text%) (define arrow-cursor (make-object cursor% 'arrow)) @@ -410,3 +411,25 @@ Like clickbacks, but: [else (search (cdr idlocs))]))) (super-new))) |# + + +(define browser-text% + (let ([browser-text-default-style-name "widget.rkt::browser-text% basic"]) + (class (text:clickregion-mixin + (text:arrows-mixin + (text:tacking-mixin + (text:hover-drawings-mixin + (text:hover-mixin + (text:region-data-mixin + (text:hide-caret/selection-mixin + (text:foreground-color-mixin + (editor:standard-style-list-mixin text:basic%))))))))) + (inherit set-autowrap-bitmap get-style-list) + (define/override (default-style-name) browser-text-default-style-name) + (super-new (auto-wrap #t)) + (let* ([sl (get-style-list)] + [standard (send sl find-named-style (editor:get-default-color-style-name))] + [browser-basic (send sl find-or-create-style standard + (make-object style-delta% 'change-family 'default))]) + (send sl new-named-style browser-text-default-style-name browser-basic)) + (set-autowrap-bitmap #f)))) diff --git a/collects/macro-debugger/syntax-browser/widget.rkt b/collects/macro-debugger/syntax-browser/widget.rkt index 93783f30f3..fbae429032 100644 --- a/collects/macro-debugger/syntax-browser/widget.rkt +++ b/collects/macro-debugger/syntax-browser/widget.rkt @@ -247,26 +247,3 @@ (send sd set-delta 'change-italic) (send sd set-delta-foreground "red") sd)) - -;; Specialized classes for widget - -(define browser-text% - (let ([browser-text-default-style-name "widget.rkt::browser-text% basic"]) - (class (text:clickregion-mixin - (text:arrows-mixin - (text:tacking-mixin - (text:hover-drawings-mixin - (text:hover-mixin - (text:region-data-mixin - (text:hide-caret/selection-mixin - (text:foreground-color-mixin - (editor:standard-style-list-mixin text:basic%))))))))) - (inherit set-autowrap-bitmap get-style-list) - (define/override (default-style-name) browser-text-default-style-name) - (super-new (auto-wrap #t)) - (let* ([sl (get-style-list)] - [standard (send sl find-named-style (editor:get-default-color-style-name))] - [browser-basic (send sl find-or-create-style standard - (make-object style-delta% 'change-family 'default))]) - (send sl new-named-style browser-text-default-style-name browser-basic)) - (set-autowrap-bitmap #f)))) From a45792ca1c9cb02913ef479116ce4d2f11dae0b0 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 26 Nov 2010 19:23:51 -0700 Subject: [PATCH 159/255] macro-stepper: dummy editor-admin for image creation --- collects/macro-debugger/syntax-browser/image.rkt | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/collects/macro-debugger/syntax-browser/image.rkt b/collects/macro-debugger/syntax-browser/image.rkt index bcda3f65e7..2a6e4e12e5 100644 --- a/collects/macro-debugger/syntax-browser/image.rkt +++ b/collects/macro-debugger/syntax-browser/image.rkt @@ -48,8 +48,8 @@ TODO: tacked arrows (define (print-syntax-to-bitmap stx #:columns [columns (print-syntax-columns)]) (define t (prepare-editor stx columns)) - (define f (new frame% [label "dummy"])) - (define ec (new editor-canvas% (editor t) (parent f))) + (define admin (new dummy-admin%)) + (send t set-admin admin) (define dc (new bitmap-dc% (bitmap (make-object bitmap% 1 1)))) (define char-width (let* ([sl (send t get-style-list)] @@ -93,3 +93,13 @@ TODO: tacked arrows (new controller%) (new syntax-prefs/readonly%) columns (send t last-position)) t) + +;; dummy editor-admin +(define dummy-admin% + (class editor-admin% + (define the-dc (new bitmap-dc% (bitmap (make-object bitmap% 1 1)))) + (define/override (get-dc [x #f] [y #f]) + (when x (set-box! x 0.0)) + (when y (set-box! y 0.0)) + the-dc) + (super-new))) From abcaa1775ca5aad50e87705100a1047bfc7b5e7c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 26 Nov 2010 17:20:24 -0700 Subject: [PATCH 160/255] add `width' and `height' arguments to post-script-dc% and pdf-dc% and document the change that the PS bounding box is no longer inferred from drawing operations --- .../racket/draw/private/post-script-dc.rkt | 42 +++++++++++++------ .../draw/post-script-dc-class.scrbl | 22 ++++++---- collects/tests/gracket/draw.rkt | 16 ++++++- collects/texpict/private/mrpict-extra.rkt | 2 + doc/release-notes/racket/Draw_and_GUI_5_1.txt | 14 +++++-- 5 files changed, 70 insertions(+), 26 deletions(-) diff --git a/collects/racket/draw/private/post-script-dc.rkt b/collects/racket/draw/private/post-script-dc.rkt index 449165002b..8d1257ee6c 100644 --- a/collects/racket/draw/private/post-script-dc.rkt +++ b/collects/racket/draw/private/post-script-dc.rkt @@ -23,12 +23,22 @@ [parent #f] [use-paper-bbox #f] [as-eps #t] + [(init-w width) #f] + [(init-h height) #f] [output #f]) - (unless (or (not output) - (path-string? output) - (output-port? output)) - (raise-type-error (init-name (if pdf? 'pdf-dc% 'post-script-dc%)) "path string, output port, or #f" output)) + (let ([get-name (lambda () + (init-name (if pdf? 'pdf-dc% 'post-script-dc%)))]) + (unless (or (not init-w) + (and (real? init-w) (not (negative? init-w)))) + (raise-type-error (get-name) "nonnegative real or #f" init-w)) + (unless (or (not init-h) + (and (real? init-h) (not (negative? init-h)))) + (raise-type-error (get-name) "nonnegative real or #f" init-h)) + (unless (or (not output) + (path-string? output) + (output-port? output)) + (raise-type-error (get-name) "path string, output port, or #f" output))) (define-values (s port-box close-port? width height landscape?) (let ([su (if interactive @@ -60,8 +70,12 @@ (not fn)) (values #f #f #f #f #f #f) (let* ([paper (assoc (send pss get-paper-name) paper-sizes)] - [w (cadr paper)] - [h (caddr paper)] + [w (if (or (not init-w) use-paper-bbox) + (cadr paper) + init-w)] + [h (if (or (not init-h) use-paper-bbox) + (caddr paper) + init-h)] [landscape? (eq? (send pss get-orientation) 'landscape)] [file (if (output-port? fn) fn @@ -91,17 +105,21 @@ (values #f #f #f #f #f #f)]))) (define-values (margin-x margin-y) - (let ([xb (box 0)] [yb (box 0.0)]) - (send (current-ps-setup) get-margin xb yb) - (values (unbox xb) (unbox yb)))) + (if as-eps + (values 0.0 0.0) + (let ([xb (box 0)] [yb (box 0.0)]) + (send (current-ps-setup) get-margin xb yb) + (values (unbox xb) (unbox yb))))) (define-values (scale-x scale-y) (let ([xb (box 0)] [yb (box 0.0)]) (send (current-ps-setup) get-scaling xb yb) (values (unbox xb) (unbox yb)))) (define-values (trans-x trans-y) - (let ([xb (box 0)] [yb (box 0.0)]) - (send (current-ps-setup) get-translation xb yb) - (values (unbox xb) (unbox yb)))) + (if as-eps + (values 0.0 0.0) + (let ([xb (box 0)] [yb (box 0.0)]) + (send (current-ps-setup) get-translation xb yb) + (values (unbox xb) (unbox yb))))) (unless pdf? (when (and s as-eps) diff --git a/collects/scribblings/draw/post-script-dc-class.scrbl b/collects/scribblings/draw/post-script-dc-class.scrbl index 721849ba07..0bc4a360f5 100644 --- a/collects/scribblings/draw/post-script-dc-class.scrbl +++ b/collects/scribblings/draw/post-script-dc-class.scrbl @@ -16,6 +16,8 @@ See also @scheme[printer-dc%]. [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) false/c) #f] [use-paper-bbox any/c #f] [as-eps any/c #t] + [width (or/c (and/c real? (not/c negative?)) #f) #f] + [height (or/c (and/c real? (not/c negative?)) #f) #f] [output (or/c path-string? output-port? #f) #f])]{ If @scheme[interactive] is true, the user is given a dialog for @@ -36,19 +38,21 @@ If @scheme[interactive] is @scheme[#f], then the settings returned by hit @onscreen{Cancel} in that case so that @method[dc<%> ok?] returns @scheme[#f]. If @scheme[use-paper-bbox] is @scheme[#f], then the PostScript - bounding box for the output is determined by drawing commands issued - to the object; such a bounding box encloses all parts of the drawing - @italic{ignoring} clipping regions (so the bounding box may be - approximate). If @scheme[use-paper-bbox] is not @scheme[#f], then the - bounding box is determined by the current paper size (as specified by - @scheme[current-ps-setup]), and the bounding box does not include the - margin (also specified by @scheme[current-ps-setup]). + bounding box for the output is determined by @racket[width] and + @racket[height]. If @scheme[use-paper-bbox] is not @scheme[#f], then + the bounding box is determined by the current paper size (as + specified by @scheme[current-ps-setup]). When @racket[width] or + @racket[height] is @racket[#f], then the corresponding dimension is + determined by the paper size, even if @racket[use-paper-bbox] is + @racket[#f]. @index["Encapsulated PostScript (EPS)"]{If} @scheme[as-eps] is @scheme[#f], then the generated PostScript does not include an Encapsulated PostScript (EPS) header, and instead includes a generic - PostScript header. Otherwise, the generated PostScript includes a - header that identifiers it as EPS. + PostScript header. The margin and translation factors specified by + @racket[current-ps-setup] are used only when @racket[as-eps] is + @racket[#f]. If @racket[as-eps] is true, then the generated + PostScript includes a header that identifiers it as EPS. When @racket[output] is not @racket[#f], then file-mode output is written to @racket[output]. If @racket[output] is @racket[#f], then diff --git a/collects/tests/gracket/draw.rkt b/collects/tests/gracket/draw.rkt index 882d0cb9a1..3d8158cb8b 100644 --- a/collects/tests/gracket/draw.rkt +++ b/collects/tests/gracket/draw.rkt @@ -953,8 +953,20 @@ (let ([dc (if kind (let ([dc (case kind [(print) (make-object printer-dc%)] - [(ps) (make-object post-script-dc%)] - [(pdf) (make-object pdf-dc%)])]) + [(ps pdf) + (let ([page? + (eq? 'yes (message-box + "Bounding Box" + "Use paper bounding box?" + #f + '(yes-no)))]) + (new (if (eq? kind 'ps) + post-script-dc% + pdf-dc%) + [width (* xscale DRAW-WIDTH)] + [height (* yscale DRAW-HEIGHT)] + [as-eps (not page?)] + [use-paper-bbox page?]))])]) (and (send dc ok?) dc)) (if (and use-bitmap?) (begin diff --git a/collects/texpict/private/mrpict-extra.rkt b/collects/texpict/private/mrpict-extra.rkt index dad3ec4b66..4d66afc4f3 100644 --- a/collects/texpict/private/mrpict-extra.rkt +++ b/collects/texpict/private/mrpict-extra.rkt @@ -459,6 +459,8 @@ (let ([dc (new (if (eq? format 'eps-bytes) post-script-dc% pdf-dc%) [interactive #f] [as-eps #t] + [width (pict-width p)] + [height (pict-height p)] [output s])]) (send dc start-doc "pict") (send dc start-page) diff --git a/doc/release-notes/racket/Draw_and_GUI_5_1.txt b/doc/release-notes/racket/Draw_and_GUI_5_1.txt index 4c1688c8d3..8e3b7069a2 100644 --- a/doc/release-notes/racket/Draw_and_GUI_5_1.txt +++ b/doc/release-notes/racket/Draw_and_GUI_5_1.txt @@ -95,6 +95,17 @@ backward-compatibile. Methods like `get-translation', `set-translation', `scale', etc. help hide the reundancy. +PostScript and PDF Drawing Contexts +----------------------------------- + +The dimensions for PostScript output are no longer inferred from the +drawing. Instead, the width and height must be supplied when the +`post-script-dc%' is created. + +The new `pdf-dc%' drawing context is like `post-script-dc%', but it +generates PDF output. + + Other Drawing-Context Changes ----------------------------- @@ -112,9 +123,6 @@ that it is installed as a clipping region. The old 'xor mode for pens and brushes is no longer available (since it is not supported by Cairo). -The new `pdf-dc%' drawing context is like `post-script-dc%', but it -generates PDF output. - Editor Changes -------------- From 0f86dc15afe6d0bf48a77f8aec7d66fda356082b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 26 Nov 2010 17:49:46 -0700 Subject: [PATCH 161/255] scribble: render `pict' content directly --- actually, any value that is convertible to PNG/PDF --- collects/scribble/base-render.rkt | 43 +++++++++++++++-------- collects/scribble/core.rkt | 6 ++-- collects/scribble/html-render.rkt | 10 ++++++ collects/scribble/latex-render.rkt | 35 +++++++++++------- collects/scribblings/scribble/core.scrbl | 5 +-- collects/texpict/private/mrpict-extra.rkt | 4 ++- 6 files changed, 70 insertions(+), 33 deletions(-) diff --git a/collects/scribble/base-render.rkt b/collects/scribble/base-render.rkt index 2a5cace603..8dd56c063a 100644 --- a/collects/scribble/base-render.rkt +++ b/collects/scribble/base-render.rkt @@ -8,6 +8,7 @@ scheme/path setup/main-collects setup/path-relativize + file/convertible "render-struct.ss") (provide render%) @@ -677,6 +678,7 @@ (render-content (traverse-element-content i ri) part ri)] [(part-relative-element? i) (render-content (part-relative-element-content i ri) part ri)] + [(convertible? i) (list "???")] [else (render-other i part ri)])) (define/public (render-other i part ri) @@ -687,13 +689,15 @@ (define copied-srcs (make-hash)) (define copied-dests (make-hash)) - (define/public (install-file fn) - (if refer-to-existing-files + (define/public (install-file fn [content #f]) + (if (and refer-to-existing-files + (not content)) (if (string? fn) (string->path fn) fn) (let ([normalized (normal-case-path (simplify-path (path->complete-path fn)))]) - (or (hash-ref copied-srcs normalized #f) + (or (and (not content) + (hash-ref copied-srcs normalized #f)) (let ([src-dir (path-only fn)] [dest-dir (get-dest-directory #t)] [fn (file-name-from-path fn)]) @@ -715,22 +719,26 @@ (let-values ([(dest-file normalized-dest-file) (let loop ([dest-file dest-file]) (let ([normalized-dest-file - (normal-case-path (simplify-path (path->complete-path dest-file)))]) - (if (file-exists? dest-file) - (cond - [(call-with-input-file* - src-file - (lambda (src) - (call-with-input-file* + (normal-case-path (simplify-path (path->complete-path dest-file)))] + [check-same + (lambda (src) + (call-with-input-file* dest-file (lambda (dest) - (or (equal? (port-file-identity src) - (port-file-identity dest)) + (or (and (not content) + (equal? (port-file-identity src) + (port-file-identity dest))) (let loop () (let ([s (read-bytes 4096 src)] [d (read-bytes 4096 dest)]) (and (equal? s d) - (or (eof-object? s) (loop)))))))))) + (or (eof-object? s) (loop)))))))))]) + (if (file-exists? dest-file) + (cond + [(or (and content + (check-same (open-input-bytes content))) + (and (not content) + (call-with-input-file* src-file check-same))) ;; same content at that destination (values dest-file normalized-dest-file)] [(hash-ref copied-dests normalized-dest-file #f) @@ -743,10 +751,15 @@ ;; new file (values dest-file normalized-dest-file))))]) (unless (file-exists? dest-file) - (copy-file src-file dest-file)) + (if content + (call-with-output-file* + dest-file + (lambda (dest) (write-bytes content dest))) + (copy-file src-file dest-file))) (hash-set! copied-dests normalized-dest-file #t) (let ([result (path->string (file-name-from-path dest-file))]) - (hash-set! copied-srcs normalized result) + (unless content + (hash-set! copied-srcs normalized result)) result)))))))) ;; ---------------------------------------- diff --git a/collects/scribble/core.rkt b/collects/scribble/core.rkt index aa68a42f72..6e71a8ce0f 100644 --- a/collects/scribble/core.rkt +++ b/collects/scribble/core.rkt @@ -1,7 +1,8 @@ #lang scheme/base (require "private/provide-structs.ss" scheme/serialize - scheme/contract) + scheme/contract + file/convertible) ;; ---------------------------------------- @@ -119,7 +120,8 @@ (traverse-element? v) (part-relative-element? v) (multiarg-element? v) - (hash-ref content-symbols v #f))) + (hash-ref content-symbols v #f) + (convertible? v))) (provide element-style?) (define (element-style? s) diff --git a/collects/scribble/html-render.rkt b/collects/scribble/html-render.rkt index c31021c900..412b4c34fd 100644 --- a/collects/scribble/html-render.rkt +++ b/collects/scribble/html-render.rkt @@ -9,6 +9,7 @@ scheme/port scheme/list scheme/string + file/convertible mzlib/runtime-path setup/main-doc setup/main-collects @@ -947,6 +948,15 @@ (cond [(string? e) (super render-content e part ri)] ; short-cut for common case [(list? e) (super render-content e part ri)] ; also a short-cut + [(and (convertible? e) + (convert e 'png-bytes)) + => (lambda (bstr) + (let ([w (integer-bytes->integer (subbytes bstr 16 20) #f #t)] + [h (integer-bytes->integer (subbytes bstr 20 24) #f #t)]) + `((img ([src ,(install-file "pict.png" bstr)] + [alt "image"] + [width ,(number->string w)] + [height ,(number->string h)])))))] [(image-element? e) (let* ([src (main-collects-relative->path (image-element-path e))] [suffixes (image-element-suffixes e)] diff --git a/collects/scribble/latex-render.rkt b/collects/scribble/latex-render.rkt index a8b2ae95c6..459deac0d5 100644 --- a/collects/scribble/latex-render.rkt +++ b/collects/scribble/latex-render.rkt @@ -9,7 +9,8 @@ scheme/path scheme/string scheme/list - setup/main-collects) + setup/main-collects + file/convertible) (provide render-mixin) (define current-table-mode (make-parameter #f)) @@ -235,18 +236,26 @@ es)] [style (and (style? es) es)] [core-render (lambda (e tt?) - (if (and (image-element? e) - (not (disable-images))) - (let ([fn (install-file - (select-suffix - (main-collects-relative->path - (image-element-path e)) - (image-element-suffixes e) - '(".pdf" ".ps" ".png")))]) - (printf "\\includegraphics[scale=~a]{~a}" - (image-element-scale e) fn)) - (parameterize ([rendering-tt (or tt? (rendering-tt))]) - (super render-content e part ri))))] + (cond + [(and (image-element? e) + (not (disable-images))) + (let ([fn (install-file + (select-suffix + (main-collects-relative->path + (image-element-path e)) + (image-element-suffixes e) + '(".pdf" ".ps" ".png")))]) + (printf "\\includegraphics[scale=~a]{~a}" + (image-element-scale e) fn))] + [(and (convertible? e) + (not (disable-images)) + (convert e 'pdf-bytes)) + => (lambda (bstr) + (let ([fn (install-file "pict.pdf" bstr)]) + (printf "\\includegraphics{~a}" fn)))] + [else + (parameterize ([rendering-tt (or tt? (rendering-tt))]) + (super render-content e part ri))]))] [wrap (lambda (e s tt?) (printf "\\~a{" s) (core-render e tt?) diff --git a/collects/scribblings/scribble/core.scrbl b/collects/scribblings/scribble/core.scrbl index bf9b3aec56..a64b56de2f 100644 --- a/collects/scribblings/scribble/core.scrbl +++ b/collects/scribblings/scribble/core.scrbl @@ -943,8 +943,9 @@ otherwise.} Returns @racket[#t] if @racket[v] is a string, symbol, @racket[element], @racket[multiarg-element], @racket[traverse-element], @racket[delayed-element], -@racket[part-relative-element], or list of @tech{content}, @racket[#f] -otherwise.} +@racket[part-relative-element], a convertible value in +the sense of @racket[convertible?], or list of @tech{content}. +Otherwise, it returns @racket[#f].} @defstruct[style ([name (or/c string? symbol? #f)] diff --git a/collects/texpict/private/mrpict-extra.rkt b/collects/texpict/private/mrpict-extra.rkt index 4d66afc4f3..11b821d32f 100644 --- a/collects/texpict/private/mrpict-extra.rkt +++ b/collects/texpict/private/mrpict-extra.rkt @@ -447,8 +447,10 @@ (define (convert-pict p format default) (case format [(png-bytes) - (let* ([bm (make-bitmap (max 1 (pict-width p)) (max 1 (pict-height p)))] + (let* ([bm (make-bitmap (max 1 (inexact->exact (ceiling (pict-width p)))) + (max 1 (inexact->exact (ceiling (pict-height p)))))] [dc (make-object bitmap-dc% bm)]) + (send dc set-smoothing 'aligned) (draw-pict p dc 0 0) (send dc set-bitmap #f) (let ([s (open-output-bytes)]) From 5d386a99ec8121261fd61d61da9e5ac69a217488 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 26 Nov 2010 19:13:03 -0700 Subject: [PATCH 162/255] fixes to make pict eval results work in Scribble --- collects/scribble/eval.rkt | 10 +++++++++- collects/scribble/racket.rkt | 4 +++- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/collects/scribble/eval.rkt b/collects/scribble/eval.rkt index 180fabb1f7..e204f0cb17 100644 --- a/collects/scribble/eval.rkt +++ b/collects/scribble/eval.rkt @@ -8,6 +8,7 @@ racket/sandbox racket/promise racket/string + file/convertible (for-syntax racket/base)) (provide interaction @@ -38,6 +39,8 @@ (define maxlen 60) + (define-namespace-anchor anchor) + (namespace-require 'racket/base) (namespace-require '(for-syntax racket/base)) @@ -270,7 +273,12 @@ (parameterize ([sandbox-output 'string] [sandbox-error-output 'string] [sandbox-propagate-breaks #f]) - (make-evaluator '(begin)))))) + (let ([e (make-evaluator '(begin))]) + (let ([ns (namespace-anchor->namespace anchor)]) + (call-in-sandbox-context e + (lambda () + (namespace-attach-module ns 'file/convertible)))) + e))))) (define (make-base-eval-factory mod-paths) (let ([ns (delay (let ([ns (make-base-empty-namespace)]) diff --git a/collects/scribble/racket.rkt b/collects/scribble/racket.rkt index 62ef079876..0636420895 100644 --- a/collects/scribble/racket.rkt +++ b/collects/scribble/racket.rkt @@ -8,6 +8,7 @@ mzlib/for syntax/modresolve syntax/modcode + file/convertible (for-syntax racket/base)) (provide define-code @@ -215,7 +216,8 @@ quote-depth)]) (if (or (element? (syntax-e c)) (delayed-element? (syntax-e c)) - (part-relative-element? (syntax-e c))) + (part-relative-element? (syntax-e c)) + (convertible? (syntax-e c))) (out (syntax-e c) #f) (out (if (and (identifier? c) color? From cb3a48ab2b27501ff96996cbdbff5eaf2f2b3f47 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 26 Nov 2010 20:40:09 -0700 Subject: [PATCH 163/255] convert "quick" document to mostly use picts directly in examples --- collects/scribblings/quick/images/exprs.dat | 84 ++------------------ collects/scribblings/quick/images/img0.pdf | Bin 2520 -> 4396 bytes collects/scribblings/quick/images/img0.png | Bin 186 -> 3538 bytes collects/scribblings/quick/images/img1.pdf | Bin 2474 -> 4395 bytes collects/scribblings/quick/images/img1.png | Bin 93 -> 3764 bytes collects/scribblings/quick/images/img10.pdf | 80 ------------------- collects/scribblings/quick/images/img10.png | Bin 611 -> 0 bytes collects/scribblings/quick/images/img11.pdf | Bin 2507 -> 0 bytes collects/scribblings/quick/images/img11.png | Bin 139 -> 0 bytes collects/scribblings/quick/images/img12.pdf | Bin 3655 -> 0 bytes collects/scribblings/quick/images/img12.png | Bin 718 -> 0 bytes collects/scribblings/quick/images/img13.pdf | Bin 2851 -> 0 bytes collects/scribblings/quick/images/img13.png | Bin 1109 -> 0 bytes collects/scribblings/quick/images/img14.pdf | 80 ------------------- collects/scribblings/quick/images/img14.png | Bin 233 -> 0 bytes collects/scribblings/quick/images/img15.pdf | Bin 2843 -> 0 bytes collects/scribblings/quick/images/img15.png | Bin 1208 -> 0 bytes collects/scribblings/quick/images/img16.pdf | 80 ------------------- collects/scribblings/quick/images/img16.png | Bin 212 -> 0 bytes collects/scribblings/quick/images/img17.pdf | Bin 2520 -> 0 bytes collects/scribblings/quick/images/img17.png | Bin 186 -> 0 bytes collects/scribblings/quick/images/img18.pdf | Bin 2474 -> 0 bytes collects/scribblings/quick/images/img18.png | Bin 70 -> 0 bytes collects/scribblings/quick/images/img19.pdf | Bin 2473 -> 0 bytes collects/scribblings/quick/images/img19.png | Bin 74 -> 0 bytes collects/scribblings/quick/images/img2.pdf | Bin 2537 -> 2405 bytes collects/scribblings/quick/images/img2.png | Bin 259 -> 4870 bytes collects/scribblings/quick/images/img20.pdf | Bin 2482 -> 0 bytes collects/scribblings/quick/images/img20.png | Bin 76 -> 0 bytes collects/scribblings/quick/images/img21.pdf | Bin 2475 -> 0 bytes collects/scribblings/quick/images/img21.png | Bin 76 -> 0 bytes collects/scribblings/quick/images/img22.pdf | Bin 2476 -> 0 bytes collects/scribblings/quick/images/img22.png | Bin 76 -> 0 bytes collects/scribblings/quick/images/img23.pdf | Bin 2475 -> 0 bytes collects/scribblings/quick/images/img23.png | Bin 77 -> 0 bytes collects/scribblings/quick/images/img24.pdf | Bin 2497 -> 0 bytes collects/scribblings/quick/images/img24.png | Bin 77 -> 0 bytes collects/scribblings/quick/images/img25.pdf | 81 ------------------- collects/scribblings/quick/images/img25.png | Bin 102 -> 0 bytes collects/scribblings/quick/images/img26.pdf | 80 ------------------- collects/scribblings/quick/images/img26.png | Bin 596 -> 0 bytes collects/scribblings/quick/images/img27.pdf | Bin 4535 -> 0 bytes collects/scribblings/quick/images/img27.png | Bin 3493 -> 0 bytes collects/scribblings/quick/images/img28.pdf | Bin 4599 -> 0 bytes collects/scribblings/quick/images/img28.png | Bin 3711 -> 0 bytes collects/scribblings/quick/images/img29.pdf | Bin 12588 -> 0 bytes collects/scribblings/quick/images/img29.png | Bin 4865 -> 0 bytes collects/scribblings/quick/images/img3.pdf | Bin 2474 -> 0 bytes collects/scribblings/quick/images/img3.png | Bin 93 -> 0 bytes collects/scribblings/quick/images/img4.pdf | 82 ------------------- collects/scribblings/quick/images/img4.png | Bin 259 -> 0 bytes collects/scribblings/quick/images/img5.pdf | Bin 2578 -> 0 bytes collects/scribblings/quick/images/img5.png | Bin 343 -> 0 bytes collects/scribblings/quick/images/img6.pdf | Bin 2474 -> 0 bytes collects/scribblings/quick/images/img6.png | Bin 70 -> 0 bytes collects/scribblings/quick/images/img7.pdf | Bin 2623 -> 0 bytes collects/scribblings/quick/images/img7.png | Bin 229 -> 0 bytes collects/scribblings/quick/images/img8.pdf | Bin 2502 -> 0 bytes collects/scribblings/quick/images/img8.png | Bin 97 -> 0 bytes collects/scribblings/quick/images/img9.pdf | Bin 2852 -> 0 bytes collects/scribblings/quick/images/img9.png | Bin 200 -> 0 bytes collects/scribblings/quick/mreval.rkt | 25 +++++- collects/scribblings/quick/quick.scrbl | 51 ++++++------ 63 files changed, 54 insertions(+), 589 deletions(-) delete mode 100644 collects/scribblings/quick/images/img10.pdf delete mode 100644 collects/scribblings/quick/images/img10.png delete mode 100644 collects/scribblings/quick/images/img11.pdf delete mode 100644 collects/scribblings/quick/images/img11.png delete mode 100644 collects/scribblings/quick/images/img12.pdf delete mode 100644 collects/scribblings/quick/images/img12.png delete mode 100644 collects/scribblings/quick/images/img13.pdf delete mode 100644 collects/scribblings/quick/images/img13.png delete mode 100644 collects/scribblings/quick/images/img14.pdf delete mode 100644 collects/scribblings/quick/images/img14.png delete mode 100644 collects/scribblings/quick/images/img15.pdf delete mode 100644 collects/scribblings/quick/images/img15.png delete mode 100644 collects/scribblings/quick/images/img16.pdf delete mode 100644 collects/scribblings/quick/images/img16.png delete mode 100644 collects/scribblings/quick/images/img17.pdf delete mode 100644 collects/scribblings/quick/images/img17.png delete mode 100644 collects/scribblings/quick/images/img18.pdf delete mode 100644 collects/scribblings/quick/images/img18.png delete mode 100644 collects/scribblings/quick/images/img19.pdf delete mode 100644 collects/scribblings/quick/images/img19.png delete mode 100644 collects/scribblings/quick/images/img20.pdf delete mode 100644 collects/scribblings/quick/images/img20.png delete mode 100644 collects/scribblings/quick/images/img21.pdf delete mode 100644 collects/scribblings/quick/images/img21.png delete mode 100644 collects/scribblings/quick/images/img22.pdf delete mode 100644 collects/scribblings/quick/images/img22.png delete mode 100644 collects/scribblings/quick/images/img23.pdf delete mode 100644 collects/scribblings/quick/images/img23.png delete mode 100644 collects/scribblings/quick/images/img24.pdf delete mode 100644 collects/scribblings/quick/images/img24.png delete mode 100644 collects/scribblings/quick/images/img25.pdf delete mode 100644 collects/scribblings/quick/images/img25.png delete mode 100644 collects/scribblings/quick/images/img26.pdf delete mode 100644 collects/scribblings/quick/images/img26.png delete mode 100644 collects/scribblings/quick/images/img27.pdf delete mode 100644 collects/scribblings/quick/images/img27.png delete mode 100644 collects/scribblings/quick/images/img28.pdf delete mode 100644 collects/scribblings/quick/images/img28.png delete mode 100644 collects/scribblings/quick/images/img29.pdf delete mode 100644 collects/scribblings/quick/images/img29.png delete mode 100644 collects/scribblings/quick/images/img3.pdf delete mode 100644 collects/scribblings/quick/images/img3.png delete mode 100644 collects/scribblings/quick/images/img4.pdf delete mode 100644 collects/scribblings/quick/images/img4.png delete mode 100644 collects/scribblings/quick/images/img5.pdf delete mode 100644 collects/scribblings/quick/images/img5.png delete mode 100644 collects/scribblings/quick/images/img6.pdf delete mode 100644 collects/scribblings/quick/images/img6.png delete mode 100644 collects/scribblings/quick/images/img7.pdf delete mode 100644 collects/scribblings/quick/images/img7.png delete mode 100644 collects/scribblings/quick/images/img8.pdf delete mode 100644 collects/scribblings/quick/images/img8.png delete mode 100644 collects/scribblings/quick/images/img9.pdf delete mode 100644 collects/scribblings/quick/images/img9.png diff --git a/collects/scribblings/quick/images/exprs.dat b/collects/scribblings/quick/images/exprs.dat index cb78daca61..5df01e094d 100644 --- a/collects/scribblings/quick/images/exprs.dat +++ b/collects/scribblings/quick/images/exprs.dat @@ -1,89 +1,15 @@ -((2) 0 () 0 () () 5) -((2) 0 () 0 () () 5) -((2) 0 () 0 () () (c begin c "art gallery")) -((2) 0 () 0 () () "art gallery") -((2) 0 () 0 () () (c circle c 10)) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img0") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c rectangle c 10 c 20)) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img1") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c circle c 10 c 20)) -((2) 1 (((lib "scriblib/private/gui-eval-exn.rkt") . deserialize-info:gui-exn-v0)) 0 () () (0 "procedure circle: expects 1 argument, given 2: 10 20")) -((2) 0 () 0 () () (c hc-append c (c circle c 10) c (c rectangle c 10 c 20))) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img2") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c define c c c (c circle c 10))) -((2) 0 () 0 () () (void)) -((2) 0 () 0 () () (c define c r c (c rectangle c 10 c 20))) -((2) 0 () 0 () () (void)) -((2) 0 () 0 () () r) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img3") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c hc-append c c c r)) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img4") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c hc-append c 20 c c c r c c)) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img5") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c define c (c square c n) c (c filled-rectangle c n c n))) -((2) 0 () 0 () () (void)) -((2) 0 () 0 () () (c square c 10)) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img6") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c define c (c four c p) c (c define c two-p c (c hc-append c p c p)) c (c vc-append c two-p c two-p))) -((2) 0 () 0 () () (void)) -((2) 0 () 0 () () (c four c (c circle c 10))) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img7") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c define c (c checker c p1 c p2) c (c let c (c (c p12 c (c hc-append c p1 c p2)) c (c p21 c (c hc-append c p2 c p1))) c (c vc-append c p12 c p21)))) -((2) 0 () 0 () () (void)) -((2) 0 () 0 () () (c checker c (c colorize c (c square c 10) c "red") c (c colorize c (c square c 10) c "black"))) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img8") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c define c (c checkerboard c p) c (c let* c (c (c rp c (c colorize c p c "red")) c (c bp c (c colorize c p c "black")) c (c c c (c checker c rp c bp)) c (c c4 c (c four c c))) c (c four c c4)))) -((2) 0 () 0 () () (void)) -((2) 0 () 0 () () (c checkerboard c (c square c 10))) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img9") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () circle) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:element-v0)) 0 () () (0 #f (c (u . "#")))) -((2) 0 () 0 () () (c define c (c series c mk) c (c hc-append c 4 c (c mk c 5) c (c mk c 10) c (c mk c 20)))) -((2) 0 () 0 () () (void)) -((2) 0 () 0 () () (c series c circle)) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img10") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c series c square)) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img11") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c series c (c lambda c (c size) c (c checkerboard c (c square c size))))) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img12") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c define c (c rgb-series c mk) c (c vc-append c (c series c (c lambda c (c sz) c (c colorize c (c mk c sz) c "red"))) c (c series c (c lambda c (c sz) c (c colorize c (c mk c sz) c "green"))) c (c series c (c lambda c (c sz) c (c colorize c (c mk c sz) c "blue")))))) -((2) 0 () 0 () () (void)) -((2) 0 () 0 () () (c rgb-series c circle)) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img13") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c rgb-series c square)) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img14") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c define c (c rgb-maker c mk) c (c lambda c (c sz) c (c vc-append c (c colorize c (c mk c sz) c "red") c (c colorize c (c mk c sz) c "green") c (c colorize c (c mk c sz) c "blue"))))) -((2) 0 () 0 () () (void)) -((2) 0 () 0 () () (c series c (c rgb-maker c circle))) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img15") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c series c (c rgb-maker c square))) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img16") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c list c "red" c "green" c "blue")) -((2) 0 () 0 () () (c "red" c "green" c "blue")) -((2) 0 () 0 () () (c list c (c circle c 10) c (c square c 10))) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 2 ("[image]" (c ".pdf" c ".png")) () (c (0 #f (c (? . 0)) (u . "images/img17") (? . 1) 1.0) c (0 #f (c (? . 0)) (u . "images/img18") (? . 1) 1.0))) -((2) 0 () 0 () () (c define c (c rainbow c p) c (c map c (c lambda c (c color) c (c colorize c p c color)) c (c list c "red" c "orange" c "yellow" c "green" c "blue" c "purple")))) -((2) 0 () 0 () () (void)) -((2) 0 () 0 () () (c rainbow c (c square c 5))) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 2 ("[image]" (c ".pdf" c ".png")) () (c (0 #f (c (? . 0)) (u . "images/img19") (? . 1) 1.0) c (0 #f (c (? . 0)) (u . "images/img20") (? . 1) 1.0) c (0 #f (c (? . 0)) (u . "images/img21") (? . 1) 1.0) c (0 #f (c (? . 0)) (u . "images/img22") (? . 1) 1.0) c (0 #f (c (? . 0)) (u . "images/img23") (? . 1) 1.0) c (0 #f (c (? . 0)) (u . "images/img24") (? . 1) 1.0))) -((2) 0 () 0 () () (c apply c vc-append c (c rainbow c (c square c 5)))) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img25") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c require c slideshow/flash)) -((2) 0 () 0 () () (void)) -((2) 0 () 0 () () (c filled-flash c 40 c 30)) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img26") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c require c (c planet c "random.rkt" c (c "schematics" c "random.plt" c 1 c 0)))) +((2) 0 () 0 () () (c require c (c planet c schematics/random:1:0/random))) ((2) 0 () 0 () () (void)) ((2) 0 () 0 () () (c random-gaussian)) ((2) 0 () 0 () () 0.7386912134436788) ((2) 0 () 0 () () (c require c slideshow/code)) ((2) 0 () 0 () () (void)) ((2) 0 () 0 () () (c code c (c circle c 10))) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img27") (c ".pdf" c ".png") 1.0)) +((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img0") (c ".pdf" c ".png") 1.0)) ((2) 0 () 0 () () (c define-syntax c pict+code c (c syntax-rules c () c (c (c pict+code c expr) c (c hc-append c 10 c expr c (c code c expr)))))) ((2) 0 () 0 () () (void)) ((2) 0 () 0 () () (c pict+code c (c circle c 10))) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img28") (c ".pdf" c ".png") 1.0)) +((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img1") (c ".pdf" c ".png") 1.0)) ((2) 0 () 0 () () (c require c racket/class c racket/gui/base)) ((2) 0 () 0 () () (void)) ((2) 0 () 0 () () (c define c f c (c new c frame% c (c label c "My Art") c (c width c 300) c (c height c 300) c (c alignment c (c quote c (c center c center)))))) @@ -97,6 +23,6 @@ ((2) 0 () 0 () () (c add-drawing c (c pict+code c (c circle c 10)))) ((2) 1 (((lib "scribble/core.rkt") . deserialize-info:element-v0)) 0 () () (0 #f (c (u . "#(struct:object:canvas% ...)")))) ((2) 0 () 0 () () (c add-drawing c (c colorize c (c filled-flash c 50 c 30) c "yellow"))) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:element-v0)) 0 () () (0 #f (c (u . "#(struct:object:canvas% ...)")))) +((2) 1 (((lib "scriblib/private/gui-eval-exn.rkt") . deserialize-info:gui-exn-v0)) 0 () () (0 "reference to undefined identifier: filled-flash")) ((2) 0 () 0 () () (c scale c (c bitmap c (c build-path c (c collection-path c "scribblings/quick") c "art.png")) c 0.5)) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img29") (c ".pdf" c ".png") 1.0)) +((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img2") (c ".pdf" c ".png") 1.0)) diff --git a/collects/scribblings/quick/images/img0.pdf b/collects/scribblings/quick/images/img0.pdf index 25438957a6c3f594c53545fc720602456fdefd2a..4d8e7d9496a5af9dade7b93be0d1309fea41eace 100644 GIT binary patch literal 4396 zcmb^#X;c&E_Pirj8J|xOJz9(PbHTu~VP>+Dm;?zBLxBPSdw|A${0h(iz9X!t z8Wcx(x|g3f@KIvZ&KL<;m#GRpT>N8}ySaT*kQSTzoO(D=J?*PVqZgWduW4TJnfv>0 zl?=YNdia|M6qh!;t(B)PKfc_f^o)4wt>~8ihV+tg4ih z9&OCM7(1m}eTd8zV5ehK?Wbj_gNcocCi+Us53YIK!QSxX+9%PU@`+hDXI|QE{f#th zod&@-#tDq+%wJq2LYyF8kAKu@RuYXQ^dzbzwFW|Nv4c1aUgIJz;0WUpct??D8gLm0 zBB+YASyCtsX@jnfq%4{!l8!^6^8u!D{Y~Gh#_~l!f^v#X`pO$U?M>Q91SO& zuOf7gK}#pv;(!3d{_2;BkQwH^!K??k!z*Z1N&?L!0pmDmXIC^Fx4nGYO@}hNcQJvo z%>ibcq5B+U(CJ8+F)&5q5FFLR9}cSLqIw>x=c9T7su!YqKU6P@?-9k=*;^9hm>xGc zY>yyJWPe}DVYW#fDy;0rlGz!SzZ#jUpi9)bqgG)(3~AWS;KI-NA=6P-tfJ9EcS zB4{Yg6@wYHw;sAd<0Q5!n`?6UwG1z=78z}I~t8! zTW^_F{|K>6J!HAr@vN@>?a(7bZTz;B^kFZCzu?4&oRquGFH`J}-6d3;z&W?H z4<%t4@@3C+p0AaJe7K5L?JW;Ex@zHV*C*Q}sx6nle{(xtW%g;`SD3TjePDq#gP+0Q z^yyJtlI!U{FnM|dISC93j-Hq1zi3`y_^FU_3wU40d8ZD!mZ{^pD!<*LwG}6SJ-%rO zcV7Kaj%Ve;_WVH^`w8J+kyl#UE20&cH4!YA8f0s^tf4%eEtUdueBxRB?q_c^}4!D(e!)lI}4v&70oI4NjZb8 zJb9C7epK8bJ$&3X+cj(-`+6=(9nIXkNH!Jsm>a2&rtcIixl&wvYHZ6_&)$|^pTF?r zSGBd3)X%`9wQPw0_w%{avjYDacIiiYd`Vtugx9E*TlQx*FAr-8e)gGW+li4`D<)-S zJwBN48+5mE{rDA`WurGWeOol^*oVZL>J4VMG3r}Sir0L3cCq5!jT7<1M?6QwEUk~X zHsrfr$X^rXUNraf;hD!0!SI~GpCUh5voOTi|7u$ttt<;NB)5x2RE%%#F z%QNaPoEvsD>i~C0*@k&K>(+Q-SJ?>eqD(Y#_Wl4SIc9+>R zx2|TLR7;5VJFC=BgI-*4@hTd1Ja%cKZUq%A|I+Q>lV^RmG?x7<^?1FzW$t<9`=dvm z-_bDGe{JaP=c0T2m3LQYGBY<1Y1i zn8RugJ*LPTwRcs-w`DaKm77}!?$9@=%iUAIFMHJuErN0tT&= zHHWXnl-58p(J(!oBBRnH)SC1pjY!M#mmv~=0?r~N+fG>7I>!)Z1F!{4Cj_d(6%!Z) zyV!2Bn&9^t*iA;WO>CF493*1+&VW%CaG=mhQdW#I63`ZlG08v!j<3iUXXD&=fR2LS zh*S%e1aMyg3$moNIl*3^|47M%J zOcQpt*)|c%b0}hn=_WJVd>uOZYAhzy5QE~r7}_PM>w9Iem;oc0NU)^PQWjUM;o>|$ z4x5YXcx)Ue6WADh*a4$5&Bw2fD*hdt+fU>yI1@KJ_$1ZJ(hNPsdkjQWl zl4!Bfof8A_^A+MO)M@!^PzXlk)waVhI*pe=9I+D46S}k@IP}Rl7>+?R*&KnIgNeC9 zF^|i}gklVnpf6#(NPy#4N4kGMk5;xH4gREYQ#DVWg=i!6ILr6mqC3QrKk!Hzen;qENPWKxPvd$L=9ooa|6~S?UU{%97q1`=0 zhJe@fygo)fjS{wBDJzv}gZ&yYGcY>)a93G-zpAQz;4I2i3UoMAE8an3rqFPlBj8|M zp`*rF7{-EVuonLU!?N2$*k7)Q-ybHx zUjgIwgW|1%QT{br#^* z9pEk!1mYw-1)nPy@I-u}fX|U*LSZlu5B3v5H}W`s7$%baHAXzM9ouMvq8&lwig;Ya K%PV-M0{I^|pZbIV delta 1033 zcma))&ubGw6vw-%EoRamf>=-roodr0)NN*Wb~n4rx;AN=7HqMQ94aK@Hkp`|BwIII zj9#jDg~DDuC@3O$5D|)?2cb$&HrP-Qil@?xH~$7_Q?R8Gk~uxT@AKZg_nmondH?)I z;_gHWHE;@bMT0M%@4Okwz2CT9CodO&khcdt+qcqpE`aEt^iVGt?**UXuSR-zudy}v zwLZ7I^=&W4Ti)Fy?9BF*Z)0r!yQe;T`1oUQwZ~$*)-J-|j*q$I zL8232Cc0%PJ4;MxAOpfPHG4K`8#bZRYvw7VIJ`$@WT)gArZMN8^hAVB!z(jm%Cdk2 zWaL;`l0=r{h`}OySOaqyX9=%h!Z}~S4UdE!;DeK$@BvsWmnv1YW;jbexDIQ^s=8q2 ziung|I?}ZOk2u64f#vxWhgDHjMa&{eMTizsblM^mYlrIEKi0HTrdiS#=Tk75Es!$N z!Y6W$&?j`Z=99kIl@9iEyuQ)S8cO}IGP$gpbr&)%U9)m|HA(Ir1*M{1&X)|^o?0-n z#foiK3ospAphAJ%hY2^64ryVxhN4G7vp9U*a`R`umvNuwU|?t+2|UkXQEa*ypl*gh znA+|d8H}s0>Hi~|Zktx{*gaYnU9$^RYd>E|*GVO3F0X*vS&QTWf*f*I2Zyg?MTG80 zLa+isGeDdYQBG?JW2r^sk>czO`qP|(T5^Ke+C!wboVp8%{0YvsjADscK+|A2S$s&` zAwQfO$xNfDoKPatj3P`+F%iXMF(DF*$O$2?U?gE(YfEH+u7j#=Sa!|bpXa0q@cU15Vr|6*Z7WspW36ag zTT1Jrwm#M8+Vh5%kdP2VfCQLK=Kh!% zVv?C4VDPqie|>ZEopWC1ymQWXzBvO0!!U5b0Xu>^(gYm%+rgnZ2kZ@p<{Yp$9GY{$ z-f(En0egcs5GOr~-psxL01=6Esk8xAc_5&uzNn}Px7lph=xD*PcQJHmwMbQ!tgjC> zEsTrvadUGSDM|x@rcYDWTvFU{ZDGvfVDB*lse+(Lb!%m5Q%QAeC5z4q<%cE5Jj-_V zAgLl3-xe2NiAbEw7Wmq1e?S7dym#mItV{st=~9n>X8Ay>JP> zhrNp-;{5rVjTV`d7=ooe(hD zvX-u|7wORgfV!>q_pd)q-n@gn7u)gN?_Ylk7zO~&u8g<^O9o2+uZ7gq$DVp>442Dv zcc;6%(?^;PA#OC494*cqoZtZ9oiiJaf}0dLW%ZO-=0q%Tc5(&)RF8gm;hi3&$FdgF z!z*%jGH#cjKOqy{B=5z>Jl9(DXG7^V1Bs=pSzO)&{S5;Ii$%}LS%cej`tZk#L&umg z+`W6BHeQB?euf(q$_No6z*s@J3yt2V>ji)yZpg&IgcCQ8q51*M(ABM##SMnBeslKb z4%adtEaqTSvPUbhMUBzvY<0H>Fh(!YCe#4*;jikK>x7fQ{$lNReTz zV|?R`f&+lKQI9t;>A@rNDctz2V-vU5Q{%>uyxA-C9L>-Z7 zPAzM}x2pgUzi=ttjYUoxLD1S-rAVX@iQ2VVoj~B`@9#NdMj(UXtkED0hO_0Ypx0w! zvC=G53JT)5y4rXc8X8m@O&@MksnoDAZ``h^kd~FTNF?g8Fy6d*V;KzR;i5W3NF?f- z8hK5PLZ#A%h4CUI`Jtg)C#T`hRqhZrN_`_ zRb!>3EY@$FWeby*q+b6i6VvMf!~XdB`*|BbB5w2Og4=NxlH$7yd^~(5swM!qBNtiK99!TUGI_?G!W;mox^(ub zwOeR(SF3%I-PSu-vvI>WJjT=4pU4eC&^O;a|MJTxEk_Xmv|1!5r%tOyZr@gvm9?7w z^y{x8OTpPhUS6H4-~a$c^&fqdy?ptPrh)?inXD@*(XBiK0h~bGkakFj8i|~}05^KOyP7IXiQEV^ z*L}BL(O}rZ@Pa}~=hf2KD4{LZ|GD9hoYjUfBox{R%@6)oSZ1p z(SijF!c2qLyLYu4H(u!J(G9)3p+MQK#0@W|_3RqQjf)!{Jsm`inChgdyqL(1aBY=T zl^JdCK*IcWMTPX6Z?5BZcsOs{wmGq}Li|#%$3&v`jEpP4|8Ab|!4VrPJa+6KdOe0= z7>Z(1QC|@CVhW+q{m`Kl41E{>qj8k;l-f zJ`hfyu2v{CIMr?2<}6zlYx7kp_s zbjVtaAsI=ogHUt);IVW!_ulSK08rH5A#zJh48{jCKfgXb{q)+kQ=+2oJ5ScztINu& z{NjrOwYrzbbIZ$ng+?DQRh1%QC~NkncGlJ8ryHoYRcnhgL9 z56^W!7dSavIS`9suy*Yk(-@i0X9${|WeiWEBD`fxvXYfk|K~qwW-n?lg;4p=!Cu85frzcFfZ?7a5J$>?q4b#cHu!&w> z&kLE)nVq<_gcpth zf}-+clfMF2Q^_Lj|21ONsF%Qyha6-o<54N z&>EF8ZhneYHyVxl^wSYOKJ40BrPcSROr~>6O7ymEb7sxz&+~bB&>I^&+S_fMF7)$b zuUz@q%$bH5g3o8kWL+{@mqvpSRiV>q2?_qMy_VqRWxgm6mMWvMQ8f^%D^|om@kEGe zVRW=$@#3hqw(i@v6;^8r1gxZ_&@EeLnN=Jd`0j#MwM5?4)`Mt?eCRaSNdXBjPJPw# z69*?MEh#d&rK7n{A;!S)NYJRXgrI2|Df`$AvHjccIYT$H(1jc6!7iRk!}xQr_OJ2=*Qm;~VelZ2g3Y5tttRCN&w4 z`}rZ^YchW!akink-tMkFOA>oJI{-i!8u`+}Q;*!ySO*>fl%35w_wg3oUbN+tn7PlA zINLbWL3d+Kdm#0aq62>=V0wN2p*^_mH7X$L$%W+pw$BkwTC&PJzz}Lk z{=6|neh&Qg&?%Ry+YE2UlGeRz^9yL(nxoQa&u!Z)2#pYqjr!Yu_vHWy*aF{)DJ$K* z`LokEg(S?h>2D*RbHIUNhvWa1IACu$H0OZ5;n17|_J%`q4%i$211SSA=b10;NdN!< M07*qoM6N<$g4*ZnC;$Ke literal 186 zcmeAS@N?(olHy`uVBq!ia0vp^AT}2V6Od#IhVfBmDRDQ7T2`(&HD$0Qdcr8{@;DmOiu?0jjCutQo|d3pHMnP)9k z8<)&{yZ7tyd(sS^E-s-j6^xac-rc*Ke)sOXx`&gqdp2IP>i)g&xP$`dgE?twD)ENK lt5><}7&Goky1)GoLmBVNmHQvtrvn|s;OXk;vd$@?2>|GANFx9M diff --git a/collects/scribblings/quick/images/img1.pdf b/collects/scribblings/quick/images/img1.pdf index 0cb18631b6d80e58c7e1bda3703a3d21828a4de1..85664a1388f4a084aeff583366f00ff15f8b5250 100644 GIT binary patch literal 4395 zcmb^#X;c&E_PnFkGCT{27N50s)MB7D%uH4ilOQ1k5P}o}S~1ljnS?+#CW8c2+)zQq zx}epjsHYrK%x<)(L@m>j3`YwMJNcZRY%BVkewn4 z+zdGizS$7qdJJ_xez&r*^x!^CQb!H<^gG$t^rt6B4s(^SYI`(1J|=0Z+O}a@;|8zB z$5pXAN6If1#N8iRv8}4v4=RawcK|7Z;7X3W^gXYGcs$S<8 zR|ejis9UiyF{SQPWWvYacfB^;&2Z~j#`2QOWg}XOJKS389#$h4c#YmuE=)Nk34MI< z)v~o;cGY@_Z)Sa*H2-$QkV&TYb<_M?yQYP%T$R0R$-WNl6Fi(Z=VI&r$y3@M5Bs^r z_FuxHbJ_#mXdlp)(|<9MKjZ}Q`rM;Vw-HDbZXgg9p)=xgs{@Wl!8M12!5pCm0(T@~ zpc7z%h7#%MNxL}>-&7{(lc zvymWh1|01$9i(UofSg*_FeZ~Zm1L}Pii#FOG+lHb8^+9@ zTYt!Z;4OW0UdnMhK|2PCiz!>8dBqlY1qLYAj9I&$|8q94!pZ3xr zwC+7jfNV>k#cu39D~x(Q0Wt=pNIZlg2Jpi{3|z#(LkxVxAV3U4#Ndw@M4CQPw4MDW z(T?eJ17mw6ZYBo%N)FN$WGfrv3t_&H0}FUU4PDy?JIsTSK)aUCTmS?~hucC4qao3G zq`A{~G$n+Dfm|_a11$y<0izHSLlNdU*q;xmfU7}<`}~O+zKnXHuMk`q;|z>9b9Nfm z-Ff;q9w4Z{=Yx7W6^4p9GFfj=GH+7ZJco@snYL+EMf5bPChQf-t*YhRwM#C$jXRPu zO+Ec&-4^w#qKf$Vjps}91fLwPU%zCrcRm$x&qbBLWn`UkYM!qkW_q{}r)}prO41%! zJEZu!Y3qY)mgs+kSf}o{UVZkcvFoj{G1Snojc9vn9>Jz(LypopU(F#1ZP}zSy$ok%)Pkf6l=uVhnk{wUY+;OoH@$wm>lObru>pgemqoO8g*U*Hh;+*?sKC9)c#~)v`HEMVL#r6@HVF>#8 z=$(R7u|Fi-EV&iM8~dStVjj8h_|DHpdmhhK=24Da&;GqGsP*?wWqW3MleTJmS?Pkw zZ>FDI_DpP-W)`<;qr=~v&lRjMbgz=O2w(wa6h%e?UGxVjg|< zddID{WAevW9w>GrCNe_wdAOOS3Es8)Vtj4o7qbf^()9=`4{f*On&c&rL)-&$-C=4taHz* zJ{U9lY;p6e0c*oJf=0?>-xIR`T}d%emibUfI!fzVVqCZ`ZO8pXFUeUl@L^=~Q+-BRiyD z7hG&9IQ3oidxGTB{fm);&2Z~J_?Nr6qwfEZf8r~z2@gvipJ-^s9zD3mKQk}o)|wl$ zc&U+>+%}FyY&g52^aI(=`)S;>5w7+d4~7>u9xtlth- zvS6c5%9_bnp(faNVPU2Su4`90%VXR00*-O!FJ#_ww{^6>@aA-(uqOQ z5z2`)fu+sxqm3_Hvwi(TxHvKSIEc&EV#3uaKLWGQQwDhj5oR#UQ(f;oO7Ka7oW zr@(p=d?V7VWHOBT30Qz7snd(2!D!OW5S*l}M2fPB5hN`w%`c7XXC(~?CK8Ddl!I_M zY=FVGr&}o8!M4~Z0eOrf##y~&7P}v#lb_aVMvSu%%nwC+1oeEcj8+Rw3&s5Mxut$=upN0cOfeRpu3tRx+#9-{wrD_RM z$_j~!fI||kcB*?~fc^c17z=S){t^@d5qYugAdF7qB>+dP0`r7ET>*wZ83)BsU?!U* zP;*c*S19K3*r-s9q7vjeOb~KF8U!Y9Fp2*S(teozNUfwAB!Wzf8%ZmOJIDnd?Bk3w z12mAhEzzj8)4}%bR)XQ=B$Oa@u=@GxC3+9HsZ@XNKeL%mYZ_0iuxeAyU?d4s{LQ3! ziE-9xd)2h1k|w4ubXtTk5wu2j5NZtQsnd$}R?>`vtj29NFfid1NOlCIBugd%mz0q* z5i+Lg0!>u+i^)h=k=TS=3{sYZtt0e!s)=IBVl51|uG{@4qpbUdp+ow3y&yOY2vjwQ z6Vlr=WDxw4o|ng{uTg^bD`ln8ZE#Q{rUyo6AMPn@pBGiNFPKH?N&yb1YsE()rV9A#utK3_c@qAI9RR- zEDMA1uou91gJ2jY94yzL4;I~layi`oFp9*%dO(7IM!-mnF#~MId>DzgTEPlS?+Y*z zX3<+=W_JL)hysq6C^3Ib#0ggL5Zfe{ZQks!>@MqKetOVgC4nF$l1+9(qDfXaE3RHj z1-*z+*pr}O1wj<_(5nXzUPKWO-t{jK{12Q>#THXY=Ca>?@AHQDzVqIketmqaR9&sY zH?azH+2pgQpI}q0iU9(pNtZf4o|6otTQZV4~D{H|Dw|Yp$L8Hb=vpKr?KGn*cSdVTAc1A`s-nm|A=Ki59iC9l*6g+=wV)NeM;9ZC82pamwORNC z_6PmpNcXLvb`)=5-@2)n9lO`LTVO4nO9()K2ZQEj9AFOh(NV^F<)4Cgw94fRb1!vHzl`2_TxrRHA`Q6OBB}_55&rfd~XG JFBdPD&>#Pl8UO$Q diff --git a/collects/scribblings/quick/images/img1.png b/collects/scribblings/quick/images/img1.png index b45fa1cb6f1449f665226dadcb6f3d1e5e29f352..5f2c07464fc2ceb651cfc7eab9471a4b65880e3a 100644 GIT binary patch literal 3764 zcmV;l4omTgP)eJY*L>@%mMTC43GE!BGIbON)^Qgv#ru3aq`MT#=61;t3X1`-lt2#^48l6QZ+ zF~(dW5Rqs3{B`ond4K05`R4bY-zCAJC<=D$OcU@^oq!!Xi}w%>R$1600>W9fhSCUIF(9WS=ou%uCAoWNbgAxF>w?Mq_I&rI;zrb zjEV7ac6OSol*WR5R9@Rvb+`Se)Tp&VUbDt>38F%pdK#)btD1Tms6=WABQz!IHCK|G znM*{x2fVwt!V_1xdiz@J-{yL~arEGwqI>`t9+b^_b>pP>FP9@6&Uwt9Ki}`nne~$% zVuD<|*1TiKbp%oAwO_orDJtr@`*w}0MjQCGciVru+x}BycfC@r1c1dMOUH7pMBbNq zmctW2)NMRgmUrOQPZkCz8V{$C7i4W185+D(l>eJkmniNu^C4`j*Y11ucfKyb>|vSI zrm>z|Dk?e*#rhnAsF1@Yf4x*!Bp;Pqae3d6IP)y0wXa35U4bZmf8lqZZ}|I5{__p5 zQjU%w!wLY9_4fRD{4Xi*9WWoow)N|e$NvH-3IL8Ia?I*=HjVY%!r{EQY}qVNPl}5R z(Zz*0)#;d|rnBno-F)lB3IKn)vO_D@c>(d8nGz4|B2p0|E8)st?EC{!x3q+|(U}EYG7y zU(r4c3Hd8#;BZrvkO^jchdB|5qskEg2=ok|8xVJ)=A24BraMDZPs81I&1e1Y()Tvb z&A{xsuIk^OO;@Uwd}-%Ds|q*Azh!uB;+E`t#n)BHD4^)g{3EaL|J+O<8-Bo*=T2b; z#mysr;}#o5!Qp_#anPtC ztylpdX2y%J#;iME^G^V{Tz5Vrev4sOZcNroYd2MX^>+YhzWJZtmivt0FjIkSrB|7- z8(S6tfY{XaL}#jbe*{srv`DyIF_+t?P$<2gnwv$< z&0?uk5gJO5h+u?-cse*tel16*GU&4yFZ@HTQUL(qa4)28Fz;Mi+PY`Y z58d4|y>>F$asK=nm6ct7er{K;yrKIE-MG=RbLYSN`}IqrD_7nK4>$RabGdyP8RvU@ z2emCOF2w5Ux2vkUKK!txp+Tr^&&|Dc;6U=rF9%FK)rrv4GjQ-=>9uRkdhJ9a;kDNy zwrz`NFf0rN&w%cJKB7V}JH|kc3>R-7H($QA6968HxJLEr>g^jmf6>E=5&&rY;p(z& zy9h**(O7r@KvA@ypdcwJiN#{ESgfR^q{70&37*?}c)J)ge8ZyLef>WUQrR4Vlc9~5ug_?50$0YE4m z%*?#R=Re8H>Qt@ftFP*llTRCp6#zy?l;_UXr=%3t)lE*UiO?Zw!we4!&6#NA`{Pdw zzzjh@-&7|NOIKsY$k1SCL$xV4yjrd1a5$fR_E~mzc5Q8KO-)U9c6MG~9*4tGtJT)M zfT2fy;&#nckscUg#`Eyuif_KrObPLL+^kui$;ly$7YDk!>d&LQx}H+WuYMIfXAWz; z!`SN8p$iuV=oSoeIZ{wit^IC>h0zx*n2Fh=qpG2y(TS&O9hH@xfBy3i3Wa9ea&W*! zMtZMa9jaTbKYFCtvE%yiuyW$zCW2&0f*BqZ+YIzBNP-A zaJk&_@^TVMGXkfkrY>8yEHN>$u&^*ABV(M&0|4+FYqhplfXRK4`g*|^U);g$urT`m z{mY}Hnb#s?{ipqAC^2W`8=C#F$K%)2Gu=6w1rn zHgCS5`xKq-oRhP3`SK7fvHbk%*jS(0v!9fm9F=B`Rle^O~p zJk@b=`Erw3EXPvazkm6L4bi$gw@jwXhaV=dSTP%Wc=~jeZrw6XaU_vl89tajAQGB# zBQ!QP#>dASJ`o=u-`Ln_U2M5jqP0E!P3pC&sTVW;@P|c)cU1szb0cMD&O3OpG$@D` z8|!0TG8W0oihJjs1$ewUp+DnPwZ*iD2f4VIS6s|9^g$3cHXf-|XkA^;6fWxFACD2H z3P=^Ie(Y(ke)IAVk_o%vY5nM7ll1}R$dj26iE8|Plu8vsp=RncXAa9$R~Z>|($XSr zw=LxAO3cnqFz@s1Q*CGvV1`7Z`0hKdMgQhz(W+IU6OU^ho>a|FkU-Xr0%~~o7s@n~ zLLXOiCt8S)rJ@`iHRXe6v)L6D6^2h#R8+9p?6D`U3)$U6YfCy?jrvF=3aw3}kSb8>RnY<7Bjx^*vr9`xki)YoC8_5uJr9v2tEQq?D%H9>1tbz7IGAQA$H_`nmxmAgw2gYHZrBiASXd(x4WTH!_uhBI z!^+guFx~xOg#u}45Z2fCG&PCHWWx6C33R%%!5eH10$C3>QUU<_c%IbO$8#h&0RV|W z3iJv#tWej+u0K~*s8XxMgQEAp{bSDR15N}Y3h0TOhi~(4Vm|3{Z<>j#U9blL|JZq^ z+;BGf|AC^NZ*gxI0|430{hfc6J2)CSNROhhZQB*y`2>SOWiqLro)oEcxT~vQEFRKk z=j7y2S(!zpIsw2(AC=|j|5vHBu$_U!!ICAxCr-SIJwy;yTH4ur_ly)+y12WOj~#pE zrI((XS6Q9vp+h%MovIp3s*4r{o;`u5i)ZcO9zT3elejajlNdyqcPBY;@6NiO22UorEa>0IpuWZ&3jNfTB=R!qaZsHaCkciWLB) zQbkFLehu>sQY|ZM)t%TSB>3;$yG*<6DwiWoO}%AhZBo+Azl_kSmeH- z$)Z>R;E`NX-cn}Rz9r#zQNA&nY)9oyJq=p1hA|@!um77Fv8t8Ix@(&4o4~mVro;*W z4mmkF7E`nWj~V{em(OAqiCij)S(RqgjX=P^@=Camk84Yd#OQed3dJ!kEpq?<FqE+G;LadCcIx5jyR=ob>! zrb_PUkd7tQO`Bqql7e*`BO|@nu4VW34n24vHhPt}H#IpqWY?}GdKX#;!^OKt#up9t z4kHRvK12d(o`2l07yQ=nCs_`7LUKe(cYjx_n1_Pq>qNj4;sO(L(~h~4%@y?bOTVjs ztk;#l-|NAeY0A@9^#B0eDmYqt@)OM7n42Fs*W5CvT8%b0i}-w5PtSlvqM*^p3 zcMc1qQz*vI^-UGeK2^CKX=#!0coIHeMx&8^d|a4J7at!NqdONpD=ny6^#vydo98fs!?xsqW5(HrdL0=WJhCovc%UBum?06rId$o|J5q1w zIiU7x(YGJ%!t6D>K8{-Pni*#s{(g(-Oig%0vw|z&HZ|Y+!FI9iOjA&``sV2)nC&sc zpZ$we^ZvH|z2Urd8D9RH(u)6cjZI_OnT`yI1hQVuZf){AyDk1hg>ChUClFrWf7Cl9 zoH?8QfBXAbJ7#e8_MMxS?&8H*nzb`HZm~sw8`iIO>`XfL|Ie~Bov`cG&UC`AS3A=Q eyI$=~C;kTx?T~ovjw9><0000> -stream -xEKn1D8fiQ~(ӣy?,IYz7%?RE\U~@QgMKe'u:eQ?lS(b0?Ob%:#(- c͞dR5H4; l<)4<9mN:acd=\RD:LGd"*j^h<. tW!R:endstream -endobj -6 0 obj -214 -endobj -4 0 obj -<> -/Contents 5 0 R ->> -endobj -3 0 obj -<< /Type /Pages /Kids [ -4 0 R -] /Count 1 ->> -endobj -1 0 obj -<> -endobj -7 0 obj -<>endobj -8 0 obj -<> -endobj -9 0 obj -<>stream - - - - - -PLT Scheme - -Untitledmflatt@Macintosh \(Matthew Flatt\) - - - - - -endstream -endobj -2 0 obj -<>endobj -xref -0 10 -0000000000 65535 f -0000000506 00000 n -0000002090 00000 n -0000000447 00000 n -0000000318 00000 n -0000000015 00000 n -0000000299 00000 n -0000000570 00000 n -0000000611 00000 n -0000000640 00000 n -trailer -<< /Size 10 /Root 1 0 R /Info 2 0 R -/ID [<773F739C40C01D398B1ACA4FA8323A87><773F739C40C01D398B1ACA4FA8323A87>] ->> -startxref -2278 -%%EOF diff --git a/collects/scribblings/quick/images/img10.png b/collects/scribblings/quick/images/img10.png deleted file mode 100644 index 626c2649aafcb8ebdba2eb856fe512a6f2170fc6..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 611 zcmV-p0-XJcP)-BE8J06dh%LM=gK^P1MqtR$Ko3&c4ztlz3 za2y8_HBFtA0&)3oJs`OJaqx*W&Faa<+i zI0k^bm(X>cQu?j~N~x~vP<{~rWLdtuOi>iy_a9Gso~I~EmFaf7VHm#aAc~?+rvt;` za59->SvHwW?&5*x`7})*Po`-G9>c;9X}K@cF0{0kR<8(bS8v+560#l6h&d%HX^F3N+}J)u-s6>Fr<{Ks)~rVZCCXl#m{VM xo6Tms-JVXT^Z5(_qA2$J{qcA_olftzv@dtxzwgDidu9Lt002ovPDHLkV1g2w9+dz9 diff --git a/collects/scribblings/quick/images/img11.pdf b/collects/scribblings/quick/images/img11.pdf deleted file mode 100644 index bbf27fdc69effedc1fb8aca4189128241d60f296..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 2507 zcmb^zOK;;uxI(ND7JEayE{qmcPPOZd$B#U$#NBR_ltRo#Nmg6Y7Rj+EiK*=g_C!g0 zZ{PqIB=`yYjq_?lMLE=$eEHt*Z#G-ChC=d&wE5#- zA3v5%q$1XPU#e7alg0x+LF`wGDl=6hSku-gDyQ}`Dch!xZ z+!v32{_1uAn@`^R<;F`7a&JASHGh4v`NG{NxleE3{0aZ5b^m$h_d8D>qlr=f;pmSB z`ufHzACA9#{@L`^cR$u?Aal`>w474Nc`gLH~Sj@lBS<_-vTvz#F;JV2QXDZ+0Deu@qy;b2=jMxbE~*2y_h zvJ{<5?z-F!*jMRq*Gv~L%CG#E@cov9h;7e(6k*Kk+Ac~$ti1|AXq^+Y z3@*$`xHIl?k<$aGx#$O?7Y*B<7p1a29l72K<)}voL0pyp{_cAj1%6e2XgaDh+NHzb z&9j7d&fe*IXD43Sm$z-Hvh6}GsWNp(Nq3t)l9GRj!^NmV{@T8J|io&+3e`Es5pM8AXji5t-gOHL5U7i3VG_CgpM&s~Xlc1vr%SH0JJ9iPJa0Ugk(}uoR2aeCAW$V-XGx zFv+WUVW5lRXsC3>&7urxa7 z;RRDb09!hw03Zt**B^T{smgn;CfXaal+R3~Qof+ecpmvRI0V(YJa!<=f=2*Z4)cTl zX$@wlDr+iH71dBQtxI&vG%eFm)Pkj|5G1hf!uEh|as{hhS@N=^3x&2@%`WPALmJTv zUZ+*C$oIK$uQdUV^WQ0mBGH-d$Z@P1^TrYEi~ZXFtot>V%J-ITj>butwYKkJ8bZoo zgF&?j`00CApCyqCjp>d?Vc@x{v!09CjQG6&~;7GXuNB<&D)ipScYdBJdOS^_s30&(n94Y== zpJ7~rE5V&ylQqdXKAyNiNE3K0A>0YhD8zgTe~DWM4fma8z> diff --git a/collects/scribblings/quick/images/img12.pdf b/collects/scribblings/quick/images/img12.pdf deleted file mode 100644 index bf80744b7b544f9a465b683f34cccef449d27634..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 3655 zcmb_fdsGu=7DwrUHH)aH>uN3P$iv`bGMNksBqjq$Kxm2N04^w?9Ws*#B$+swn1sji zL9JHox?&Yk5v4w;Tj|iPmJ!V12K_@W%jO81)(K+&`AAATq2<8ojQn2ZuS9OGy{HiRs=F0tLzlo8azU23zS8751 zqsf(+)ARbRHG7<6r+NL=QQN4+J~~KtZ9OGB+lbX?StCF8FTN8etiC_%lx@c^-;E&( z^R5}g>BzDtlGEcyRyoS=$t%}iidF^OdRS6A*{kyEg@yKPZR)uWH1fofC8vnv^*^lr z+yko1OF?dJ=}zd3I=^koiY+5j(SR(E_?ywrj^fe+@3<#ZvbE*1WxJl2=l^tlep6S? zg8d5?JZKNOkk(YcaXk7*MR0{B=+8b6pPgtmtxlQH8z-(tr{qzh$OGV+=Tm(@vnX;J0FK^Tps|0uvhn)+(>p^ba-3&B z+?fyZ^bL&ezQ8Y2KxI1oEwRF^v^FlWKJyNJ8j+CNVsTpma0Ei`a(^g5qlHJZ2 zAE*>vzr=j`*y<61mgyILtH@8n7R_CJlRQ$F*X}&<=;yTd@Xl{;+%9N&=fd$Gf2a1@ za=_jDeN({2g)&9s$;VXUI<@(@ z_U4q|QtK);OAf87>-~PzHpkPLM#?Z|L-)D#ycXv;ea!)R!p+P4^F7jyW4>wgRQBwj zKIO*J*6qIa9X($*{kzF@_QQLO1AR}kenYPEqun(99tg1C< zY)SNCpG}9yp~02gf4{Z^Kl#hE`3pU7#H-{XlS<2UnNR+)*)JtAd+dhj!)3wsQC-`- z5DC*$`;p~AePM5<@8QYixFf&mv)#9M6lAPwTB`|J(0rrT*3vhtsLpt1U3JFaoUxz! zHZCnhj-1yWs<76L&uNJ2`p!#qx53EWw4w0+{L$GBJJWxj2)6O35eL)s=@Y+{`Wb(! z`=Tl350v-ZpeSqK$saC6q?Kb6y0bD=do^4auJ$o%T2;2RaI@c0r^4a8?b>*bGFGiN7=jZnN)a&fC7haiIRM;9c?o2B%N|m=<_ereXihU*WzAOo=6shRC)-_8SqRB95CDI@Byv9A*+$;aU<_l7t?gP1&Jz0XP<- z2!sg3GdbXpCQS^4vh9=uCy^G)N~=i=XtXMtQYVv4It*GdV2rUdbCMa*W}$EwFX*#y zG-YCdv;|`Oa}o!T+z?oG{rwt(SqzX1gav{>)Dspcox?&*;$%WVgB4guUJykFMctCo zID;D~?SKk5QYFdY1UP{t!%T<0EI)*s11GAK5Q1TDjI0~(nUWO7Va1Y$9ALG&4_z@F zFvo$Dtyv5k)ih-+ z)5qn~WODA@6m@QnT0(FmFpew&2l*sKMi>g<+e`#p zX@g=W3*Uu_ucnN!J`G0r0(iiX0=Pr#&5WKhL9Agsi?T9uu0$P%hzXqFg^R@^9)gfK zPXHD#lpsXmxCReJB;f;=%r78($rLyMwoniPu#M5n{uTg%Y`xxhaM15O1a?v-Md&pS1*jc4S13RPJV7W=C`>_6sYnDqJb_p$5CA6u zYczPdfS1f0STWfkFGZ(-L}RLi6ewA(BaNgC9)2c+*?7O;?pqCjQu)6_U^KEf6E`cB zQU#^98bQB^SNxxOe~YOi)Ppe1R@&gY+JqV=4IpHogMn-z04JfAYAD)>gNuoq%?7<1 zXYVTvZWR}kfkQ^m7)Z=jI8g?se`Cu&ZDk=q;_cr)a2^f|f1k+So=3b}vsr;ZUa@DE#2p)%^@GuGlz( ze6r;gtdO#$Cgs6sBNLcj*f^$i>@MHC%8RCPcs%F5^f?aeuxF*t(kG^ybT zAVk1ndtU#7#3B(Yf;5nuhKNuwvDpQg252aPfC>6C4G9ecqjMMy4ShvcAV9#h9?mCx zg%1%)UbP_x$cD>`#V_zNG_E(0H29+i!O8ku68HweNfZTUJUd_^INqe8AU0>!o)Gyn>jMs=Yxg8X~q>$6cq?LK|wKz Hv7G+`(NHD4 diff --git a/collects/scribblings/quick/images/img12.png b/collects/scribblings/quick/images/img12.png deleted file mode 100644 index fa40ec0c6d729f09f79642d3b87b6fa7b65569ec..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 718 zcmeAS@N?(olHy`uVBq!ia0y~yU{nCI7jQ5ENo6&)-3$y&Q$1ZALn`LHy?Ze0v4M!g z#T`HX*WZj4+f;B>#eCwc;%$-(4-^Qt9DiLVbG(=T*0$sQc7<<^|G$1G`~B;Y$Oqy~ z%@YnNs2Ff?@;DL4+*1FGJLYazwb~u)bKGo-jgB4(0zwikEW|QrC95AV+h+K%X7-_< z`&vBD%h@jvzhnIHUSS+ANBA0^G<>VN>~mIx4}brzyZYm{c=P`QNG|`j{qL&6PcQ#`7F%z7y0qdTA~ZbtI4Tj` z3nG(ciqA#wdHx2&^FBomCy-2BHsi^R`g@PIrtjp_M}&;gNk&B^?ydgEZ?3n0j#r!a zv*b_wI_wTciINNdUg{U@UTcv5@z&;;c5z%0cKfFvU(xNyx0TjyyPtHldM|0w1CGjt pn*Vm4n!0vJ`k}p#_mHDM|8iETe>jJr2QZy7c)I$ztaD0e0sx0G{-yu` diff --git a/collects/scribblings/quick/images/img13.pdf b/collects/scribblings/quick/images/img13.pdf deleted file mode 100644 index c0045d2a2ce179a0d5d971b7dff2f09342b3f429..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 2851 zcmb^zdu$VB9E^{6V!)6XUdqSVyiRGqyX#|ZX$!1nb7O_l7MU`Fx4W;~x%RHRex(H= zAdwkCK(Lw&i4g)Q;VI7mCPYw)4h~gs>d>}7>*R>l=BL1;2OZMyU{r+89 zC{ShQEjFg?@K4LuFm}Wtt??Pg8>&Cp-n#bCPni{cCdVzM!v0N}FYM_Z4{e@-H%Hf;Srpi{YjKBtA^xVJ10S5Y z@2h*oA5YiLUly(0xbA`FgZAV;zp{PHhWg1h7sIdoef9V!kIpfPXL18(~_nlsP zYHOzU)S>`4vh19LoO^CX=^gTfvYk&2XFS|JW=VQN0M3oD* z1IVbiQDx)5&1z!`C|h?cL}w)l4v9?!2Z^kRm0A`}Ij7vLe4xd^bq!IDh25jGI}q}0IJ}Cp{}zR5jH$P zc^6U$Pf+9(n#LFohMDOIG^D{ge}gFBC0da5i&TtjO+^(2PlJStGEk7Khv|x&<-7f6 z@T5=>@jhR{Mty`Fw?{c*bOt zqSQhtY9vjH>Scf3e}F}b>}99ggIqA_C(X*^vvm@gJuxcHZjoFvJI2R&#)wc%V$O<5 zb1XlwDMV6|x5OW=t12-VvhHjmnSiKKHW61-?yQ&1i?{(c(3nMe7TV%v>w_UgH7(wv zP$XDf7T(NTN1>Q5CP+rpTM%z?u%J?xWA1REs-O^ldD&)4lWvSNnT#c4wP<=1=3Ooq z<^(JVX5cWVW~o%nn$^@uu$Om4sqYd~Q7D-EBr5^JZ4i^mtARJvuQbkjdVOVU` z($vekqzc|4i?Z42aM;Z}Ped~Z&&*Z0Y`l#VI9`&AmXbGkc#|n0fGsPe03bIsuAG*L z?q#b(b*Q>oOVLi#$Z2s{SzL&`7aW3W-8yz4bOw(AatAe8iOmYY?08uS2!gYj1tH2? z-F7?tnK_4>;~+?2^}|+%EqxnSpQnpg)1y#mU#KpMB2qI+5D)H2^I#+2H-y`(2?z%N zI|Ye^(V1d07<30TDV>0QQ4{!|b??Pe$x@e_$+RBNx3(-{5{Hz*27_wx;HNCPW15~2 zp)ti|GOkFX(XSY~iuHMbNEI3(M&SPxaPE>yod6< zu%Wz5@^Hg%#&He@+^`-vyA`fn4;;tCweEql^KkHb z;3{1Iw&AqGdG5jIblkv4by0~E9X>)4jwrJU#D;KK)8NJ%2NvNPHKrk>X7II96F}2E zerF|bt8&@>Hml%t_$!@)lk+mdv=Qj{#4>Q>0z9L}?kYTuEUDaHw8S<+9ps<@0K_X6nfnjRuxQzyH^QejnGRUVlHxltI1D z{ywA8in2Jy7#fYN83X~YOB|;v9*wXpe*R3yAPn(590$k2^9aKQHIoU(EPMRV==U*( z$z&CSW)q1{ha@3M=ytJfn$7vLt1Bv%HLjoH^pqbzmNE!KY?~;WIgBEt`Io5G@cp$J z_&&9o-hNS{RGPoc^XPULeA(&Xc{3;ZJcGg73?3gjI1t4m)hgpL)hctt={O|Gf-jQ< z$C){?th7D&5pj%V35oF-U_9OmgB?jaKi6cUiwl)XGux_A(63($w%*;H3Wb@Iy*>T@ zz4rEec~LGWqKIPgtrh0_APg5AMiI81X(uj6vx#lf?Y>Q8r-Sqlr*VocZ>01H0xWB_ zC`=K@xNhpLoF0t^#;hKS(FkMSf}UcXLBy?zwEDZ|>XlV)tDRTArA_+81`P|V&tE&SPv6C@ zvl*XQr@qhrh!ra#CN`J`S^LC*z{QP8rH~^=7S>PFZKROU!*g&P91kyK!B(CyF_d;9@5|S=m8@tK8GF@?1VQpnP<@5(jl_?~&u_I>GIU*98dx;t~ zpS9K5$FEV-^cRInl;$q;@VYGUi5)r~Gd?j-e!$v3@sY;^4pgLAr8;I@rK;JsaBvb9 zxU_`CVaBCdSSfq(BVu9;OG0DDz?kt?80<(o*ZD+~3tf~n;}Z)i{L%uSc&EF9W_;qF z_I_(^pZKDeoN|hYiWH}TSJH&S{8 z1QymxQJ5koc5%~g<@9LKFqoA?F=Ave@A8=^(7fx%R$`1k_` zF>y>hVBq6ds2EJZ=6&L;UT<{MQ}00!PkNdzj6)rs=;TaiyV|@@)ax$Sm%6>=UV4@! za?+7FmOdH94fw=0> -stream -xm1 Ew'hl Tp*TCӡ/6a0B|{#]Iq_0, OI+> -/Contents 5 0 R ->> -endobj -3 0 obj -<< /Type /Pages /Kids [ -4 0 R -] /Count 1 ->> -endobj -1 0 obj -<> -endobj -7 0 obj -<>endobj -8 0 obj -<> -endobj -9 0 obj -<>stream - - - - - -PLT Scheme - -Untitledmflatt@Macintosh \(Matthew Flatt\) - - - - - -endstream -endobj -2 0 obj -<>endobj -xref -0 10 -0000000000 65535 f -0000000443 00000 n -0000002027 00000 n -0000000384 00000 n -0000000255 00000 n -0000000015 00000 n -0000000236 00000 n -0000000507 00000 n -0000000548 00000 n -0000000577 00000 n -trailer -<< /Size 10 /Root 1 0 R /Info 2 0 R -/ID [] ->> -startxref -2215 -%%EOF diff --git a/collects/scribblings/quick/images/img14.png b/collects/scribblings/quick/images/img14.png deleted file mode 100644 index 29ee39aab5561563863ca54e53f1216a1484b642..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 233 zcmeAS@N?(olHy`uVBq!ia0vp^+CXf>!2~1=-dx!Nq&9fEIEGZrc{^hxm#ZO%^XtR^ z|EJ!+r#NNx44#u(OWU2<3|GDSBK+~^%lrqw<9rr4Ovvc?Z5ouw%3jm7CzO9@E&u&S zP7#ix{Z-*2G7W29JhV1wWMa&DRJhQI=~V~*8HvhO>CPkMiya{K!S*%=Ov z3g1_kyB=Vi@fM=~;F)W{n8?YXfcE}8(x!rwTZ)hGH$VRE(z?{&-80s57hdn1#P*8i zXUbMw>k9mQDscVC)CX?tDO=Iei+ANN=Ndm(#JYL>$G!kZ++~UjjL0^rg>lXC7x^XEIYI9>k)@Xj~sRPD0cpN&&5?AT;6-B z5vYefV|qN1nfFe7zU)b1_UUE$k2bg8-+f_#-q-Tws@0;qH&(Ix>YHb#9Ub5P?D6qE3KbnW+ttS_r4u|I?gq1S$TJ?iFw}rV^PT0fw zho+x8db-V`zPNtuFXiEJx#_bcX20Vv`vUEWgIwMF;hj4^J>uN=#wV{XeYD*{rf+DS z*Qo88bZA8Vlzn|WuAQxDJ`lWGc~AA4o_cRZtFk4!u=cy)rJhe-+CF3QrNbAlMAm#W z{@CQTGtcy#oV(|%hu`hpQGV`^rsmG7Q^$UIYocw!x!#Lc-rK#V{lLlEo!4Ezj&z=$ zv#5N_%Ch}uPjr4bWrx}Asn^7xrgm+(F^QzrV$A@u>TFfl`tKCnOcCWAY=P$G8G<8n z8^ID$HF>t4M@u*$J6y==S;_#(AZdymR*Nt=N=!X#D8z*3i5R*PBXkLd_5#NGJZ+3o zXdUD!@Ivq4pq{26Z6d4Zq70yl4p{2?dk|sE15|LqM7T*)O|*ou9E>tc5opMQb^az% zen7M+8I-A<)Z0obik?b@$|_KhcZlhlTjdA+X7GZDgm_Ub`e=nwoReq`V~Irv1F*Cf ziG>W7%rQ8YZKYODTcmJlzIaECQxuC;@z>@vveH2)Y9(!2I>7#U@G}-^YJgqrk~k?7 zBnfR!mqB7(^P82f4#lgowIbuMm7$o#mX|ZOcwtaYL`)@65sZc#DlCS)FQ3Y!AZnCP zCDW!aA7Be2K7cJWW>JBKb_CcKDT1i3Cp$EX1iRPH+jz(0C~n9plGBY2#M|90s5I2L zFB)nnDuiDFHbH5|hjA{Kv*#Rk-DtzS*XzZcfCa$@95!=#n#y@w+I$4;6&%r82E@{) zz2K8w(NkD!!MvTrB|{+y$IvoV)6>W@EVt@e8eqLj4ewTE)#h=#T{fO4vWhT0)R@ps+HV?p>~05(i;)k5Lr|^T z#}0)4;1NJRNmsS_@(|2UfE75NvvE$FAT;w1pUVY*HqPziI0zD0gRqTZJKup-^bhdr zMl%#zjD(v}Oi7Rw@#CR1KeqCHQ@F#L07?4q6r@sCXUZ8#@`ZFIn}U5YH}pU2K8&SO zl>s+1StD6!ZB@Y}2`PgO2G!!hPgU{7bt5H1W6GIKQd4BBUomtQEBb**HJT)1VQ}h_ zv>!-n)*$$ja=I9Y% z5caJ&&h3JuH3a8!z^xyG<9N8%LvSu0&h8LgjpyGsJOZ5GA$%U!O?=dlwIng%;}hYS z)i-G6opqZ*OjCP2yW!UDwK>Hd!SHZTASQ7VJ0E*W55&e6tsaLn=%ZzOK|VJ0Ip-= ziW#8>x%h5@$73*mf|HwFp4nSkbF|OeOY6JzZ?o0EpZ#Lz5YPFQltJ~FJpus@huJU=cTJk(Kn^XCijYZ*VL)#at3ui$y~`>CsLZrI;{fe}WsZ4Cx;oOD&A zkzT#}1B{e13?bOv)$iY_tM2ZU$rwU#c&HygQdfQduA?JE2u@G+?OW=qc3USWf1i=o zKoEum0gi*?5Cnwb{Io^`%UV4YCJ{yW{(7ujts>EG6UW3coes85wK_k!Qo(gskA~3* z*L@t1OA&-2w#{%jwKyCiE!>H68Q)(qoh|EeFs?!n1avxc*4u4@U}06Gf$LHzP^;1J z6GcQ3{XVrCg#xZiqwzF-DFVkKj_0h$F^;pWFiEJ_DV6X%EDOuR^C*?5*GZC@+<(lR z#_71<(fJvdXSx=*lBA3{l1{`&X=gflDIXjh%;%Y_D;*pxDr&0f$!n>VSH7$6K!bq> zU3K%yx770FHMPD@3`3+jooL&OI>cni8Vv+HfVv)I9vK}KfX!!UMYw5%hBMa**6GoC4 zj{(Nxxd=kSfWX0VZ~}smIS3LG7kA0#KaU_IL!lUJoG)TSL1$HW~v zHg=WSuTZC6ps@byC-IiIU-%-1L$cY2R+#RCkkG~+GPO8lC^WMZB}z4FX%W<@l_+WQ zM4=qHnU@6w9p-Rin|8nyCwh2&QtQMUZuZ$%mTZyYm~oM!rYX|FiJ8NRF|orGCt6r* z_TbZqh%77#jTr-D#(xFDOG%&fDN*uSpL5DhQKAlhXbvY{>FPjJoVcsq-%70$?{t?@ zMni^KvXfSr>4T8)`QnhFjcv3Oms28D8@oeiavIyTg$$p@)s*8em)u|`^FFH~8JDi{C@{DWg zR+7j_N8&_!CKQ+H#EoQPYCCb+S4b}tH?R{|{k5f$iJRGpYq)vq|F~{sCmQk-xA=L- zjDxX-ooL8M+Qv>a^A)zR6EWi_Zeb_>i5rfTVFtk#cA_B!TiA()5Nu;7{(VL=cFVJ= zooMu?Ya=_+>|NU?cA{wnq_z_capFwe-|ON+-L8KA)URKXw7aXrL!F-L!-ttmU;PJw Wf9mWa^JjJd0000> -stream -xmQ @{@[c70qKLp~x}[ʺחҎtqzCycopгGO~*gs9ʲ9J ,YGM"ZXQ'jGM!q_2r6J\KݠMҕYsW,}hendstream -endobj -6 0 obj -162 -endobj -4 0 obj -<> -/Contents 5 0 R ->> -endobj -3 0 obj -<< /Type /Pages /Kids [ -4 0 R -] /Count 1 ->> -endobj -1 0 obj -<> -endobj -7 0 obj -<>endobj -8 0 obj -<> -endobj -9 0 obj -<>stream - - - - - -PLT Scheme - -Untitledmflatt@Macintosh \(Matthew Flatt\) - - - - - -endstream -endobj -2 0 obj -<>endobj -xref -0 10 -0000000000 65535 f -0000000454 00000 n -0000002038 00000 n -0000000395 00000 n -0000000266 00000 n -0000000015 00000 n -0000000247 00000 n -0000000518 00000 n -0000000559 00000 n -0000000588 00000 n -trailer -<< /Size 10 /Root 1 0 R /Info 2 0 R -/ID [<2D22C5E6138860AE600CF56ED7C7E964><2D22C5E6138860AE600CF56ED7C7E964>] ->> -startxref -2226 -%%EOF diff --git a/collects/scribblings/quick/images/img16.png b/collects/scribblings/quick/images/img16.png deleted file mode 100644 index 19c3aef5ff1ebef3225cdeea6fb9db612624425e..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 212 zcmeAS@N?(olHy`uVBq!ia0vp^+CXf>!2~1=-dx!Nq-J}%IEGZrc{}YOSAzowtMQ-z z@%P?232FY~`@GKkt$~fP_4AmoGyc|n$=k6{j6?MQ!OI1NBw>H^wqWOzggr${J#f)mB}ry+tbCxH>syaV*q}zrZ)^SCdwRLq?YT?Kj{1IZMrY!=Smm zw)FE~pM0U&h#;|hQ>#?)29Nh-4;28@!i_MJJVCe-G0E%P7Xf!&EtLspeQkW_%?^2J zb;zmO@@IE`{qoh|>)Y?&=btx!<6k{Kd+)vN4_?x0e{a8hPP=$c`wso_aQnfdhj*|2 zc>mgiyFWd;div6t{72_6o__M$?-$X^nQw1?`r^GS=WoBU@yiSM*Pnd+&AIe!a{AQp z74#>MgQ-e@l$pvn^-qbdO;P!U2c263j+<G3k_&f#An~Ct-Ty9~A4G^x4<$7C!-@vG7!EwAQVhP+SQUS|QQ}s&RB!CDj{U|da zMfj~SNYR$2%xh^o2qX+aJ5|!AtaQ#gWwMPhFzVrr?!B@5sNm5-<{9_C-zt>GI@ z4^h{hDpGDtliVt5imkPM z!8R!6%phL%XxmmV2ooO08W#J)JZ~?k32mwG26mBr|c~aHan;U4oCsH|4jY_$K zrQ@mRCtwg{>-oOJ#l(38kmHFU?B1$F?^Jb@P-2k0VVWIkIkpWygA^P>z)2uog;4^d zSABG7;D2AI{{u z{VpsTdBtOX7)z1%(Dt$ih#nsywSwgK$`Roivl2cR`JCKmDCm1A13aH9u7*zNoSdM= zD20(-)kkVj0(5x!nTtt1Yy9Qs_5BL0D-~zRr)sa|x}#c=;u(&Xi?E;$ zVfBmDRDQ7T2`(&HD$0Qdcr8{@;DmOiu?0jjCutQo|d3pHMnP)9k z8<)&{yZ7tyd(sS^E-s-j6^xac-rc*Ke)sOXx`&gqdp2IP>i)g&xP$`dgE?twD)ENK lt5><}7&Goky1)GoLmBVNmHQvtrvn|s;OXk;vd$@?2>|GANFx9M diff --git a/collects/scribblings/quick/images/img18.pdf b/collects/scribblings/quick/images/img18.pdf deleted file mode 100644 index 766c59b57ad9892efff7a5ef5e5f088cbe19e4f6..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 2474 zcmb^zO>g5wbcKYFEOFq%mC>TgskY8|>^P0B#3fCdQmEM|$%;yCktX&eF||Fxo+xQ= z`~tXeLCXaRX-`O;IRGb+;J_c?!i5VG`~==OUu{}#Idm?0dEej9TkU2`BgK-k_4D7K zeXUqXN4)>BQmx`+mJG!Rl>yVituPWSMYt7F!J5qH0drj?6DgyyGJF1{r~hvD^hfo= zSI>X_=B?n{&p-O@)i<9N-h0j5`SC^Jizl!DqWxv`{(a@oofluCY0vuU?9;PH_>VWf zV@a^k0+6&U?d89^vcQzqKJ_lg47cf!VUGnN-RCoOssp)#D(4CiQkDp0N{xW1;&G!IP40D1Oz27gn}D95g?r*nSva(FfY~3Q-ZLxk8%exgx?Q? z44o>{y^eB@K*I#A6RB+>N>-u^$p#fP;=`qig{K}9Gyn>+H%#x|lwbR;;HPa55!YQ9 zl3^^$*4b60SZD2p)Vd(%`CFP(aCg!dGNUKn@v_{++%388q9oP5*_iqlOrSm+hDlBR z=ldU26b3c*L(9{>af6M*cdt^`z51Z%UtRcipzgU!b&o9jaCi##1-V%s*>4Qv=1aA?_OBIry@vbVur z?nrpD5=*jT?o-j{F%C~KDe8D>s0rbu;aG$`LDDeo^NFabcA!(eWCU8JT(&eq7}a!m zTE#XhexK65Wd=)2<7*z?Fa-p#WkL!7a-ea8iOmQ58eB7Xpf zpjvmw4upB|2q4GfK{&WshqB#rXc4t&faNEvJ}s1^Y~1K%0&G^Ws)bUcnipUQs4&{e8i1)>N=#N2#v>XDcO zQ78w&iD)vcsWUBL13HO>>OM#Z}M)y@yk@UZt?IYwA=k zN`P+OK4ZP9mxEupYwow_^6nvNVrSUm) zt53uTaQD}2dv$_lDH|v{BDx}X-u$7mWtkQlpe4>M!7-8#B}*K!O*n%$ak^o{Ro}po z@@+nyz_s4wE8WJG$Zgq@1($n6wp6*sCsGmdKI;Vst0F@aH@&Et; diff --git a/collects/scribblings/quick/images/img19.pdf b/collects/scribblings/quick/images/img19.pdf deleted file mode 100644 index b8e14fbdc00c81e73570d9a1d334deb7e11b5957..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 2473 zcmb^zOK;;ucqOzKb3%LI$Y@b<%i@g3k36iz-8R{jE;Sn^Sy8Fml_vHiF?Bq~o+xf_ z`v+i;9Lfc>7Y_UZ4jefw2mS&Q+>rPSeB->@?22;eT=M06zdvtvT5XM#EM@E0zrXoj zv5}7W;7g@m$44w4i7_ezri|x=JQeMkh*s`Jk`=Zua#%d)wb# zzJB#V@YBoZzuo=g{a4wG?R)yikNA*HumtXqbX^az&J^L>H1xDrm$)@ zi;BXap?+a|x|cNBIQ;Y?Wxb2f`~Jn5UklV-SE=t(s3g;JnrOqKZ8F3%zj43WJ!;>V z47rm}k_kkO@<|kDPTo)p5eHz2#wsdU#92c<_Bu##9-V~(8Kqi@XvF*k4O2Q{GoGFy zQYx#UG7W}Kx7A)KgntcnEJWg9Je$o*Gqc3g5hk@-4eJIr3=KH6>^v4U*W&C$uva(| z90YDBkZZP#(+E5QVN9bV8Gch-fs-?22;zi`Q;1E>n z?Xd%49y|ib@pupp&s#7%4b{+zuIZL$7=2Op)qNaM4?Y*zhdYr)vW_jgd$>YF*tjXm;+HL z2f>MGJZh-97O)|mMnZL;#szmUPk$7;bD)sJYh3{OvgkaWtLw3^mU`XE5H5#!=utn6 z1<%Il*|rCWF`FTIQ^d2K4dsQfRK8OAmf9C6n0sggyxJrK5J{Oz~R{SKTfnP;e{9Ix$`BS#Tdk3me^E~Ze0DFikc*BdwrMLgYJPaTNu zO~n{+H`i=ub%OGg4HX>`U6DI){!rPrO&bl-5@%X)spLcP5=Uw#gnb>S8&x=38#q#a zlTRmbtvC5BxX2qgi@Ygo*>HY0`Knj=L`uVmrSK_)a4)=I5F5f>&f&((1B>usJmd%j zKbLh*2~7Y7un`OZ diff --git a/collects/scribblings/quick/images/img2.pdf b/collects/scribblings/quick/images/img2.pdf index 94573b751baa56c46a970218c11500f5db190c95..6be681c83f88b1e97bb99338c662c98a7a402e49 100644 GIT binary patch delta 856 zcma))v2W8*5XPG{38_aANL|1K!HK|mckgUJ+e%#}HIWcPMIvL1){?(Y3`zi#}zK5fhQJMfh{u+pra zoql?Ir}u99{Ih>P{c`hTaplG9(vOo5>v_^nzC9=rmy!6aoO_hZYcPA3H**I{2vk`7r*NBPNhtE<=x{i;Cr6`rd-c}w#2YcJ z15=zvBH2%Z-k|@|^&;QlfRMCRxzXWZldv^S1z`g;*n(3^qg$b$#Ii&$IX5n4gRm0> zht8fi2m=}GRvk6DdJsh;o3T{f553XBU~gOx!u{HOiuikBBO9k?v2`yKo|I&^nis`4 zvy0NT+_Au##L`aainqNh0!GR`w|D8OO?vQ?Y8t6OULO0 delta 984 zcmaDV^ip_&TfMEXBi|tdp54zy>l~klBzwm<9O?bolI7%di_zjk?W9YKR5r=nJ}K$7sQ*Vwq%OU}BJ%qHAGhW~yswn3||-00g>5Nl7M2 z7M7+drlyvYqnN#!%#0`ZvnuEjqh4L1A~z?m*s3CN@>gbsdWDL_0xRGAl+3hBm&B4( zTXiD?Ljzp{6I~;t5JO`tQ&THbV_gF?D+2?dMxat>pa)7)2`RO+fve3g3dzsUu?z4C zQ3y`XNX<>P(MOV-e38Y3IB#mQIuWN37!brMyv({VHYM3A8RVnaN*Fu3#@P3feIIKylr=kp8QWMAl4Yo7 z#@HofF!p`>`urE)b06oN$MfEM9`~2?IFI{$MjPmBf>=0N0001KYpFrca>1DwGSi<$ z%h-e z1ARfVk%qd;d4#t$!?zo17HC7Vd%911`Cv`hlEe?$&XT-N5Iu4v$^w3${tlBi&wGo4 zX6>Jg2ye?nO-~{8A@#``ew9Brpb3WGr5Xn>?Ix5W+42PF8A1QB-m^M050E@jSV<|A zXqoc~UG*L;y3K0eW0RF#iGtEH1kbUa9dGX~bZiM7;UP)9g7;-!=s%V0VRyle&A7SU z$%ev4dW#+YRl#cSk43hyr2XKAuA07-vdvN7Z=_~wWS3(v|9I>|_0>J;xs%Yk%z ztWDG3m}U=X{6eUyF{m4Y)wK;DnDR3t-{pOnm2I9F#FSH<=4JJpz~bKLd9{B^IoDFI zM@W3omC`#D=4bv&j@PloAv|T#gVojIi9Pp>4Pmg8#nF0f_9MFXo19JWdQod@Zl^W@ zc$=Qad}W^{YAWY;)cWjOrH!c5$&HPTXG;487z{h0s;ZjfJO6>N%b)&md%VT`Tjn<( zfHs2b(a?t&rRZ(C4Q3a62=(yY-$K~9a6ub5FGa+}u%Pw%WA4r{0c;9{i^z8On|+wu zi9IV`85tRx8X6D@OLOx>YE{MnXNH{nffP^F>Mr+4;GaDz>m=Es{wLk#L+4}Z_xZP;$3=*j-$3so)az1)*Q z9~gkO0I&9wAN`qCJ9eUevOBvv3uDN9)Pax;t?BADvg_CCe>9v5OS!(D)7;TYW#*Xd z7anFQz2*rQ6mOxDg(_IxEGuSHfq*F|FIAM4rN|V1B~lvi86)0nUvrW{F&M6RCc;T3 zwhL?a9EF!^wuqtUx;|B3huW~=KZX5>rAWiqh36i-YX{gC-2Gi})`UYQ@+o^qG0V|M z-zw3%OfxU7X=Qz^&XczEyQwNOHNC9mrY&$0MOnW+#NxQngXO{EmR+uVrSbZp4zZJF zGp0p53m#NTr= z^76jR%M0N_f({_Xv58zfZ^bXuxPIpv?yP7s+~^t=GWen!_R@DXM5)HOKu*caP3;}8 zN>T(Quzm#^Y*YU6bL6y7=mo9;bl_OST5is!`D5tmG#hm>G4b|jtD4-_eEbxC<4;Vh z9Nf0sl`!Q-1+yg2s>PI)h{F9_q=-)M+scv{-xNYi327zhT@$Ke0ZJ3S@iX+^^+a;EPP#mCjE`OH@5BI zVQauk_ny3TUpNoN$GcnSw5e#r{uCj3Qj-=q>|5rLZV57CNV7+z0ZwM3b!;&ng#PlUPIv))}p<|?xAK%awyLuqO0 zvX{Iz%C6S*!D2~SbBil()KuN@IogC<`S_Ypz1gIW;q#y!!Q#!Rj_)M7D-ND!%Zj}x z6Q9N`cRS~Tlbar9({db#Vi zC);KZ%ui2S;bB$7?|3Poi3SG3=HhaQ;96E^4O z<~k!l&7CVC-3k+7Lf_xHSAB$9(W`yVjyL$GZSCx^nL*xF65{AQ^dn)y#tJWOzU941&FLn&?f$!M2v=iz8 zf?5BTv_d-1SF;8)vysNi+&2^Exl(FO!1E9x#Wb8))w~^>{X2X9(~b_@Eg=06 zHY)CVY+&@4h;hyy%-yW#^9uMHc&u(->DfmE>hFsq9$_5e2^NDwj4O)iJ-4@>iHV7v zz|B=e`y?S2+c}`x;7FNQDii?t&9D7l+$|2zsLIDOyW|&3aTa0DP(zf%)z4pEfmkZl(t37J_~g$Qk9U9($;`CpE*j;P{ItL4NNUJrM|kB zF|r%1?B_FEESZzZNe8s!Hi6;v?8C3IJu4#X|JveVZTrK8>q2+}UE8qYQF}i*+e$u@O0I|W z=kJqm2})?ZlFFE~JlqIzUiZkK>r*Wy1;3+ml`;XHL;pO3wF;?i-lSP;`+Cd(N6I>p zvPVo#`XVvIU~9YDU!&krrQ)%+#mLnDul4D1o8H?r5P(oIyd^)l5|WhT+GJ5#S}GLT z>ApEXfJ7p%2%8|>kY3czjLU(oj_vtv{u^E4P>8(-X{%?KNVlaE_fhuYM~`O0?dB}= zW&NC#y2be9*r3Mx-!t2!YW2C>8a-RF2K1~cSL1^BOYXeFw|T7OVEzQ~UmWrd(O02M z`n@rw_|U_G88{{7fw)?6VP^Z&{j#;`B_jC!fe!YoRC0Mo^G_9+aq^`8O9|zY;X@f_&$PO$*0g^VPURdK-`u0zdM}X`P zbohR2xRK%KtxyC>yXvt)7543gQ}@MT8um>C;4nYB=U4p0fK7`?FPOcttw0d9{ik|DlwHU2Tzk zyS^M@n=B?;S@*&}l=t32=DVed;k*HpecoXv__^k*{@RSOAHoxHSrXw4 zH@2w{S_$Nq(bAu#a^7DgAjMltd}_NH1cjswONC`Jw}Nc2S;%GL1-V<4TM-}YmLHiu zQ_eUhUS9n}0j1a=W8y9(I^|nr7}(c`u{UjSVg$#XsG(${UWArWt-MnulEatMh4?1W zXXD+D;9{7bY)}e17&i`vyM3nf-*d~zU(8iFrp$ewonQ2$D1T(>H>w(muBC?(2n-N; zYRSSX;-1;3YlOUnq{p-UzXZb@Q_S{={GB_(a%$`6HoJG%(jTb9azB0a?loGB!i-{WXZ=IzfQ z$|8`G1?s=`m${u+;mwkB9pBi`-r**7-Z_#BIqbrvie4;z02!}Mf`qIB-?}$F`q2gP zl!ik8b@U_=nVFL}LGj60)Hl^l9KtTsE{#oaZ%EJ;Ia6NG=3>d?_5&L>e%H``-|V+H z@tE~X4?u(_e`T~E8~ygZn!=!8^hpWQQ=$kHY++|~CX6Y_==_~(r}yoc|LFTPm_@k$ zAAo>U;hK?5`7u7-o*IhN07vK7uV!@=$|;ib*OGYlfF6{cojoQdCTro_#2z6&E-sGb zWld2Qe)#ZVD&&o$f6a0(>%t(~NGR=gVsZVY_%n*5!lp*Rv2gedqUDQC$|hWJV2Wtz zRxckjl2?22k@g?Aw!S32vgbm$F;VSQ^bg9rFKsMZr~-kQB6}2Xg~`$_N7*7tUOv7i ziwAfZ_mwNgQ0U!bujUCUJtOe_-t@p$ zCUh>X!kAUqr1XT-AZOCVuf;7te6KCbh5uRdAJP;~3^P}4A^;XjgX9nU;9)9k%t)*2 z-AmiADR>TTtgT)dk&2KztAv(-S;B+ebUtv|>R4AmOMW}l>le@Z=J0BVtIl{eKThbx z`17Nj&Zsq8T0j}mAq~$d?obnp znEJ@Wtc{g=?s2ncQz7WdPx)ju$fjtCtBFvWP+IBS_jDEm@crggejk**3R^*SH^%>t z-c=(gtEhS-m;_d@uiipI3kjDxwdh3cy90e(yH6uB!GGYN4#n`y$h9+8`W+(}!_J^W zYg&IwgIylJZr^x+HrOb94JQ!nl6N(mHYe2xnzX{XADo_R`*-mDeD4O`nXm^#A|> literal 259 zcmV+e0sQ`nP)vxTrM4C=xb%cc_Ef6WgO-5ut09LFqxh>wK{ z0Pen!kF~s>pUb6`lu`&Ggpg7yrF>+&yQ%^}t<}uTthGi&syeFj$p8T4oQbIS{tkNY z18rmxX|3H^tyM%eGBcamotYUkujTLBjxnC+c?Z{Z#TYmCXyslQ5$y|ecU2{#*4kKA ztrY-1TGe>voJEA0nOQ_~&acEmMqi#J;xzETSGD;`5D^h)=m{M{S5HIwH`Gya<7iXT-|Wq2gBHJb%P#Y$fic@ugJMT$BV+sV%~_pA%Et&u70VZWqMB z!~g?_uF|m}-NL}Yh8PeN5-_0q8*T%Me}Ug~zS>+x8Tyv|^85b&dA)0QB&AXn)_?u` zi*E%T$%vkOEHoN;pCm&zLN&nja3_oy$q?>DE+aPas81|Q$XQ0*SSTL9HIV<*2J%{K zu;lc0mMkYZUgA9)zF^7Xa^F4kKHz_reZW&Y;o1l%8=FrLu^XMbLHMcb-c)~qCr z?ILx(Q^L>*8HPzy{O6~iMHKo?@dMqFowQ9x;XCIU>7Tzh@Xk*?!xy(Lp|R~kC5cqH zsT7p`lOvLQ%{%She&-HnD9j>GV~83Rag^j{(G*J&6JUY5Tv&e73A*j~%u>)ZmJOapcs2>JrHq1^_RAoh$xBuU`3N0tIDiP1iLY1!#`bbhu6Yp=6Fz zj4GVTt2kLT;G(VIl&$CaWCgDEDxVH#bp=;dpO>xHAl<8c#w9+MxnV>y_$ETQAD$D4 z4dEW8aO3%bMR+d>DB?APuZ=w$9X7TMS*f?}y0#;$ExFb*+B+RvYqeT-Ta(*L$GVy0 Xn14Rx%*|MtP*qV4VSWAH{f_W2yzopr04O;T=Kufz diff --git a/collects/scribblings/quick/images/img21.pdf b/collects/scribblings/quick/images/img21.pdf deleted file mode 100644 index 0a66ba9f0d383c97f334d1278f27526440481758..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 2475 zcmb^zOK;;uxY`>&Aicvv={Jnwthdxl(b~e6y z{@aVUgCCxK`a6BO_U7h?e?55Z+b^CxdH3mC&yHUI`rikCK6?2Lnhwlgj=wx!tNi%J z3z`ITH2?|I!eIGJq&db|IW;&>DeihBid`CnUXvB*NCmQij1vh68BI9Sh07A|(VR^( zpXLxuH)DRE@*@o40^@GM_xc<{L0cs+#DZHa;UJwOk%OKDsJVHeZk7{-g?&^ykR$w2 z806?k67Kb+69gJ2V4YkNB}>t{WXt1T#6}Ahb5C8$y#OevcFlD4s{G1t2|w<-h&ayN zM-j%nZoR4`#Cod$gw{E+%-_PCg!_|IE;4%P9xUoj^s3=F^ODrJi`4VaC`YGs6ebP% zpPzn~Q5ZDjr>3jAX^W1-4=ys=zxa6IU!3{1K;Cww`nCs^q)OqX%CKyl9MRlwJZ$w2 zIu8XyVHa^4L)55q z=}36E6if0-=~KmLF%Azgsi=5is14y{Vah|6AYs@$WfR_zYk}&ih88GWmSrl0P)||e zQ%KdKx^-F&s+P8}lwR`iiYXv~Egez-kPVF+OnjO(s>J-GW=u9tlUAxWvNeug9zx_Y!evhRJ z{H2@eB#X+{4tz`_NEvJ}s1^Y~1K%F9EcT!=y)=zN-xK|cp{r!44n!XEh&tuq>_mJ9 zM4=c2JMxlILoSqn4!udlW#^Nm{=t>Q@Np1%82v|6RGvK#VL zEJ}c`-ac)$sTYI4aogN)!nqQ8hI)$e+GyKi6k+vfL^sWH3T2o=V1seJgQHZ$vW?Z$ zf!NN3j{$dg%{G@OsL1G0QV~%lvGZmhvP@Gq(GV?gx(U}>d?;DqNKJmdKI;Vst02)jXyZ`_I diff --git a/collects/scribblings/quick/images/img22.pdf b/collects/scribblings/quick/images/img22.pdf deleted file mode 100644 index 93e545155f8524ee0f732926dfe186989f719531..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 2476 zcmb_e&2QsG6t7m|fNyZ*!e~+D7I4Pnk2JOtmu}pYLd|BApzW$#q^UhgymdUro+xQg zh<|{+vq%Vpv?uN>4qT8pfDnHIH!cYN1>QJcZMUKv>Psf?{oePy_h!BAw=`0*l=Ywg z`r;eKMmpjrPn3EcAFy;FhNudZ4sOMXU^&9AgbL=fkVnk(ltSc;j+E)McY6BoW=~(+ z+4$<&FW1BL?@#q=JZq9YyH7P5{NVB{F9Z z01?ld`zXVh7p}9VNU_c;0I7A(Ec3T8r{M1RM97RD1_z6R6LZV*ym?9L+tZAOr%a#| zHi*-P`p*wPswj>c>O(uwgRIGh@%!gF>z;qq3(rqOCsMaPrM^v}l1!V@OzW37r$DR- z8+V(XgVtRMn7Y$ZHiD?pbd;opJ8h_?hzn;)#wscy;*nu$%9>K{Ccog@~eCVBqYUo7QbW1ag9x+|pcI~RBS6y9)AOYHh@c`rE z2B=qGVtL+!LVN9l9_ofeHez*rl~>0y-xtEY)dU2=f2UwHk~foPLE!p49FJgL?EC+- z?zdQ~C|tUkjq{|u+EIvE0x5$D2Gt_qXB4`9o{uP8Oqyj$98!5-G2ANEs{>QSB4J+H zI6H}$9g4H-zi_Y_zx-R>4q1PMr zVR?x60vg7t;KdL<-Uxs&WD_LUig>(vMR_SKl`mCZQ~QzxeGk_FFQ7@EHPA4zZhz0xaimY`F&a&aDaTQm)piks9PFN1FA%wf}IfK{`?r;t}UM^UK z_tQQ{vS#qw*!R&<-MDA?wJpmrsx3lxTQ#$065laumSsCt$8UN!BaY?sp%63|WkL;N Mn9BP4?){eXFRFLSpa1{> diff --git a/collects/scribblings/quick/images/img22.png b/collects/scribblings/quick/images/img22.png deleted file mode 100644 index e41b869fd2de6bcfb5cc9b317ce7ab1dfc7fee36..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 76 zcmeAS@N?(olHy`uVBq!ia0vp^tRT$61SFYwH*Nw_!k#XUAr*6yQ+}Lp;F%#Iq49{B X!G97Xr=`IzkUj=aS3j3^P6E_{MqlCCZ_`3FY-}vsu zZ!g~oUp@cq_t*bid+^rFFV^0B+WYF)uiyCVn{4et{@Sy*d;aqefBg38tB0j~rN?jn zz>;vT1|Vr#8Z3T^GRIger+Q~&hTC+&u+PGX?(iHP=|HxSb*um(Wr;whbXmb2mhnj% zundA}r#$E~afBgUVBF2cUROXUs9f+uEV#iF0n!WnwyvEW;sDv+DC;08Nwe& zVTO(r>0U=UMxbE=*2x7?vJ{<5HmIO6A1qYNJ@uKOAy81|is`M(@+-d;{HX0C;(2o) zWf=3ib+!~K)>#E0wa$q}{ubsG+?|{VnbAZ4U{P;kZdsl;FG+PfAJgEJ33S2+QBqU? z`RQjBMPW_-)b@3M++f4#qw|z?&p+t}=chp>RJT2)x=o>yOv~w5>lclaA(jQT`;E>) z>%L^j-F!42LDVQ8#YyJoHMJ0N0hVa2qJl-7*3?74jRfcMX(W(Qs+5RE%nwjMr6V@w z=_w*5M+KE>*mpb4)?6X{tEodF#xBOw>9jO8OFSK5QmIt1ZeYXEfJ4j95JZFgrEX(21_;mSz||V!F2N+K#3>uC7Cnz}kTA0NdggR4-vO((yQs0xJ6zLszL@6^J4dG4qPSsmEdl z#E~2XH>Sy;rsi76`g9Tt)q9*2+~F+!apcW_LJqHV0Tjrh^K_=J%bqRtdZRwv4)M^Z zL6iud4bhVg9}q(}Me?eMC!1H47s68cQsoV`FHkV|&<1$9RXhdV(RX)>R;v_Nc1@ki zMG4U5+h?pc^yP)|8t8%n@|5)z9T8oTJ8$+O$F@xy_0a-n+HkGqhmr-3R7|*_mvOpLfzx>f zN1W??I)Q6_mCu4F#1))HuFG2Xby=%?fls6~idhPeA%wfpIfK{`?r;t_ULIJ4_me(H zvS#qw*l(hv>P}^gn3Y{!FPC+_S#OnFbz*GQca5f1Z|v50yxTdB=z}i z*w|P=NNk6MkdT-VjEDg?khlRcA|@6VBp4a_p7Yn{D#}nV`SSh$e{Zc(t827iDr-Od z`N3z3g$Uv&r%Jhu4_ML_JyZlt6W60yuoU5X>~Hg=hA0Ze*NdpODqYe$^nuNNjKzg$xx;kbKz?He86zS?=tMM zF!CSpF*+hZHj#O(03l_GK!yxN!A+L&VH&UuLTscwXfbhwAql{^I~IE_0Rf^?&I=LZ zDo+GRXGmtIsQ_wfUaFg93Sns<Z(WsN_^sfF4G&S*o%$%lm{zm7rAV>nA^@p%O3d>&GpFFz@I=Ur z9(o6}E}+Ji>AKUBl()wNKR9Coov?0{RMfw|{Z2(uSW(}yJmL+itQWm{k+Rms>+Rs; zEU-g$+f~ZjK2(xvV}GD^@^;D)%Yw??YV)9eS2B#9aevT3cQUH(x zjT;UFmR8ig#sS*v@k~riqf()0sCXLrEjR?#x;}OwOoB%MIUWzA&Up=Hr=seF5{;Oe zuD7Y-Se9cIHBxj4fgpjk3OfUK$PKJ+dCtqzHWb=z9JEm@=&?R4<7HYI%Y0u7_f`|& zdH__< z*Bm*DuzGZASXMrTDoi1;!MNVQkt^cq`eN!pY-cEXfV;V78}k!1PFY7Gh!REayvc`( zmStF|gJw8m3qq71N@h4}TX6EP;)p@vG%n$2>1jSf;aV^A72z5#;Y{OcS#t~S6A9r~bip7tgqxhhjh6=&;r*n;k*pcKHuh`is9Y@)+k8NGOSZkGSIs)z l-Px(p60xaSBUYWbH**}z=R+p^ROAWOsR=K(wcUqx> -stream -xuM -0Fs 8=НD 뛙 })~zy@7.!#^V.%˼ԶfM"Wi\ Tܠ21cytE!42B#3AZIlJi|Nendstream -endobj -6 0 obj -152 -endobj -4 0 obj -<> -/Contents 5 0 R ->> -endobj -3 0 obj -<< /Type /Pages /Kids [ -4 0 R -] /Count 1 ->> -endobj -1 0 obj -<> -endobj -7 0 obj -<>endobj -8 0 obj -<> -endobj -9 0 obj -<>stream - - - - - -PLT Scheme - -Untitledmflatt@Macintosh \(Matthew Flatt\) - - - - - -endstream -endobj -2 0 obj -<>endobj -xref -0 10 -0000000000 65535 f -0000000443 00000 n -0000002027 00000 n -0000000384 00000 n -0000000256 00000 n -0000000015 00000 n -0000000237 00000 n -0000000507 00000 n -0000000548 00000 n -0000000577 00000 n -trailer -<< /Size 10 /Root 1 0 R /Info 2 0 R -/ID [] ->> -startxref -2215 -%%EOF diff --git a/collects/scribblings/quick/images/img25.png b/collects/scribblings/quick/images/img25.png deleted file mode 100644 index e4d4b58336cc9735c3f6206d1562f3a719ec1c62..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 102 zcmeAS@N?(olHy`uVBq!ia0vp^tUxTs!2~3;Wt?9DDP2z&$B>FS$$!o_FwKzAc)Zy_ zXX&cSp8x+JPgTEZ!Jxk%}!|e_al}*nwGc4H3-go3}q9RZugQu&X%Q~loCIFOB BA#(r# diff --git a/collects/scribblings/quick/images/img26.pdf b/collects/scribblings/quick/images/img26.pdf deleted file mode 100644 index d979ba6be1..0000000000 --- a/collects/scribblings/quick/images/img26.pdf +++ /dev/null @@ -1,80 +0,0 @@ -%PDF-1.4 -%쏢 -5 0 obj -<> -stream -x퐽 1 {O؉MD1@!EQ|~~7d|ӀQH"^! Jg/l$UAMhK$2P㷆KРGHf 4v酙:L1ZڛdӮ_,rfJM T\u+jCW5>Apx-'^؎{endstream -endobj -6 0 obj -196 -endobj -4 0 obj -<> -/Contents 5 0 R ->> -endobj -3 0 obj -<< /Type /Pages /Kids [ -4 0 R -] /Count 1 ->> -endobj -1 0 obj -<> -endobj -7 0 obj -<>endobj -8 0 obj -<> -endobj -9 0 obj -<>stream - - - - - -PLT Scheme - -Untitledmflatt@Macintosh \(Matthew Flatt\) - - - - - -endstream -endobj -2 0 obj -<>endobj -xref -0 10 -0000000000 65535 f -0000000488 00000 n -0000002072 00000 n -0000000429 00000 n -0000000300 00000 n -0000000015 00000 n -0000000281 00000 n -0000000552 00000 n -0000000593 00000 n -0000000622 00000 n -trailer -<< /Size 10 /Root 1 0 R /Info 2 0 R -/ID [<6C51B73DC3A90C9A3E8D707F4552676C><6C51B73DC3A90C9A3E8D707F4552676C>] ->> -startxref -2260 -%%EOF diff --git a/collects/scribblings/quick/images/img26.png b/collects/scribblings/quick/images/img26.png deleted file mode 100644 index 21a87515c1b6ed47b4868114eb8830db35cdc645..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 596 zcmV-a0;~OrP)w6-SVU>um8nca8;c?4bLEG9gF3p-E3#^MeyfSbk#fRH$_07jHM;02E2 z3Fltww^3`q^zYyHFO#<*j^p8QxL&V)-+$M~^E_2mF~)Hmw;7XZ)5$bV2q6GK5Cl!r z>iR6pEX$H*86ni`^$iO1t{mSr@=x7+Oz;gaGz%d*X8 zGZ+kLSPL-5vMirYr)rJQ=kt6%r)n+WIIcKT@Ao@%JRT>L$-7NVgJSB;Xf)z^{$thx z06=fQ-yaSK-}kTA>t~exet)@KK9Xy<+fAoas>=)jfDo3qYIT5IE|=|gODXI;&#zXi z`bA#tV*tQxHlvhf5JE*!rqgNFR6oWPMWJCWP!y%%TFmo2iXy6;3IGsAQA4P0+omnH zZM*vZOq>hq(SC^2H2pvY0su(UwBbH(gl^6C1MeymgiujyKD9qp8vicNUn&zqh$xDN zVT56*X__Dib$w@bb)M&@X_gNKS(Yu!%CfBdH3)*QudhN6A?)%ckt7Mmc(GV`p7*X# i5Cod05kgwNo&EqbJz($5DR`~`0000V-*xDRjXDlVBI$fM?iP&55teV_r34F@_qQmDZ|(( zM*#VrY*}6k31Kcwrldgu0Z0sP($RWY1R(K97-67s3P!>V7>z4&4XMQy3dllJIA(-w z#RpfQZh72+`H$N?#20+eep(WFA^6q~ZOhQ<#J0Rg&q4-!e3|F^v3ta_1J@7U-8Z1Z zyY5yDssB&nNWvoi#;R>w;8M@qXOIeVqsxex^z7gztWkyRueZ8C^*T{b zj|@GgY)+EQcxzow)x{9kJ(o&9s+wM@Y2Unme2Mb+0yv=c-u^lM3l9yE3~4)H-Bz$# z%GqK$_olBQqa|j9vi?SZYVQ|!d_E``75&d9&7;vyMES*Rh?j6B)P=;VMW*~K) zEIPDT;WVZNFEHu=bjud^WYBE}gv7?FU{s;#P||Kyhp2cl#L&fev$31m`6_`VJztq? z$73*N!5POOq0|oNMwR=p7TQn45rb!BxGFn%x;h|4(N`HzA0g4(fq!FtdDddQi_3(kM@-65r0R_Cen+aU+s zm<%$3nj}m*V2mlqWFfll3Dy*v$yO%9ARwJ-!??#O_PxAkzfQu8`2X~DFvxk3@@!Pd zhlOGk7V#y?On1;(K$@T^R|p|N77bGa;02^FW{$uKoxbDB#EE%h$RQ*WWF4UiGU*IB z@EwvsW{2}(lm}eooTbdY!)11?0C z6C#D8t5FuNFvcX|Lr&f`M$bOkCpmo6>r+f&C*X;;i!4z}^~9k|*B1=Vjkq>%vpTAw zqWnO4E5Rcdb}uX(S6ErL z=-j!{i}o(2N^@<6lE@aH#(t44qum!Dtb*QnbI@3~Q*#ITr+GZ};|v_O#CWZtJsUba zz>}iFCDQFzXV&NZBl+5R4~gn$SFbsD-Who`@iVs_?=<*bw-!Fkd97}8%ZJg~L-z-! z{F3{#?^erk_~@>_@;Hf$*P1&U4z{&b zoIXSJz4u4I-*W2*_emS)zBsw%QPK%s`S(L}_y^p!@6wQQRpu!J3N4MQN!2y?w-scK zY@6TYsYxHdzFzkJ>RR68t5|VXT50Q^6H9mhdT8&Cqfq}6B{z?u72Wed(g1X1FLU1``Hh5oCQAyMhZ?X z{(e+?KaZ-F$+2q=EHd(zY?z*kZ1L8TRXpIWUJUEZ=gK1b#%=*^R=KN zze|srqQCL_i5>aNk8f08ubk4{?{*pc-tya<&Oh4^H9p(@iS@= zzx=fO!sXiPy27bJ9(7iIU4^i9Q(Q#T>5beB`l}lSt=T8p`&@rIxx0G8Qgivc6CbZ!W?a(xdf*}Mt^>m& zZABY=XJ;%ROT0#pFPSL$uxZN5s{R8utLAvFx_e!{vG0=9GQ)6I%wci1$$jfBv+cVp zfsOrfH5_@yrG7zS^jmX--QU-L@J4%Gk#xtB*d~s{o`}e%@PzD1YEAYmja17DR6qfN7?^)>whc40 zQ|&{a1qRJp?i~^z6Xwkz*km@N*$8F=*k&}CEHay%Whaq=GXq9gupNb-C1)k7;$WI2 z4YLRu=5eGPl#TKyz^N4YWyvI|Sun~Gu>ea-n<|S3nbkpHjw@B3HoUp?smxUWF`Bg#Znd>q{`~ zj7Z9_yXpX0kd@X0*vn()-?g9FC_EJ`C8z*mdYV)y7 zDA+H1!ngtfST1_Oc+%%#TomlGz40VqUFroBioxF53nmgjCl}?SU}^7-_X7Pyg6C=Z zJP^K~v^;^xNiI!cU@M@&KSp3Afyf4nx&TJvNfK<-%$firk)~7g4#2FJ(j{VfvE zulu&&Jb45Fdb%YeQs!AwrBBG^NJhp<%pNsr@Udg*1Kxy{T)6OX?bBal7$GWov~>jR3&J&{r&}+bQc<_I*a3pjNkVf8m$gQnJQ}Of=q{ zT$a83b%nI6@{&{8nB5~0TN3w+$F*xshJyPOqS7FHuIxN} z@03g_?MHQyRJiQ>j0RzyUb$Q;TYGxtS8p78Y49i`jVcw0LJk1pw${rBcFg>6tLawE z=W~}2e2%RfJ5gQYlG7{=|HUFBWB8OQp)8iGn;XT=jq<$1A*8hV&he7${s|5MHsq|u z1vfHq%%ZVNr$r?@k(~iRrBQv7x1mSXV_3_@-81@?nV4Occe?G-1JkXT>F4+ls~Yd# z!0b`4FQT)&`t&zg2%YX+Q1CWpQz!$UFIvx#A*_A-Uc*0zhVH-&66rYwL_jDfg5pR~ zs1yJY#10u5IOfdV6Dp0$lDhX>D{nPwf9t=$x_;iv8JJzxQo8i`LX{eM(%F3C*3rx{ zZyVN~v}DbLD;HEs1&X3YN4`qive!gIX8O4sKOVving?_2yd{=|-amYO8Q4D-i}vhV zdExPJ@i@QyQr6u47grUYTJrM;Q#Ozt$k-*4x##2P&4ZW`>lcp;4gli(hNZ-5$G3B3 zr;XNi_x61$bv|Z4EV|TQ_s~Q`raBc#dn-0w1%P2Q)17H_(?KJMrmjv@TPv!q754NX z91eZZAdiHEKo=J$nGB)PjLh#)6zb|k2%^y~3=Z}*+uJoYJ(Wrk%qEjbVPR~{uBhOb zmhxI!B;ny+)2D~IxEP;Q_9Ij);qfHZ)qtnJ|RY z*IF7>Q&4jmv)>;7j^5S9H_Y%3Bj;w`JeiGZG$@MRIeUEi z+Ra35nfhsOoj$5jsQ`dPA`P2mW-eJ+*syWqB_2+iY@ijHJ)?UxY4ByD19=?N!+z>?b z{`)^KUVO&zR|Ei=OqriwFOw;2Y6N9vt-6S)9aPa4zJ*~l|6 zm>Gx}tzsV0P4Jn7LfX|_euv17P;;`U9m2*(nC%r5Y9ib{d#>f=Xs0R;4y4dfc2ZK< z#EHQS2360qx%m%EE%WEcj~Ln$s;1CnTO-_#R_wQX_?dXuLU7M#+Sd`{JJ36Ey%wW2* zj5;t~wb_fLhwz)x)k$;tZ6Y_qv9+b@9&WP(2-mO6%lY4YQ-ax%k(^IHnL2bR7yF2! zP+Kef;)~+netTrJZfq>~#ECah6f_!Ct=2?GXA!lc3zthjd^imNii;mFT69YH5{E~dOeM3Xp)`!{;1On;m)wyc51^~!phs~R(BqvAUn-+Y2_pV*V zXU()QJZ1{v8uA(4PgCh7Ke7A`>O07r>n?5}p`*`^9 z?UoiJ!~OpkPE;3s?@J=!6S)!gbF!x$xXm6+*w5X+ua)KpA0!xEEOmFME?YM0(@*n* zgPC!0<~QT|$I6vsR<9msTC6q>wW6X8Gnh=5{QUa-{CYzl1kqp}gIcXAFK_kpV_4Z} zzi}XGpLsQEe7i;Sd%5W~7j{61xQz#Y)Q=v7no}uyvwI5N&8W}Qr#*ar7iNzb;YW0< z%*^3wX)$!Vvx!)(fx)1@_ue?uKDH0FvQqn?i$t=E7i-M=S62)0ZqN3x=-Lc~FEKu$ zX_ILG93OYWZx3{&qDGWNK7?Z{&D|5XJDMAf`gC;2aGS|=F%inM6P$(EKGeRxXJT|J zZ8LlrzL+6b$^_l*h7S0|cCcrFiTmJEp}7<8^b_`Tx~Bt#O?CdU!wr3cf|zu=b9c8A z03JRR#>YRaq0@S7A8K?or@8ql00abhBqf>ez@no1ypTJ9_<0Uuy0Wm@YeCI#X~W;p zy;{w$YVXpf3PEgB2ckqx+7!aX=@LTCaYA~(CedRfxd;G|NDv$AbN%{b0NB0z+Mz>p zh{pP^F2zqjRZo}@Xnk(pKWrarOpG@+q&78)!@}6JXGdCdw`UERM4k~d``FDR0C4c? z{#ip)DUQ7<@4muam=Ql{L;y30=q6%*3-WtP#ts}p78WkWr>HU+($LU>jX~Iq5~H?O zq*7@=`uZ{qheAHTTPT#)*K4y>wOUhI*@j=GQXNA=ScZ}ss8Drz^hksk>V=w~KJ@6( z()RXl6h+sszo<~CX3dJEQhUE}xg4peXe%#oeej^2N_ASZW;~lcFni5>No%J}yWXbx zJ-$X!y))Sf0H{tbMh|cPEk6Ckt^cSrDq(l~$3L&%H1ktuvNHf2DB69kt_btV82y%s zc7-~9Q^2s1L~bM#@3;Q=;nLcxmjQt0?z#GGG1ea`K7M;fL>FVkn80g7j(d2SOAdogUi*=v0 z6)Q%sSu@^r6J}AU6brM{^iEtF;z?ufO8+|ACswa~Z$Z|PYhPnF&Dk}G9sH!TSuB5w zl|=i-ewT3yh`I9h&a1}`VD_rh1@7LyM%_&9x5iGHjcHCM?yN5OCHmEwM%{Mon8D|F z-@B*X5@~De*4vxHaBv`P+&CG}&~tMinEe$207cO&SL!4Z1%p8WfSMYCS-}B7XQwRVSmm;{)yVJilaZim}RhFkcbrSsYcp||80D04< zO+?q2{(*PT|A39qa&c$ej5$W#9334}Qlfl(81?lcqx+|>uFiAj#BA9zZPKLPwPgl_ z+SDW#iDZWUy7>FMFI+f0Awio%a5!{KC^8vBRE0uu95ZI{^5vsFJoE?U{)Ot{;nLLf z)NH7Je(rC+89#aQABL@%81K~7nD%yQO^wiKEiTt>+O)6@8xj)}EqYnOG~NtutAr=$ zYVSehL_Sm}>dS#+7L8rXpz1FNk{!rNQOP`UOM|Em@17mWPNRdzWzF4h`jv?4g8!D~ zox$wsYd`k%8%*SBYHS67;-mZWztwI@&CkjXddbu>7>Yu5wSdQyw6;pH$KA_|&f&O* zhkHGX(?Ql?`%q;vq`tnRuC9Z}lQ5YsK0a<-uA7gK+n@8)F<;VJ$tx2{g(2+F7{55G zqyB!h9;in1P3BBNLoEP!4~bZEf9twZPf9>1LzpL@Bd za<~5zvtQfrdF-?l6V7JNbU4%K;}$H#Y<^8uP0_Cd5~7_K3KT8M-h-J;{{W)AAIJPT zqLJyD_*%=8s!}V%v-9F15%9%r+8wiL?|o$U4QTV4b09m;-LjV(8s!rn9sgH-@5_z} z7#yFGX$#%h-mk9sN60AiC$h}sb9U?uIQIXq#Ez}8YtD|Xv1`tbt+8v)j;;A0HSHRS Tb)J%500000NkvXXu0mjfpG51K diff --git a/collects/scribblings/quick/images/img28.pdf b/collects/scribblings/quick/images/img28.pdf deleted file mode 100644 index 63cf5f2e8f715e381ef1f3844e5dce8bbd0ea2fe..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 4599 zcmb^#d0Z1`wiapY$XYMN1KJVAfRaom7fDKj;l3gWQK5+KkPOK{G7~2Q1gsZG#RL5n z(e*yC>s1e2k-BQD;(=BQsMy+~$SNppsamfpp!S=DTX*drhClLs@BZGE_wa}g4CbOd z5#&+cyu1h!!+e-ZN`ZWRkw~1>GX_`!ATdZVVPtR`MuLqPg9qYTN{1_zkcFXf%mi82 ze>3?Ad6MsR^{KP#id+w`^F=?r9WNiAs z{QYb1t{aP!x^`!P6YD_MZS1!|EQ8uXqAuTRGR-&=jp=bjjq3=^pR&RUe1Jx!B3K|x zgaD4lNd^|O&WDf~+(M<%THFG{5=~RuSe!{fK;U3RgIgIu9%N-gVi^z`7-hu(mS767 zqp0lyB83EiJCJCB*$Br#0Mu?3tHK^}APtxW+w8KyNCcs?zzGm*bqtgU0|{xY$Zo8x z^!8-2a|U1xW~B5TBHFE2;|!()7#Ot!x^(;W6wvhy2#JbT!>Cf(Zlvv1?W$sYAeJwt zON{NA9at$O?TKZt?MQ#jg0qf6g5qOiqBIl0lV}2`x&D+U-_dgcW3u>e41?#~B_@VAHUUB}L zc)OM^T^*;6Z@V6FV>5^ZHBFFu@EB4>T8PejY+4e-W-A+E5Ri_vVcpX$_PxAkyH3JP z`2X~@KgfBI@?2CbgvCB6ED=f*+3upZfHXl-z8FGO7A;!?00Yt&Gl$}Y-q3z!|2TP8Yl>WwTJUzx(z3SqsnZ*7=<4>Q4YgQksFpku^uegWzYr#&P zmKOA{d@}uhbI#XJ>xJ=2_Zx1VdwTtLTh)uUP=9y#(1J+brFHouSE4Tt&8QuUH2gt~ z-Nd``eqNv34*ujt0WA^-z zK60)4;hJ$%V%w%X8nI_r?%ryH_??_OfBiojt54_V20bm?{-ki*!4t-!s9)2vTGHgo z=dsS&@ZkLX@%g32d6ku;^S)k07iC-XrD4ru8v2Gcj~=|}n=KTbF!D7i3fuJCC8U3;}ubeVbT zfP71XdQwHz{hf<5N43sxbk)wBu-5&)o;?? z9_KzeFJ^yf-iZ?r4-apQkBFic);6Rx5kqJEo@u#rJ9YjVgJ_IIG3v?4Z|98|m*R$h zzWTuimkI}RdF@T;aLDMss^t`O<)iu`YfVuHN*_-Mx!=FZ`SfR14 zXP_deWpvee^9@y@=e5U;5&v=fksEgP@_Q9GOQ$yV{jHdLZ~1RqFTOYoHN4pORXu+5 z$;Zpuas$%)=-G-8Te8Zzha7(_ z-&f&Xm$#>EHgvsKu56sMbb}^taef71mv?Hm!)>QJ*#6Js` znU=J?e;R@|R6pF@ zx_d-MaRbeB&Gt6k`6}*4$>Sp@R3pl6{Zf2=mbhrTs;Fx6_%_GTFN6P07j8}{UcP!> zIH7+UKI~lls+HteviaHfD+)`#D2yC9*Ws4ev{<$|_Z&lPKe^rebjOczSHFod8#v%u27L0IU z8wr!D;KZq;VTPiNsRRQHcrqT!MTOpQG7WxNGAKF~MtKqr5J~HjRRR95W34sg1Ne)ImU78lB6`YXhNI1kmSs43x0!w)kAqQ!H`5Q0@MC;XW2MGJ) zVQ`YG!HAHY83^V~1xLU~`CPt;D-dWhNSN&B$<+Q%D=N&hCCAp|l@td`OopaMH3tr)ayl zSbS!OT%{=)?2XJsHKrv7Hr;FyI+5yHPUJy?P0^F|)!uMZO~THV~+LkOoL+ zS5ZRn8~VICL0zpBG-w4UgKd;Awd!u;VMpP6zN+rMz;Md?8N`z^@Q=o?2lG2m{9UEjE{m{wl|#!?5n+C5+T?Zd%=8!FX=`3 zQm|_EqLaMBJ|F(eyh15h_m85#py0S*4K0wb|R7Fg6pFcL#iV54T&1Q-b; zlPTD?GJu695Kiz73Jw;Fgs93Nl?J0SiNDxiDv}5UfdK-3P!L}dpnN?=BD<_x7>s6Y Q0TQ7S3FP4s6cr5p1;|=2S^xk5 diff --git a/collects/scribblings/quick/images/img28.png b/collects/scribblings/quick/images/img28.png deleted file mode 100644 index 74697eb3dbdb420a9e004c6678aa2ec42d289dc6..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 3711 zcmV-_4uJ8AP)QkS_nmw0 zeZe6J0xn!k65M`k2VA%q1+I8?F`011tBc8mD_&hpCS39AVlqK+wgE(^yH)lr0K{g_ zcf*grIh_vq<(F<$_Vy;m$Fs-XgyReiX&V{@YPHU|F*%t-p}7B6E{z1GMp4s!{py{n zB}v&~%!rY6(dspgyoQ?YtBt&RD$y&-FJ^J#QX0wIMi*g6OGov^*v$Df7RT=RIA_6Ec;??JK@ZvOD^Z9y99`WeY%y;1^dRr}ePKq# zY|G}9ickNLp^^{M*qn6-z9!QdwoN#9e&yb(t3FYT%1Y^gQ*Ax4T)uqAJXjwHVlv5IUPLc1;&1JaRcgAgAE_=LTd)E^ z-nlJUuucz6Uz`5IytqZ~cn<*3>b3c$c|+PE^Io3bKJia1M&;VllY-V;wyijEe&ye8 z?7UHh%4y5jQkj0vutKGJR8%~V%0wdG873SgGLrH6=S#4cQBk{40f+mI9I`?bE0#zg zsCe{D!NYhR^y>PrSAA;nk>I+f(zxzgKB>n!EkoCD#tG zdE|NXzK^Zne5>qRty+a3$i+iN%eL>aVaSQ|Yt^xXs6eJO(pRo`o}qvMFZ7SeBse6Jxef8_w zlNS5Z*a6eBpGM`|7k=n%yKTdev*uT6FApsX06@y(Tn{qUw!TKAZ)+2^w1`?-L_^*B%n5QQ}q0o@Y7S_=S0&Q(#jpn}8Fg)CcNVM~&y1M%1at$iu@wn({UsSHI z7u3{ndwQfXF}@2H#CUpI9%l@$ItZ6L*wiF!ZWc-;L$R@badE83NG2XX{`0dhl{GVx zHQHW!L|@VJGb%ryvB~7>x<@yjzIj}y*WHzL)%DaQ1*V#hF#V5fs*e{VdOd<5*H0f= zuw|PyTh5Btt0xcZwORnc;c%&0cGm2bm7VXr^8=SFHEAc4-KS3vuCDG53i3XCc9rob z^z+YcZ@&56z<_B=boT73sZ*^c9<8mSHET`^1Tw6}%Zqs9#-?l6dI}24>+AVgdtu?F z9XsY`WQ02Isw43EgFALql$M%KIYc5MJ3D^UrgRpIGA@Q3fjiKn(Wz0{JRJR~EDkN; zZhtobvrhJ2u;q$DFFgGQs#Xta!sjFOTP z2j2r~8vp{PCeZ_et*L1=`qy7CUAOL(c?1A}LZK-yZ&xTZ&CPwawLIfX-+$j~9;|k$ ztn4%nRshiJk?q^dSFSu}9IODq=MQe!aE8krbllZ3bNqPy+_{I$gB1W&D(%suwOLt* zYis%DS0|V*aVIMHkQo#Y3*Vn9j8IhINx9Yr!B$-=`QY8U>(j(j%jN3g;_FxuIyTnt(MLm2S*6m- zAa^2=oaaPi`uwQKK7|5+^RU;p~V+_{keP+u=7F20_U!ikDvI_~Ni z5DMk5zItA#(*pn=@3w8*lZzI`Vw+)nzU-4vE}c5n005nxl21Rq{N|gp#>=!L;J|Vg zWOum+0L&?2IGkbk$~b;Za4RY*I(FEP z(2vC5-|NVcTr2_r0EdI^5@i^mIc7#PDll(F>GyMGdRcNpR zKw=_$*RF-nK0BOgIqvGHICJJ!U!NQRa5&ud?Q?T;6ODIn{r#y01#=fHh(=$2`Q`PV z9t$bTpZCaqUq1LQ4#o(rd5Hu&p!kt~N9XP(dV8eD__mUHzse zAvWDkJj{FPDPL-Np(z+NeEm4yR{whdK)M$yI*rio_N))6xCu8#H)lEsq6gu(F+Kn0~*A(Zu+D_{kLDLx@K z#=%0x)7$E)7s94Zo3gU9jMrNL(BI#`eEIVI`}dE|@p~AbvJrK)1tnTI+7lMWpi(_# zGBp6)zAa2ian|kLaVFl?_;@y2WC#hN&!2C9;*5(Mb&-D@38V)zC`_?j1OOE+Kjox8 zWqh@X-`G27xLt(#+B%dd>N2D~6ziw72rE{sXl-o`4h}wc>=>HJmX(!dWo3Qv!3Se2 z4gdfvA_kND?pVmZ004)B#6zJ`I@vbH$ zu+cQ2t7{-S+IPv4sg8{1Z16bz!uTa$RUZO?1DEz@C1w)|!zupfm4?zyO7OH0Mwqoh z2KYT#8tEGvX-$m)0C{MZCM^#O~#n&l#^L*la4BP4)GqNF>Uh z9;r|$$J`?l2~|}a(FF0Mk1C6cZkLTXK zzc*i3jm_0vyDlC)cx@!E&YBf^;6OIka_Q2YwQEmdV^Sy{p`kuZCRwS}2!-+ufy!hLN*FWzZh!ZH zvL9`U=Oq4f^$8opmVL47@>ly%`Q?)pGP*XN`XLTvR{hg=7xLcolI;sbN+mj-3R~x1VPHm+NDwzjYb53=4PSYUc&QaweHxyh9fiyezhB{03cC_ zFSl2k$Lsoxm#%gFQr~kE02FF@Bd;F26zd=V*>YQJA-zspS8CY434b`lTCf5D{=N6! zv+Lp*U<8HUICB)uNE8E-l+gka1CYoQcJv3IuY2K&DV=taTw03F+xmHf~I#(@hhJvAIg8 zle)SF?7A8lNPFg))W;vcZ*L_bft{V5(Az6(Ztk<#%irH?-n{6%yv)o@tD7<-hfVY6 z4RD3B-XV?BnhwdG^l)hU+VmG_B-3&)-VHxLZV`8&r$f|+-4+OV_ea8J6z1%;{Rmf6 z#eZr`PoeUHE${mTPO+xx#OJpz9saz0e<3QbEG!QDovj-df+ES9#aku0DymV{JMi*JIRoX zNzKjkC%)PFHYzX4`&;6?r8bnE_Kw(s$eisQt@ zr~JP@AM3&fG#2OKoK;@F>?dCQb3~f`Q;|;py$lyF#u3-=XStY6xZ>5tWWp7%E+!MM dcy%$E_%8+0YLmIVevkkF002ovPDHLkV1lWtTfYDR diff --git a/collects/scribblings/quick/images/img29.pdf b/collects/scribblings/quick/images/img29.pdf deleted file mode 100644 index 709afd4a14a3c3f348340890a37e004af618a125..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 12588 zcmeHuXH-+o`meqo8`TCV2m}!kF$4$+9aKc51*C{ljSxa0A&`VlK&7cP>C#a;Nbg-i zK)TW)^bR7ux7>}s<(&6_);;&bS$EwJcdxZqW;ZaMoJ2zg0e)D%s_B}q5-*w!IDq}5ab>fNkZL48RJb*GBPwo5&?z8(bz}v zYYBdZY6%{>eLXs=DUs78^NnG%cFGeotl2-9{~_G`EI22I=ggy9osX^;PY{p)#&x7$ zhJFBLY4W=OpmnJ9P}Sil3`X-iMdUAYv>dEZ5OpLP1yMzrV32q4_8>h$pj!wke0Uqs z0G$MsB?$yQG?)gWfg<8<2*xNP;EFl{Z>)(T=|KQzK@de8AVm&fkhdo(Xp#VjK;pl6 z9;rPwM;VhqLWhDiXaEl(a(GJ;Ae9I@jLc8c@1`B9`4uS;8lp6ZY#RS$#-W#g^or4l{cG>x|(O5>XvRki+Aw@Ro<^ z0s4Ox(?8b|4It^TrhpXUekBaZu`vlx013fg-~sqr{;XwY9aa zk9=h2cBlWy0o-wDdbT#&BQ{N6zN9cbe6JSXzu=a3bk41?a2;=G(K}Z}i~nZ(m;yc$ zhmh791@{YBl*!MQIiC1HxV;sk$$trXY(|a;;TTc{+Dlu0vBSzSoSC7x9%!TgweaSV znK-a6w>XX^ADo_V%08Z_RCB|-TQ!xLXnh^h=_<_Wn;78kJ60HS@l_)52xN>_Ff#Su)ttu zM@F7lSSVX^vBXf@=ssre?Kx`@9y~Z(qOPw$@Lrx4jYe1E$TZWJzLkh1^I&vgiV;$Q z-j^RAr)HekZaCU&dQ+jaDS*3%w;{4H1B^$AiT4z8t2#{u%x>=QZVnC(MvCGM`JS<3 zo|Vdfp9C%x8eLXe8i*0EcrZTGlIo>ONs6O=x?MMIV1V9iH@8|yv1su2lJ-|Z}iIf~F~ zv`!~uS)9a*u(u19qii<&6P3dqO62POW4ERvOIe01$xbFFSGRM>WU}6yTHoRil6DZI zN)=nqI$yR;Q=B&&17?11QZ|toFSBiKdAWxusXL?lC}nBxlfMpC z!fc_+t*o!7E$PnS2$6^0yLK!v@Z7nuSI>5uqt1I~5K?^nx`e}hs1c!|-D%qV78Vu< zGB^Ay$n}1{7Ck4{f3RG*Ffsf6`$%t;)cxC*3%=f`t#fj6&~4>Vr;UVH=L>KXow7RN%~FDq@G(jKpRWLNVQlk3>(lZgo@e_Y|g;)pi^HQ)4v28 zJXF8h+R%1AD7vANV%#5$=}1n;uWc+Xb-q;P-Yu~Fff*|IC`4q5XE-Pyss z%^_!0BS{r-dv@r|BBOCSgv?5`iC_$uN0a-K)E;r-7xcfsW#eyai*YWb?Py&uG2~C;>U=d^=SG|Sr@ZWSMvA8Qv%X7JkG__{#ia%Q86(?xhQ3*I6H1t&q6EJ z2T|3;)Y#ZaAQ1WsERvU>qt#-@!odr=+EY*TQR7c6%+bbJQ%f!Br(vNi_cP{y~V44iA6&^-v`q{RKDEp3LyQ z?JpS2UH6?aO)9?e*yiQ1R$&FSB9Wh)jaJfF6S}=7w~?X}!5{Lf7C!bp3DGB@=i2*F zhuTfAP-=XqCx|R#ty|zc?L-k~F2AYT|IMbift~_P@pEisoQ}hU`^e-~_Ra z!O40o4(BRh->2=s^O(PXogzZkt7~sHD)?RyVZFQTQn*xWE^&G~{hHz`l7)$>z;aM`+>N~VG%EnCPbr1x zS(sXMm6s&?R)nK$!gE)0+pDV;97+;eI_LMe`^5PV+SR9$Tu=D0j!u2c?9B}KNX=kF zBXuyQhWiPckE@wvKivEhAmtn!fn;K`!S^4m&Uv3i{OGgrankdrk(A_jvfyR2a0*C$ zDTNHt30793q46fXrt!unMt)Wp+y_fl`ccE#o{@SISl%ntSu&J&^H?oZXJ=F1y~DlF zRLOg}Li5_MG&ero2GdzCKxAwaciQi=F*q@(%Uocrq%#Q%=GZM(o)Pf-E=|f$@7k~N zqJoMlDulMjKPAEV{riMIc~@DiWL~O~oqC_?+*7dJTpd~1+^nLfrzeA5(H7%nL3|0R zo~oirp9;FBH1TD^aNI2;lDXaJ%0h2WMUXL3Qt~8J(&>ED9D1uUFn8tsZ;D9dg4;<& z%q$wGe@E0S9a8DkkgroZW$#GQ74N^)2Os}%Sqw@P4jQ?kB(8Y7tEN2gj$;3MHMfp_ zea1jS<(3nFlK9Di)fHRI1rt2FZ=kNf`_5gC!ITg0^Y8Cus|QBLQUzxnTivP#YGnHL zi>QtCw@bf+hu?C2lSNn`*qUU)8YV(hs}cmPRfi^_!c$)pITfFKgcWXA9V`yXl^?tu zzjENS(4p^e++q6OM#O;Qr?dvc4gbcbmJiK=n`+cKt3`ul*&WI%zwBE4Sjk9#VYu-@ z3%k<5S0--T@i!qMC@!>sLOre$H_A_eA!&_<-)nbddr$V~W8#-TG2r{gNcKjHhSGxr z`X6vOaY;#Teq{|)ZR^v(OHsU+$C%R?ak_Qd=hE&R1)mN%Sd9S>D!Z=HFXa=6B85e; z+(Kw>{+NnSnvzoS`xi9A;ViPn&etXbxAkt1!)|iq*frTaxEpI|psy=Nq4Wi1gTXg_ z(|nZpn_gc%etcVgEGjAweXcB6&EFb`(TjM{AB{joX`_Ixahkx!IHHd@PKPD zk+00j=e4+%&>fllA%jWSlGDoYvPG8j24l!oO@?O9g8PmmjgI|kYyArxS!Ce@R|Q$N zS*3>@(1}~0CnB;}$7*&|ba&+^mbussetbAu5VH;y)UUvi`o&- z=*l+Vph(P2Mu~o(>8S3%8IJ1C}jqzRe`lMYwwV8?O^5>8qGg{D)ol)!Fr374TNTSc8V;$-5Q=a(R+*$V; z_zu4=Akf7BMNQe;Z@>2Goa8YDI$nOQ;fJ|fuf`Q_bo4OL%}p(+G8aK}vPaW=ZkYHt zdeaa)+Q;5Q9v1FA`S|s0KeH^e-NeLx_EGLKCkK1+N5Gpz&ecf1jO%PdB(%012)$+Od zuJh)>kKo|W_g8ig+`KAw()`p=DTY#0RxVRqZ36mESqOoJ1rq_ViL-MtJ_dv7?(R;&X}~a%jFGahlL)7NSoiMfI11_)+qHNNrfTxCGh*=gSn{Uj zUc-5L(R0eQ9B-1@EfjRT5z$Tztn*V-4<9{Baq^z@M%Nl`sop42=PGNuWF7htEPut7 z`i#p_z-802yRQmi!c?o=l;`W?JAYHJ`0?7zbXHG%UV@hMc&CTd@TdK#9L?sa&Q2{E z>}U*JS_;ty%@D^&ai(}Ev~F>aieOWtl9Q7gYfiPj;`+iJpuod;t6OgI7V}k$ujqI- zTWdkFwjTyH^fs-R)E+%nQhHr*nLbkXP9`DuwP$w2n%+hDrF2YhsREXR3cv6|e=2!X zZ7pj!+xwUZVee&&muejj*=wSk$qMItTQbTQ#YHMX_ABK-d1@y4rtCF1f-lb6v` zBfZsqx!rAQ0(_xg?!w`!OJKeemu)w4P?0(dS6FnLeVm=%8%1YTO-vcROxABj_=%wj7eAWT@L8Z3Fki|x?!|hi3JkQdyLE*ZTLYfn~N zdDAu5Ypoe2?S$6(!FO<*{WF2?M*DR<*E9PT@1HuIvRZF{&7nyG*OxfU7DIgD@1EwO zgso|86|-KO!}AJn=!e}H9ICa`xtoCuYK74w%y+`F~K+mtMCSwuN^RaB5B0*}WcjU?b)6B;k-@LjC7 zw;R*APQu&M8Co@`Hs*s|iM!^X@&|@phwbD#spalsQ@)j_AHTL3)M=(}(C^z#(?@f8 zMsx1o`*?gu7W;9||Dn%^*m&-)`YH3FF3gSG9J5ZZC+=!;zTo+Jej}gP51bKYHmGuyOu3vqZ||r`?ioS zEd_kCE)Qj(Y$zUR3z@YJg|-OK5%QtP}-f$gBL_iOOX z+4;@B_hA*6wOl{NJk|7wk(wX-+)F#0RYJO%sBdMwUgI1475XKMgE386xccP$0mSvO zU2pX}nWf3M+T>uDl)!oEeI~Ut3>?GkuHhu}U_DToMq65vPJEeG62GwP8RTofY$ys`i zN|X1}6Oqya?guU^HTxOxm}qhJ>`}FXRHc~f*oKzR@MQn7Qp)`Jv=ahvk3CPZV@XP5G?l2iRuB~-G5aDj zUwZHw>3R~QYW)zpPm7CO6Pn<+>0O#a3esMpaL8n+EM7IW6yLfvEBQ&z(z&amb+dGx zaaULWOR)XHOp(#nyg_A}JPkv}W9s+MH(QYW?7iTYEdb_W{l0++W_Eoxe9Vt;bwoq*rS%p#5y{YTpCTypuN?c zqd}P~MKcVMN~dT!li_={#;__H~-FD~`8& z2i!=>{a8e=>@fYgJ(S90-C+fq(;X2~q6^|o7f>yizY2eZ;Xm0vJb>(2LOPZmhNf^2?gtEaYg zTgQZEGfUSX=!Tj15}ypLVmV7}@?-O+jC0oWQ*~$A3wT)Kh>M#F*N;S6wU1Peaj*Cj1Bj#@aylY@IqjLt)y>uFjhE z*Onr}kRH*TtM`sbPkvmaxQ`CPg0Jl{aTbpG+ThLhR-e_Dp)-tbP}z+fmns@$B2Ffv z=_tfI)E}|y8fpcVqS{WqvmIsZTGDmNk?5jTg%_l~Q);8B)!oJZ;J&?Rs-r_L1Fmul z^E5m3$*OVk$*;?CZAtF8W9AwAJedmHUkQ|mC3o!7qRZxzaxXN+Qqn#!n^)!4wCnY0|KxpmoxFo< z)lKWVv>e!UshRYR*3_sM-K)FqagJhYIXOZj*^(|hO50cOu_y^AyJIhH4Wug6? ziar@ z{N&y&Kdv0keyZE~DwC%5F){nlLhHR4P787Sq&0pS;#Q19sqIz92g@SrfaNnyM4HJpOEupUG~OvUHFc zqf5}1*!<*TYPKd-KF~FTP){u`*p&^MeKq!}!)3S8pk^`ps`K8a5e+&jCL^qMzWe)e z9Z6{B-h;=M3vLs%eBUce){9fv7hBUg^!U%ktGQ5#g=409QQqNeTIyjO2JG3NiEQgC1l({)mR?j~@R%gH@74vxMGW8poQfMo}=dv~PT#P!k z{(&}G*v~-gv&aW(mrX^C&77{S(_&j>>*Tby5xl_h4S8#4yyH>yG0GNUPYs@18q_o#gCKE7AxBGgpnG}ujOB5d2*pL2V;ZXStT4HbFSQA__L zSYu&oBg}I@qqyCAGIcq^aCz*r=)E=HZ&VdQmk4mvL6hW?`$42IbY;+CrNLok0mmIC zld^u$rN4Ks^*X1wW11?D969-8adNNLiqDy{n>R^14q#e!8*448$1CMVT=lGoH1h4`Q<6Gp{gVb_G31}ohMYbi8->ChdhN zJ*L8EE(3Q)62>F@Vb8hIQCyw|){q_9thPj*U2LhueM%%&`SZ6(ge%wE`m`mwd6C_H znHP4#iVQa?RaRk!##zd7n^Ulw?HWO0>$$O11;(UK2|C@D)3glq?ZqtnpCeiKw+~A6 z)&@Hld+0VFaCCfr6;@?vy)q(?qhPy@AC(mi(OhI6*_hw$%`JyE**ag~?^+kSPGFbw z%!*xp;i)5G;&D3NmVD-MT=|K-15W?#r#@bOqVM@CY>Y%4zdM7cL3zNN)I)L*E+f{5 zi@%Z#mE_Zo;!QpCN~N*!#$9-KM!$FgetK%4SEh2M1fOWkJ@;R4$; z;*#QGrM;3p6t=ur`P+t$a}^YiM3m{ZZbU14`2dXl$=Nsh40@|u(vgmpHnC?tFBZ=6 z8qc__UK4qcOWCcbL%f%~yuPI<=^Jp{Q}rM@+Gviv=RT&}FWggEGGMHrWalGRzk_6vqzUj3nG_b^Q4H4HI6ZV48f4f$d2C z?cO7FcmDtV|7;A>>a&0TAZ|YcKjOyPr8V$!JZ)~e^@!^I`2KqMIsNVj9|Bgi^XcQ# zmfdj)lN)LM3m@O%jxhON#j<~!JB>Rg)qSzrWh2eOj4iH?NL!XUN0u<-hzOk)e=4d) zNnwq+e0cmlUGBfXN4eMa^@23j4c(T9)1p_sP<`UbnT?#I7d!77E{weq72#{+nm?hY zd&)sBNIeS)!Oz4Z*e2+G(ihK`J)rNA(xRVtlG*L`<-)Jgsh&cpAANG>P{QH;$AkKL z@l`sUT*r%SKW{|Vi>Ha~7|(JZ zX?u30Gt=5LLoIV>_O3n_lS)E505-mGFH+KL3z0!j64tQXP#nr%kF(|?@-VUL`cy|mF1DJm@`bq4+n`IQ%|u|8DcB)c;MATyp^G^dvYgK@x7dPkBf z(b^hVt2}Q5KQq(B=Z%kDq+v$};n~Hko@KG_0v&htdI6k(7X$ly?Vdgvxa-QLR;gnt zI;=I!52GU@N?oZg2P=g*idHpTRJ4a5yH2bH4!*Xttuw`LMQbwZ>2*!$ojrTjxi>U4 zRLv^WUS8f~2iOb)hbT3;NL8Om(Yt{(s&bLOaYL!XoKT{fjGz?Zr`7lpk+cff^XJdg zBZJbmQ^iV@YOVo$U5Nw}+B5K5gXcUmG;$kJx&9TzX@rIN;l`q;s;7m^jn<-lF>Ix| z1QR4=yyn_gb_3l}os{ZnqFZYqXQ#8P~9b=FG&&}1BU^+c9HrIq(mZOXrA$(sOr2MhB0kjMG zz~YEt^_MR%ona3^sFjeFEo0+74wxE>15q=jfOVlaiB>|M7s0Ok>&0oG-zzffU5j%} z)DO{@qk12`c!XQr#V66Lzyld%xxL({bZhG@tq69fbLr5FkU{KDDGMhwBcdvx>X<8f zr}I`?-Anp7S&64X7iN(-m)LOsP=~Dk@1c59PlAobkCKn>7pEGGTD3qBHI_53 z0!Q4q=ptL|Fq8>?@Z-q|tAjEUaORMCIx^OMRh6ahq*+*mU zw+Q3}1T6K6;UeQsHkb|NJFG($x5@Jn+1qIzPW|~f$2UVJC#YT)d7?u*;^Q=c> z3bS#JQ7ZNq^(Wtkw_AbfBBxaAk^R|L{<>Q`%w&N$?Vzm7ey@+sc*)*q?YU23_M@zU z#0TS(v^#dcCTQ18xh1$mo-K0|OP&EGk#H9NOlB*47OSsEG5u{%TSC1Cm3MmWGR%>4boIArFK+A+^4Dxk*Ip|SjTp6S1JTSJ;PVVUdrIaHuV2P$Pfd^p zm|NSlPnd`3l)Mr781z2=LyqwIqY~dA4yQ6d+}{en)0vc@(_$XGNJj2}DT+mVxVmboEub7iXYN{>BfNXVXSS=z$eL-5|e!WDnQ@_vWN z{X{4J0obE~{DGKzq^j}v z3qfy!ObJLF$_`Jk00{}ec>$3G6H^Hd05_M}O>B%&1ZiFcbrq0;8JZ?`Fo!f zi#N8x0YFj3yZ?uI|1YM>#Q0A$t!xO`pQUYL3_)RmkO3HAAX`F!ohHT-rg#Dl2^1#M z$_k4yMjqBH1gI)r87ZKXgdt&3GCwEIZ7k_m1B*GF2ohMNC0d%-9&Ca#McQCVyfWIB zKS!JV3O^Pj^Q-Zb5Av5Rpk;iRbUfjgI8BuGA97`IrT`|JbW0U!jIku)iDn@E>#6|3 z3}pv8L~E1u`Ti#SC-b53KSlnV-2Ws2^ByPz$e*i<3=QbNbp7`P{k4<=3$!$^-Qhy{ zKbC6Yzrf6YO#JKrZr<|&VB^C$1Nl6hUf1tR98N_+5n*8=C=B*<7V-kK5Euqb*Z(l$ zryxAx`d_mSV7qNYG6QJ;IcI!-Vz})IC{r2$=PpchxaR%3KyVlg3Imyf{-8lc0T&N1 zkmc_*Az?v508sxgG(kbA5CAU!8%+oXV7>oF6BGjQ?th~Ri2#7{ztKdX0I2+LG}ynP ziHQDB9WcSa^9l(9LH`nXL5H~o z@cxQ-L3&a`f>2>mIryEsVnT2^DC~})80@wX{GOP+Fib@J4pdI&KaVgt1nLt>NCN3+ S;Dv;R#DPCY@W`v(qxoMA%io0n diff --git a/collects/scribblings/quick/images/img29.png b/collects/scribblings/quick/images/img29.png deleted file mode 100644 index 11663061620f98d149e347c235b36aa8f3cd6d07..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 4865 zcmd5=^;6Uh6aNw_57HnYAfbSC9w8|xaioMtcef%(pCH{LA>DBx9NmpPz!68sL)}St zN!Ri6XS_SJyR$nx^V!`Wc6L6IA2gJR3F!y{03Ze{zt?{7g%4Upfcs!gqPuGWfC34A zFQ@CBxu50ZLG`hvt8?C09p1>w%8F0HEFS`}gppB95Fs~$A_o7WV_pj6M@aA;=Jmf` zi}0N~mh$1+5#S>b%CEtH&nyn^GJj9~PQUgo0V|7<*Uy7fZIh38*pkADIXtlPYI|qT zz;*}p5Mgvzc35WAcs&-z6K01rh#ij-2pRr& z8p}5g2f<|cEDk@J!4&h`PrwbQdiH(GpQfg#KQnA1p5L5vwymZz6QmbIC9z@hW}s}-i-UuMIivD9R8E&D?p#1$ z80f;!jFjo)>crT2_yNTtIXV>E{pl z$+TnHuU{a#*pkX=1(P=UXmHoM`Z%OmJ!gR7fV^jGrk}`ewoP1s=dm z5On4~5@)=89G-9kb-p8(Bb%)>BPAh$a8S878@G`~cdO$CQqAxTNn~k+S%}9`8ZnLz zMDp>H4lDDIjO!OkjRS->XE`U;EJJUZIx@s&^0^E~KXU16Y{uAMbl*u{-W)t@ z++Y|gCFX4{UaE&PQ+Da(Ih7DY?|pgtlY|gvq^X-BWJcJIlaC`=Px9G``H`1@%{G3N z(ZrZ0UT+&!-qYX!U9OV$SBG!jbu4&ck8fU@88!b`PA?^B++d?QaJ0M(7PPpNXv2nC z(84Fd4UY>!e5ME!zLcJ2vZZKLIn7gcjxDl+oRQqu;Qa3Om|78t>F_38Gz&|9n*8IH zRC+E;p~~*(=^HuJTr{Ngs%Y?bx!V6z1P}6$CK-NS!~Dvn>c^{r+o`Y8hUk5RI@>c% zqefbS%^0oVm#dr3`q+8v>yfJCTKw!Mfjh!}(aPtVVcqnTqW3ljPQ*Jbhn>e4EnjY; zop0A9-xVHXiX+5ys1(Lg-cpP~%=X)!s>5p<@I+<;&KkThC40Pj@&YC9C#38I^6;}t z2altkSA~ROMZMt%AEVQ(GMzn(EIS{5*rBVE*Ix%LfF0rk`*wbYbtcq0?dkFsT z-Wu!aKam5+cP}LRN-nE$(&usx3+_B#i*OQ>=76jgKgT-|d>%a@9}tEw3Q_^tru8lV zPQ-&mLN|RnkD4OG5|sjYbA&jX%))0eRXp4TxI;Dh&JIN(@f$Xfvign=v}JWXtAhY- z;ZHvJ$qKez#YkG=hiAR0sQkRjk=z1#Mwa;@@Mw zGTdEI*67?^^tqLLuB~ zUMyIeJoGUk`;s+c9jmxqp1n7>t=aSJoGG)jYH+ z_rnbm6cof0(^YdD7#h+kn?~z7k+-0}@RBDEfXrX@o~BR2HN7tXr3moBVY%Ljge+?= zI4%aWkEWq}u4&?EGP$dXUr6s&ND?p29^lYuQfKlu-~dP2A!&jZ*PdksV$mqWA741j z{zKgCn$#{h|Ed^S$Zo{!xIcQH&lKtR;hmULTYhl&6toi84HJox$s@I%-MBk) z*)be@-HUnv8olhVqs(#c>@Z)ilS$b3wi!nYqugec6#3dzF*h2*n$EZVZWt<2U7WY( zNAFy$^-}C^`}H&p(lLz4d)RJ)TZEWroYQMzu>iG$A^o#TX)GbrU{*U5VM_C{G(dZU z49Zs03F7o!A8akwB-uVgDmWPpc#`y=!D zCYnYbwA74v)8%y>q8Xm9NSQ|Uf|6xw&CcaM?|a{b*r{j@;!!w%CikOGNo~fC{?@j? zDsx_v{B!zp#qqsM&(>^NIBh~Q@x828f9zR)v$nL1!R|mVl5lr#uRf7K#eW??X{)$i zoOAW2afHlPzeYe2j0bp&i%RdSxmw_T&{a<5<1#*AqN9)=W&$kXv5{Gi>w8l)GV2?d ztgT%3D-QXS(oKY#r9NLDg`_e{Tfr>4&!6#BKC57L_Af-S>zSatch@DBhQ&5`QgGTN zZ?5LdI#WGGUFI(J0l-|1J6pWd7nOF{nSGpdQFgtvw=0r0DC2+m2?F^!V66fMZ|C1N zpTYn#5x+xuLN>W1z8e)=zc zBeeHtN|Ot+%dU8@bm(omW}sCuZV2u#c>jLS`YbjMxy z*?pqG@LOEqh!IdW7FrISPRucsXo2aC*ILdm zS+n2l{mvU72cSwaoAi@^h6DmHc2fNH<#B;2YML`!C73Gw2k&DK6%`c-1hR=T*;t_f z#=;tgYdsl}PXasJB@auVgyFt*b`H^~lD_LR$kHGIc7WAEJBqnqE3szA_LDRP<9tTa zSA(UCUy6(;em9ZM6kiHf*<;0lKf`(#nN@TzAG_V3TLjPn%q%QCVh)t0iBOpL8(HHT zT%7gCHO%^xuaMkY=ZwX6SdNi*q`~I#zp}z&s;$L(t~2 zWR{LchQ*)fO@R1#TCU__U+0--Heu_UY_nD>H-!4}$@P}8Ck^mklkhC1Z|D;K0!D&# zy)Lg?zzO87^*>MRZOuejU70epc~8ymsHV4;ae3fQyB|IR{*eFsC^lnBNp@^nM3Rkd z{b;$zL^S0Q(RU7En%SS}ENX1jS58SlmD^$He>PSbj{oeTU0!==y@J1f9QBA5tQ@c~ zmPBaergh0_1Hc11j15!BW*AV(p?aOt_NG{mOtTZYcuT8F*B(3&ko!W?`ou^Fx$y*) zIkaw@w6qpttE}a`yGhwMc4)UW&o^&#~fopE>LP<>@qxP^likb z*uJM93fCOuXFeY`MHr>P^^%kB)w|?|fmdKm4b( zI#?WjVtt-`tKDB1zS2s7&$L>yZs!|8Dl7tOVz3=D^m>~|$L&<8BEeJXl;#pAOskM7 z+LvV%HJu{q2w1R-!V`j_>ao%z zh-e*^L7p!%gK_(FYn`NXRTl58t*yU1TU0}_k`G<*bw_VOD{2`!6GgFGwBh9p?qLIp zrl&!OfUdd&|BqKA35)GlDc`0lT5k5KCxPkyiHA|G-^!n+8o9JQm5AMAykOq*aXn8< z>@8sO+w8VEF^ZD@eO8k`|CpLUNPNov=rF^LxM}a4n~fTcM<_cT{{e4u)#0s6a#4OC zr;bn<5UWwJRaW_8dPZ+bGV9xQw_}=K`cYGdpQUGa=)`fED7tp*KxTfL_*2i1B`c(Z zW~cYp?O#tZ`=0z67@^Xa$oQ(<4nvm2_%dCu7|7E5cd&RlrYTrG{Q-o&+^zBVM$@fo zcc``m>qwnBpynmVR37W3IBa~m;a6{Lo+Itwgwi63&beC?#)*77Epr}uiqff!Si6DQ zBqM2Zrzlg(8Mov-0!gJ4yHCaRMdi)s2)^08!v7gd_Wu`n+}4ttU|C;nc&;nHYOQ5D z+Px0H6OfVX|KTE(Ccz~`R7C;+GdQV$HlU4D1JnQj^V8fLCRooRu11c`l7-J`z}==m zVCmIaOB`2fl^YX$7bHU*Xpgnqk#l3Oyq>(a^iJ(4beh}s9slAsZ+RVBVFO<*uZ4=| z+%PW{A4A2a_ay=yyrT}BJlG|l1=?rZVi*hn_VPvemRdupop4Qspa>?55>-T@R!~W@0>c;5G5%AEnR5^!q z)sW*3DgJ*1>DZ@^-)Zn9nTLtB3=MzjaxGBx_4n)P={3^Kci)S}!7z#($tnfoTP7ccOtE>s@K1QpkK|;w zw2_gKa|q|vBOu7e;NkQBBwh}2g2CG7oI5=C4b|0Smt4J?jd_MzmRz$peX^Ohf`5B- z6@n9QZ*MuGENKw$7O_O?&|IkfKDn6WDEf4~30hsaHWdIShV<%_hhuC5-61e0up($-o_i>c;_dIX4G zZQ#VM0&n-^2iNo)Nae{wl6pQq9O9x0d(eY>XhMELvEjeBM3!-@-q|#xG@Q%d4;w*^cS*+j ziT%`W86*12ypiFJQHxx8Pa8&VR;RuSF!L5hY({un?IWINoEx<1$ri0s3HqtNX>-t0 zpy2F?$8Q{uvAN-ypi8?5^2(6hqn^W)(jP{w+~bIZNz5~X2}B;KEdZ>b@xDUdJm`P2 C<7w0Y diff --git a/collects/scribblings/quick/images/img3.pdf b/collects/scribblings/quick/images/img3.pdf deleted file mode 100644 index d0d2fbb1781f8be9b8ee11daae68905f27a91612..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 2474 zcmb^z%WmsL^lsQ#utY2wT~xURoSCuXq_z^5+@vWLH8&(dEozJI#GWLkjwjd?CGGAa z!4|ei7YUG%Sn&faV1dK}g!lwL0KqSC#(A}&qAWU_oSgUjc&pWD8njTkb`Q3)_@+>Bz$Q-qr_lf1zL5pvJdGMREV(q_+I>yqECE_qPf{^Hp$ z-@F`t_u2cu@-JJz@o)cl?x*+8p1i2l{(ADs$4@`{>hq_M-g)(y9HW;W{J8(Z^E?R` zN&r%Zl{ximJK6$MT)Wi09CO@a1CD(jM(mN8p;H3nT|`Ug8c>mrdLogtNi9JR2o)Xh_ZuyO$99%Kl=6@?i( z)s%m2?HqxI30S8}+d`DCL>H2ECRr>7OBD-GeJ)uD6y$7}F5i@2`>o-}Egwb_A>xZjBD3HWs6nmQQ9orPJ{9Q& zqJ@$UD$}s6L%9864Xng(zf*<~Wx%t*3Vz+Uc1 zbg~jlvO?}tArK=RonTrZcxk8s;iS=6Mj}DVFzbnltm;m$NQ#7o#%`%(8pBRox_%7^G;JW|vy7ZM(K*kdjLX1PQElSPrl(?qKyQD_)Uy zq0nCIsEazmkdJr;Z_+AQ<@;K=_nH9T|L+uxMyfN}*!SIr2qq)g7l)1iS@(M^RT!+? z98c0XZ|yL^Jcg9P27_u*@G}hDzDP$58k3F3aTGAsuNb;Y_bNb?k&L;Q4^AzXb0Ch? zAhCu(GTAR4qz? zZXQ2#y{VUjzkS=>@4&fId4_tb@!D>fTC?1+Ez7LaQj?Y(t5zn&-lb-9w_%s5?cL3Bu09_!$x@jo)TAcWwzl>k HH?@BN`MSzT diff --git a/collects/scribblings/quick/images/img3.png b/collects/scribblings/quick/images/img3.png deleted file mode 100644 index b45fa1cb6f1449f665226dadcb6f3d1e5e29f352..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 93 zcmeAS@N?(olHy`uVBq!ia0vp^Ahrkx6Ogp-v1SBPDxNNmAr*6y6H-!A4lqh67XAPK q|G4Ve7H@5q9> -stream -x=MA0 ~ATcK_čjBB8}Ң$L -FuLۊ[(.>ilg1<(3h0wk꧜$ -2zBv_\ U$endstream -endobj -6 0 obj -120 -endobj -4 0 obj -<> -/Contents 5 0 R ->> -endobj -3 0 obj -<< /Type /Pages /Kids [ -4 0 R -] /Count 1 ->> -endobj -1 0 obj -<> -endobj -7 0 obj -<>endobj -8 0 obj -<> -endobj -9 0 obj -<>stream - - - - - -PLT Scheme - -Untitledmflatt@Macintosh \(Matthew Flatt\) - - - - - -endstream -endobj -2 0 obj -<>endobj -xref -0 10 -0000000000 65535 f -0000000412 00000 n -0000001996 00000 n -0000000353 00000 n -0000000224 00000 n -0000000015 00000 n -0000000205 00000 n -0000000476 00000 n -0000000517 00000 n -0000000546 00000 n -trailer -<< /Size 10 /Root 1 0 R /Info 2 0 R -/ID [<18F7F7D89292F20542678B75862EDC0C><18F7F7D89292F20542678B75862EDC0C>] ->> -startxref -2184 -%%EOF diff --git a/collects/scribblings/quick/images/img4.png b/collects/scribblings/quick/images/img4.png deleted file mode 100644 index 60119f08424450b8e810f5da076b5b77e652a410..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 259 zcmV+e0sQ`nP)vxTrM4C=xb%cc_Ef6WgO-5ut09LFqxh>wK{ z0Pen!kF~s>pUb6`lu`&Ggpg7yrF>+&yQ%^}t<}uTthGi&syeFj$p8T4oQbIS{tkNY z18rmxX|3H^tyM%eGBcamotYUkujTLBjxnC+c?Z{Z#TYmCXyslQ5$y|ecU2{#*4kKA ztrY-1TGe>voJEA0nOQ_~&acEmMqi#J;xzETSGD;`5D^h)=m{M{S5HIwQrCQK3b|g3yzPBI2zc>_I$esfq`oMOo@WK~L)UCjWNR;(FM*=|HLAlIJrTAzbopMvK%5U22*_ z%pz(xh3Kx6WVU>_Z`W0 z!-X(lARQwPbwvPD-vO?!2R*{v1C+QBBYezrW3(u62P?uE1RC04ovaZhL(#ru!DhA} z)(0y3o?4XIF5IB(nCa>D@*}?me4=b2Vw!y)c^Lijs7wo7tTGCKYwceq2oB5%xY}M~ z9Mc7BZctW4olcu(KP$O|-InbvQ-+pk-3#*KZ=Zc3BG1i>FKL!+wFdNtX zXJy&Ry5d1o$Q`sHnN;f9Evc5&XN+j<lN=4E<$~AtjYf5s9e#Q7y8Yv=c_lh@^B8R7P&is1!?mh43#gHW+Ie z7@8rDlJUS$ z5yFYQ7W2XYal`gf*k*Y#yX0ovX~mT?x~@rtP+OAWlPCbQq^D(?o~8p!tu-F5GX)o5 zO9cqvWI*A%ZHGpA@kn_N9chFy>zPKGl&*@nANeLY1lf9U>~PTw9>K}5Lf5OEEkf_) zMMWmEB&Q`snJ22DX@-`TWZjTu2ohKeFoa+zZNO^ghP+`k4~aI*bMvU`G-#9N@c3O0 zbG+AtyQu(J)_+6LZ1T#qTb5-ML#N$@d2zJ(Kl8qcsdAm6o2_=_C#CH=nEC)2Ofbk6 z0Y6>GsD)9}hQhR4E#Gr&UauIcN;GqD$voy$GijU|pY;yD#~Z=$?Vz3)yOK+5cH3v7 zc```2-5&hDXZ8+>93JU{lf#o9Mm=>^`szTh*{s2eVuvi-@d6gc4Rm_a0z!j!5MN&G z^wgO0M3^fds(e816B6`2lmQ-26;nW)^lhG^(I|zHofkWNP{L{b`cp=edeHcj59<3V zSXUfp$R}^F$)dqqQBErgQ8g{;LJ_(U*q~iE;7AmO(d4M>Ky0SX8bI4PXH&x!)QxCO zkP(puKJ$7X(lt%hPz?=eX$@8$|4=ZXDY6RtYCTO>v#?diXo?P-d5k8L`)NuVUJ+w_ z8oA$wroq-6=gX|&W0CFoG=eu5!c}jDLTm_E!Vq>mU$6)t4Qe6cIfK{6(IQ&R&C2rO x;!HuFC8dm_&#J|uN(xGvs7gjwm1)h~nBxq8KE%w9SOTb`D4H-aF?*sU{0kJ3`epzC diff --git a/collects/scribblings/quick/images/img5.png b/collects/scribblings/quick/images/img5.png deleted file mode 100644 index d4b4a480f9897741cf99ba735ea847c28fc44456..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 343 zcmV-d0jU0oP)Z!1422!k4Le841)SUEFv%V=BTkehGwA@8DxpxS)a5VgTdh2QPlzX3)mlMD!!WeW zl~U`v3hjLp@&$le>q#WJy@Q><8Z3y9BtSf3V*IJ!(01#s= zrIb=qN{Hy3t9^oxhWOU#qK?etIBv|~y+_2H^XCUSX8`ct_iUAmbj}RSoKiYIi!m~D z&tkbqE#_&Om>GzulyV%GQi!N$v0S8c<|j6uF=n3U<6v19W6bXZUC|fJ-g^Kz{%VN$ z%Jp!z8002ovPDHLkV1hw2n8N@7 diff --git a/collects/scribblings/quick/images/img6.pdf b/collects/scribblings/quick/images/img6.pdf deleted file mode 100644 index 495d919428e6233eb2e865f9619ee9713df48190..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 2474 zcmb^zO>g5wbcKYFEOFq%mC>TgskY8|>^O<7#HGZWQmEM|$%;ztB2DZ`V(NH;JyG1= z_yus`f|d&s(w>kwa{x{t!GS-(g$oxX_zApmzS^{+96Fc0yzlSlosQSmNV%fy{PfqS zUnv&S5g&Y{G#dDrB_lCLRlsy{JBkHM5pKs+FpmX1WUi}ZB4u=<xW1;)p@IP3|C1Oz27go0Z<5g?r*nSuhfG%wXHQi8Cwj|vAegx`z8 z44o>{y{_^Mfrc4aCsNx|l&nRUk}WD|%ttE~OHX|!Xb2Q!Z<(%Lm*4oU;3pj)5!YQB zl3^^%)~zX0th@0-YF!eG{H@F>xHlUJnb8yfcvWs<)+(;MEJ{F;D({ei1hDG0Gh-E?ZVXJ%G zekd7oC!b6w5H-ptagsTCQ!PXsfF&BMs9+K2P4&d@Ai;Tj9tmWW?K07bxrc@+ov=Ai z&k-qCRZy9RL#OMtmkQxuQymL2bugaK=jFLs=IIC%+qSW8V8hUWL(47_L31t1-UNGv zBhkrPEXm4+PvwA5aCCx6S;s3w9)y!dQxWk5NyBu&XQHXvgRmafj8LmrtCmIxqnZv+ ztJ_9B7*IN}%y4CCdd0(QrhovpOh^Gh4m55!3s~Az4?D-`aLhBYFpcWvs;S~-(F&)cttcs>r9bJbYfwcw80hYxbtZrk? z%hNs-+U*?oQ7;&?32WeOS_8{`UkUeK6X5&*or1|kb|#(rzT@#=Hi3O{OM^h?r@R*IC2+2A%{1*019N$dAd;7V;`^dx|1QC4)K;x zgD4R^8>6$54~Q|FBY9NB+3uF|LRczatGuQ51q$XK+5oS&imRY|diSSjvr1uQH`TdZ zlmK17ea2=}uLi$#+uZNMxsrK?ddl%Cd5#=Ky|iFwfV;b9yXzB_r);R`i0F#kd5edtmStLKh*mhW0>?-`l&o;XHsK6j$LWR*SA7dd zsyF#`0@r$*uW}PtAva|!7F_Nv*-HHipGavGvlPCC5bi~n3}QpL%Q@V5d0-JfN`@TC zn!(q`k%vwjo^I*2wn1!5*Q<5IZhM9Y1!=YH8mZO}YVO?}&*bMrCTJ>(gc`&k%FfQ? HCvD|lhE>XK diff --git a/collects/scribblings/quick/images/img6.png b/collects/scribblings/quick/images/img6.png deleted file mode 100644 index a81d97a88fc60d909e6c0c54e12a33aaf4903a92..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 70 zcmeAS@N?(olHy`uVBq!ia0vp^AT}2V6Od#IhmdKI;Vst0F@aH@&Et; diff --git a/collects/scribblings/quick/images/img7.pdf b/collects/scribblings/quick/images/img7.pdf deleted file mode 100644 index 5d91589518be9350927fe9d221570ab05bbc6179..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 2623 zcmb_eTZkJ~7%r%^PN6Ca6?{2tyUeaQIWv>YWHTgFw>!;R%(Nl9)y3VlOlD3t<4$JM znG=#-K}3pGv4~PZ!BVZFSfwgd6f3sH2NfTR2(|R04=qJdu*DaVQvA;(*-I?04|`bH zlmGnJ@4rod(Z~x@BE|K8^ZQGOIR%L*C_lkvv$#O~8CpduP)a!OdX$6+=RJ!OgV=#X zbe)T6NUR#ydSm)!X~Wmzx^2xJr*1Dj_u;LF-Yk9g?&#Ix`=xzHMn2kY7Yc_5B=zc_ zb2pIr;yXKce}7-%{0pb?oj0Do_Q)?Ak8u}{qP^L>zf!*a?ZE4msVmQKUVr9o<8R?) zuK(PX#+k>C-22|SSAO`Q_>EqMdmzh&*cKy2d?BM2oCr8&^5&Ogg`%a|R z9DVYcP1aMNT)XrsUElocmW@Bo-a&k)6BpbV77PLQUlvuaLrN{eG(J}+xM2yGGpz{N1I#|WLokOE-b)}o_h6yQZeF)!eY zM*^RMbc9%5N*s_n4ls4?JR!_HK(PxE!VkMngeE!WV2PVXprHZQr6r=$f@nu_#G;lL z%ydlCF1rWMOn_sg&lJSZOf;rnU1JBiJ>^;ju=U zGE67TLbnE`WICnmovdWHwCa{UODHOn8Q0J8e;hx-BiG6Ck1D2U)<;OyeP});WAi)4 z?fF?d4yo$DJZ74m(Ip{2EI^%_KtS~bs)v{sIfMKriG zGUidtLT7XQgjqy12)tRBA~}&sNP?7n098V(Mw&r5i=>3ggUZmUXeA@xQ3$_se3jC= zhHOUjAdB>4k4QJsnrtvXcO3r9dRcX#QZ1``;@SQ8g?hJln`;( zkOAR@Zk@V;kCt;`wF zJ2_q!B~cJlf-H|qNlj5SB_)WeCW;Uwu#UjQf(f<)tDarp4Z?9qv|cQXqcOWmY9xz$ z-?EtDy(HXK1;8}_8-iMmRi;%pP0a}GMh)i0cH@8MeHByX*b8pf8=)7Mwqs-B0c0@2 zAX^gn>DXE&2x}G;rd6+du5Gb;#ZXneo`py1Qjh3y;|zPWeeqn@2%2a4GdaE`IHY1V zJj(04{FvKm!|%Cz`x49HMO|>SS<-{Bt!|9$>FU*M71(F=LDRBbp9WDCO%0epsFEgP zn~qKm_9%~qneqjdH_3fWg1(0`zzb7F=g=yh)l;-MN?~N@_$C{aa9h6qeZfwpqa1{YRP zDcoduXBr+q#D) zXJGC2&=mFGHdGPTZx5fET*5~~%k@YIA7}`Vx$^{KL%0+Ku;bZ+MR>bk2@uN}d~Iwu z&}3E;m9#n}NyB-0*ih4XBQ0g5VPiNgU+ptDY%_cb&;u z%V@B_i23{^P1=pgvf1AHK d{U_;gT(5Vl`RBDcvOsq;c)I$ztaD0e0s!-nS_}XH diff --git a/collects/scribblings/quick/images/img8.pdf b/collects/scribblings/quick/images/img8.pdf deleted file mode 100644 index 6666f2d5352801201c76da2f3e42e74e4737ab61..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 2502 zcmb^zJ8vUJ_;?muTnU1PQMhOw$a;46W$((~VC*scHoN0^$$H1^j%6qO zffEf^P*5BNC!Iuv=qZ4T0t#v*3h0oKX!rs5&H9y?h)`q{DWAXh``h(aqp6UhA+7)T z*Qbvp6RC(DeJE8bc#kH>ypJrvv~e?vIZY96#y+PF8nBSMu9WeV`U7e5@b#|xi{4dl z)Cylb{OR#4;nxq||M|J!UwoXsRM`K%b?3FaFF*L;=4byr{m154kI>lI{^9U>^|u#3 z|MkoFHoy6^*13P{=~;(ytaW*B4XZTECY zamzoZ*rQ?OzsV-(Km{_f;P0LUq?9Hc=^`2lw`s;kX+SfGvz4--L-_%QOaSBdgzt1X zM2X5dFNBHfEa4!XA(5W81gMz*PRumvNaj{!3pK)h#p5tRsQ?i?_?B(Rr#*zsot&@oF-5Gh(Rs7%A2({40p3gK5( z?sGnLFdmP`#j##w=`kj@ZDUo#nx+7UlAR{ppD0Q8D%i^%iS`#_Nmk5#Dh6zTqkT+@ zDxMo^KsaeM9dSaO`~$r(q%l0{2CmBYF!>X5T?N+fEjYzz!&|Bp{r!K0z@A1n7aAk)M7pb;z$gF6Z^?=Rh}pz?fIja z%kH~L&K*wEA4l#K$mQ@-7eIk1I!mYOI`pHtUU$%gv%=r-{2)p=%lhcB-~pmf$4DF; zez>usJQo(q7b-8QeU5^;hc>{At>Q}Pn%?y(TCP%9*;RQg79~Izub;Nu)bqhFTsHR` zaIQq2p`K#A3Jph$qH1Uw(M>a-LK&tI*kD|*;K&uRw6L5y5UY)NA8=RKY-4ePCMoSn zaEnz*?7ZnimTBrH>Y+JKFTrgR4<&OPu`M{07jddi;G(VINEr^<3Qi?(tygfQ^lyEJ zaS5&r>0XgF$vHlr`cX_%_)bE&6P;0r4dFIpaO1^+MR+&qF(hgRUmLp(bWo|)>ITso u`nF+fnqfDsI$-L}ZPm6*+h$#NujaTXJ|8mfr#w%nMhsh8U*Epnl%4>3gwr4Z diff --git a/collects/scribblings/quick/images/img8.png b/collects/scribblings/quick/images/img8.png deleted file mode 100644 index aadb50cf8abe635a9d97f6bd98ee549a179ed86d..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 97 zcmeAS@N?(olHy`uVBq!ia0vp^A|TAc1SFYWcSQjy4Nn)xkcv6Uf6h1X8$6ntdPv)w up(jgDa@I$6MYcaL^E-Z3h8WwLGBc#^Vp7|uVD}EFhr!d;&t;ucLK6Ull^fIm diff --git a/collects/scribblings/quick/images/img9.pdf b/collects/scribblings/quick/images/img9.pdf deleted file mode 100644 index e106eda746f8fa6c304cb2b4e5206b5bcb03f4dd..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 2852 zcmb^zX>1f#xD`?@en< zBz?R;z)Tzb>49~Ogg9jN-onIUxRsbWnnyvvq;XO&P~sq*EGU#Dh-zs>mYE`Th+;66 z)uk2l=e@z5oA`UlJ*(?hFF*BA-QA6=rl1XX?mqpyJATXz-hSX{?3#<--ScyPF z%{wOEwX*S#BcJZIZ(VwY|Im}Mg?Q50N6)`&^Pk;^cKvbI@7tc=yY>)b-EwoY`HsF}C(<>+Md9A z%ijO_H5VKn2)7vHHs3hcShHoZ&#s^I!s4f2zo_)vx(Btx&)(71y!4?<&e`zmsj}V!!%?TeQEf#chy373iD7YnWI zY2EW5nN&A*+xAE6x3U*JdfzW{F}~{Hdh6?->z5x~Q?@_rxM|s2*N@x0b^MmWvu1p{ z;VH?#WN^Zk-;8~m#{28uF&0%FIe2mI%I?K0cDMYnecrRNQwZYYv)J_s!8c z&rLL!33o2pBzF{E+Hvy?Cv-4&+qFMT`FrBa{ckhoRj;jh|6=jBZ_V(LukLweW&PCh z8~vv*Sl)8RTYKJFwC|NC*@or=-yhzeynKRk=}z(CCniLjF54xmYwi6<&tF=HQ`c^@xchq8`hkh10UA>JQkL8YT*qv=Glst|s~**v9o6ytKa>@SOc%gJFr5{Y0= zz=Gfd4qvg~q)NqS7N>wc&k?_8X_9sv|hS(={hPr&TNS%Kp@9~bZmLOU-; zB`GQed|WWfxj_PJGpuD;(S0CfqSiKq~d$ zDKHGTGZj0PiY6?zWWc^?N&L^ck721ab=Xb2KRikTTd{P%R$()YNF!ats9; zQ?c!Wt}1T7V(2PXjscPCv_NEUaGDBq2q@_8AVdp_nTxX(pGLAusX$q|!}Pedq4XDY zc?j_2@Q5yeRJZ7sGo&s<7S;61Mi!1Xosm*h-K17AkGdODfXI_Fa?d&Ko<2&sC+sR8 zR(XQjdnlNDXahXFRb&Q@(KmLAMph}T>^NI?7bQT)pFd$_Q`ZK+;Y4#k9nO`TXQ-z; zUJZ$;JBnOD5O`6NyeVX13V{vA^&}jgBFkwQnK}?_D$zXPPF}O=!zZZXkSxO?o@3md zH}s*PB#9Erq8ctFz-@9rWY%zk$itaD9>)cPaM4ELBoPkTC>+PbwH}3&1b7pS!i6IL zwhOo)B=Zlks)8&4 diff --git a/collects/scribblings/quick/images/img9.png b/collects/scribblings/quick/images/img9.png deleted file mode 100644 index 0dca5c1ff89e2036f24350c043a02867e6d2e7f6..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 200 zcmeAS@N?(olHy`uVBq!ia0vp^0U*r51SA=YQ-1-eeoq(2kcv5PZy545D2T8+e*9N{ zP5RF%rfV~&1>|I$h(2!``S@jL`TLJ19tCqBSRE{Fdi^Z_zwO^W7Kz?TNbLm!w({9wic`jB(*v7DnuSA<+~ax-}E{s3TP-q>vyJS912tO T>tucdoyOql>gTe~DWM4fZ|GK% diff --git a/collects/scribblings/quick/mreval.rkt b/collects/scribblings/quick/mreval.rkt index 14c1c969c3..22756b5aa8 100644 --- a/collects/scribblings/quick/mreval.rkt +++ b/collects/scribblings/quick/mreval.rkt @@ -1,6 +1,6 @@ #lang racket/base - -(require scriblib/gui-eval) +(require scribble/eval + scriblib/gui-eval) (provide (rename-out [gui-interaction mr-interaction] [gui-interaction-eval mr-interaction-eval] @@ -9,3 +9,24 @@ [gui-def+int mr-def+int] [gui-defs+int mr-defs+int] [gui-interaction-eval-show mr-interaction-eval-show])) + +(define ss-eval (make-base-eval)) +(void (interaction-eval #:eval ss-eval (require slideshow/pict))) + +(define-syntax-rule (ss-interaction e ...) + (interaction #:eval ss-eval e ...)) +(define-syntax-rule (ss-interaction-eval e ...) + (interaction-eval #:eval ss-eval e ...)) +(define-syntax-rule (ss-racketmod+eval e ...) + (racketmod+eval #:eval ss-eval e ...)) +(define-syntax-rule (ss-racketblock+eval e ...) + (racketblock+eval #:eval ss-eval e ...)) +(define-syntax-rule (ss-def+int e ...) + (def+int #:eval ss-eval e ...)) + +(provide ss-interaction + ss-interaction-eval + ss-racketmod+eval + ss-racketblock+eval + ss-def+int) + diff --git a/collects/scribblings/quick/quick.scrbl b/collects/scribblings/quick/quick.scrbl index 1db0541b42..514ff0641a 100644 --- a/collects/scribblings/quick/quick.scrbl +++ b/collects/scribblings/quick/quick.scrbl @@ -66,13 +66,13 @@ window and hit Enter, DrRacket evaluates the expression and prints its result. An expression can be just a value, such as the number @racket[5] or the string @racket["art gallery"]: -@mr-interaction[5 "art gallery"] +@ss-interaction[5 "art gallery"] An expression can also be a function call. To call a function, put an open parenthesis before the function name, then expressions for the function arguments, and then a close parenthesis, like this: -@mr-interaction[(circle 10)] +@ss-interaction[(circle 10)] A result from the @racket[circle] function is a picture value, which prints as an expression result in much the same way that numbers or @@ -80,12 +80,12 @@ strings print. The argument to @racket[circle] determines the circle's size in pixels. As you might guess, there's a @racket[rectangle] function that takes two arguments instead of one: -@mr-interaction[(rectangle 10 20)] +@ss-interaction[(rectangle 10 20)] Try giving @racket[circle] the wrong number of arguments, just to see what happens: -@mr-interaction[(circle 10 20)] +@ss-interaction[(circle 10 20)] Note that DrRacket highlights in pink the expression that triggered the error (but pink highlighting is not shown in this documentation). @@ -95,7 +95,7 @@ In addition to basic picture constructors like @racket[circle] and combines pictures. When you start composing function calls in Racket, it looks like this: -@mr-interaction[(hc-append (circle 10) (rectangle 10 20))] +@ss-interaction[(hc-append (circle 10) (rectangle 10 20))] The hyphen in the name @racket[hc-append] is just a part of the identifier; it's not @racketidfont{hc} minus @@ -122,7 +122,7 @@ simpler to give them names. Move back to the definitions area (the top area) and add two definitions, so that the complete content of the definitions area looks like this: -@mr-racketmod+eval[ +@ss-racketmod+eval[ slideshow (define c (circle 10)) (define r (rectangle 10 20)) @@ -131,7 +131,7 @@ slideshow Then click @onscreen{Run} again. Now, you can just type @racket[c] or @racket[r]: -@mr-interaction[r (hc-append c r) (hc-append 20 c r c)] +@ss-interaction[r (hc-append c r) (hc-append 20 c r c)] As you can see, the @racket[hc-append] function accepts an optional number argument before the picture arguments, and it accepts any @@ -149,7 +149,7 @@ uses @racket[define], just like our shape definitions, but with an open parenthesis before the function name, and names for the function arguments before the matching close parenthesis: -@mr-racketblock+eval[ +@ss-racketblock+eval[ (define (square n) (code:comment @#,t{A semi-colon starts a line comment.}) (code:comment @#,t{The expression below is the function body.}) @@ -159,7 +159,7 @@ arguments before the matching close parenthesis: The syntax of the definition mirrors the syntax of a function call: -@mr-interaction[(square 10)] +@ss-interaction[(square 10)] In the same way that definitions can be evaluated in the interactions area, expressions can be included in the definitions area. When a @@ -176,7 +176,7 @@ definition area. The @racket[define] form can be used in some places to create local bindings. For example, it can be used inside a function body: -@mr-def+int[ +@ss-def+int[ (define (four p) (define two-p (hc-append p p)) (vc-append two-p two-p)) @@ -188,7 +188,7 @@ for local binding. An advantage of @racket[let] is that it can be used in any expression position. Also, it binds many identifiers at once, instead of requiring a separate @racket[define] for each identifier: -@mr-def+int[ +@ss-def+int[ (define (checker p1 p2) (let ([p12 (hc-append p1 p2)] [p21 (hc-append p2 p1)]) @@ -201,7 +201,7 @@ A @racket[let] form binds many identifiers at the same time, so the bindings cannot refer to each other. The @racket[let*] form, in contrast, allows later bindings to use earlier bindings: -@mr-def+int[ +@ss-def+int[ (define (checkerboard p) (let* ([rp (colorize p "red")] [bp (colorize p "black")] @@ -217,7 +217,7 @@ contrast, allows later bindings to use earlier bindings: Instead of calling @racket[circle] as a function, try evaluating just @racket[circle] as an expression: -@mr-interaction[circle] +@ss-interaction[circle] That is, the identifier @racket[circle] is bound to a function (a.k.a. ``procedure''), just like @racket[c] is bound to a @@ -230,7 +230,7 @@ pictures (even if they don't print as nicely). Since functions are values, you can define functions that expect other functions as arguments: -@mr-def+int[ +@ss-def+int[ (define (series mk) (hc-append 4 (mk 5) (mk 10) (mk 20))) (series circle) @@ -244,7 +244,7 @@ have to make up a name and find a place to put the function definition. The alternative is to use @racket[lambda], which creates an anonymous function: -@mr-interaction[(series (lambda (size) (checkerboard (square size))))] +@ss-interaction[(series (lambda (size) (checkerboard (square size))))] The parenthesized names after a @racket[lambda] are the arguments to the function, and the expression after the argument names is the @@ -278,7 +278,7 @@ of @racket[mk] in each @racket[lambda] form to refer to the argument of @racket[rgb-series], since that's the binding that is textually in scope: -@mr-def+int[ +@ss-def+int[ (define (rgb-series mk) (vc-append (series (lambda (sz) (colorize (mk sz) "red"))) @@ -291,7 +291,7 @@ scope: Here's another example, where @racket[rgb-maker] takes a function and returns a new one that remembers and uses the original function. -@mr-def+int[ +@ss-def+int[ (define (rgb-maker mk) (lambda (sz) (vc-append (colorize (mk sz) "red") @@ -315,7 +315,7 @@ part of Racket. The @racket[list] function takes any number of arguments and returns a list containing the given values: -@mr-interaction[(list "red" "green" "blue") +@ss-interaction[(list "red" "green" "blue") (list (circle 10) (square 10))] As you can see, a list prints as a single quote and then pair of parentheses wrapped around @@ -332,7 +332,7 @@ each of the elements. The @racket[map] function takes a list and a function to apply to each element of the list; it returns a new list to combine the function's results: -@mr-def+int[ +@ss-def+int[ (define (rainbow p) (map (lambda (color) (colorize p color)) @@ -347,7 +347,7 @@ each one individually. The @racket[apply] function is especially useful with functions that take any number of arguments, such as @racket[vc-append]: -@mr-interaction[ +@ss-interaction[ (apply vc-append (rainbow (square 5))) ] @@ -375,7 +375,7 @@ To import additional libraries, use the @racket[require] form. For example, the library @racketmodname[slideshow/flash] provides a @racket[filled-flash] function: -@mr-def+int[ +@ss-def+int[ (require slideshow/flash) (filled-flash 40 30) ] @@ -398,13 +398,13 @@ Modules are named and distributed in various ways: that you evaluate the following fragment: @mr-def+int[ - (require (planet "random.rkt" ("schematics" "random.plt" 1 0))) + (require (planet schematics/random:1:0/random)) (random-gaussian) ] DrRacket automatically downloads version 1.0 of the - @filepath{random.plt} library and then imports the - @filepath{random.rkt} module.} + @filepath{random.plt} library by @filepath{schematics} and then + imports the @filepath{random.rkt} module.} @item{Some modules live relative to other modules, without necessarily belonging to any particular collection or package. @@ -517,7 +517,8 @@ classes. By convention, the classes are given names that end with @racket[%]: @mr-defs+int[ -[(require racket/class racket/gui/base) +[(require racket/class + racket/gui/base) (define f (new frame% [label "My Art"] [width 300] [height 300] From e97414b7bfc5182702c946dc7fcd024a19f7b191 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 27 Nov 2010 07:36:12 -0700 Subject: [PATCH 164/255] bitmap% convertible to 'png-bytes; more Scribble Latex; pict in Slideshow docs --- collects/racket/draw/private/bitmap.rkt | 14 ++++- collects/scribble/latex-render.rkt | 6 ++ collects/scribble/racket.rkt | 4 +- collects/scribblings/draw/bitmap-class.scrbl | 3 + .../scribblings/slideshow/pict-diagram.rkt | 63 +++++++++++++++++++ collects/scribblings/slideshow/picts.scrbl | 14 +---- 6 files changed, 91 insertions(+), 13 deletions(-) create mode 100644 collects/scribblings/slideshow/pict-diagram.rkt diff --git a/collects/racket/draw/private/bitmap.rkt b/collects/racket/draw/private/bitmap.rkt index c567b45ac5..13114daf0f 100644 --- a/collects/racket/draw/private/bitmap.rkt +++ b/collects/racket/draw/private/bitmap.rkt @@ -1,6 +1,7 @@ #lang scheme/base (require scheme/class scheme/unsafe/ops + file/convertible "syntax.rkt" "hold.rkt" "../unsafe/bstr.rkt" @@ -62,8 +63,19 @@ (define fx+ unsafe-fx+) (define fx* unsafe-fx*) +(define png-convertible<%> + (interface* () + ([prop:convertible + (lambda (bm format default) + (case format + [(png-bytes) + (let ([s (open-output-bytes)]) + (send bm save-file s 'png) + (get-output-bytes s))] + [else default]))]))) + (define bitmap% - (class object% + (class* object% (png-convertible<%>) ;; We support three kinds of bitmaps: ;; * Color with alpha channel; diff --git a/collects/scribble/latex-render.rkt b/collects/scribble/latex-render.rkt index 459deac0d5..7fa0e56b98 100644 --- a/collects/scribble/latex-render.rkt +++ b/collects/scribble/latex-render.rkt @@ -253,6 +253,12 @@ => (lambda (bstr) (let ([fn (install-file "pict.pdf" bstr)]) (printf "\\includegraphics{~a}" fn)))] + [(and (convertible? e) + (not (disable-images)) + (convert e 'png-bytes)) + => (lambda (bstr) + (let ([fn (install-file "pict.png" bstr)]) + (printf "\\includegraphics{~a}" fn)))] [else (parameterize ([rendering-tt (or tt? (rendering-tt))]) (super render-content e part ri))]))] diff --git a/collects/scribble/racket.rkt b/collects/scribble/racket.rkt index 0636420895..a42247c8c7 100644 --- a/collects/scribble/racket.rkt +++ b/collects/scribble/racket.rkt @@ -1099,7 +1099,9 @@ (vector? v) (and (struct? v) (or (and qq - ;; Watch out for partially transparent subtypes of `element': + ;; Watch out for partially transparent subtypes of `element' + ;; or convertible values: + (not (convertible? v)) (not (element? v))) (prefab-struct-key v)))) (let ([orig-ht (unbox ht)] diff --git a/collects/scribblings/draw/bitmap-class.scrbl b/collects/scribblings/draw/bitmap-class.scrbl index dfccaf6923..9d2cd6783a 100644 --- a/collects/scribblings/draw/bitmap-class.scrbl +++ b/collects/scribblings/draw/bitmap-class.scrbl @@ -12,6 +12,9 @@ Sometimes, a bitmap object creation fails in a low-level manner. In the bitmap cannot be supplied to methods that consume or operate on bitmaps (otherwise, @|MismatchExn|). +A bitmap is convertible to @racket['png-bytes] through the +@racketmodname[file/convertible] protocol. + @defconstructor*/make[(([width exact-positive-integer?] [height exact-positive-integer?] diff --git a/collects/scribblings/slideshow/pict-diagram.rkt b/collects/scribblings/slideshow/pict-diagram.rkt new file mode 100644 index 0000000000..c651669c37 --- /dev/null +++ b/collects/scribblings/slideshow/pict-diagram.rkt @@ -0,0 +1,63 @@ +#lang racket/base +(require slideshow/pict + racket/class + racket/draw) + +(provide pict-diagram) + +(define pict-diagram + (parameterize ([dc-for-text-size (make-object bitmap-dc% + (make-bitmap 1 1))]) + (let ([t (lambda (s) + (text s `(italic . roman) 12))]) + (let ([top + (hc-append (vline 0 10) + (hline 30 0) + (inset (t "w") 1 0) + (hline 30 0) + (vline 0 10))] + [right + (vc-append (hline 10 0) + (vline 0 25) + (inset (t "h") 0 1) + (vline 0 25) + (hline 10 0))]) + (inset + (vl-append + 2 + top + (hc-append + 2 + (frame (let* ([line (hline (pict-width top) 0 #:segment 5)] + [top-line (launder line)] + [bottom-line (launder line)] + [top-edge (launder (ghost line))] + [bottom-edge (launder (ghost line))] + [p (vc-append + (/ (pict-height right) 4) + top-edge + top-line + (blank) + bottom-line + bottom-edge)] + [p (pin-arrows-line + 4 p + top-edge ct-find + top-line ct-find)] + [p (pin-arrows-line + 4 p + bottom-edge ct-find + bottom-line ct-find)] + [a (t "a")] + [p (let-values ([(dx dy) (ct-find p top-line)]) + (pin-over p (+ dx 5) (/ (- dy (pict-height a)) 2) a))] + [d (t "d")] + [p (let-values ([(dx dy) (ct-find p bottom-line)]) + (pin-over p + (+ dx 5) + (+ dy (/ (- (- (pict-height p) dy) (pict-height d)) 2)) + d))]) + p)) + right)) + 1))))) + diff --git a/collects/scribblings/slideshow/picts.scrbl b/collects/scribblings/slideshow/picts.scrbl index d7add187ca..fa6e744b52 100644 --- a/collects/scribblings/slideshow/picts.scrbl +++ b/collects/scribblings/slideshow/picts.scrbl @@ -1,5 +1,6 @@ #lang scribble/doc @(require "ss.ss" + "pict-diagram.rkt" (for-label racket/gui slideshow/code slideshow/flash @@ -34,16 +35,7 @@ offset of an embedded pict in a larger pict. In addition to its drawing part, a pict has the following @deftech{bounding box} structure: -@verbatim[#:indent 7]{ - w - ------------------ - | | a \ - |------------------| | - | | | h - |----------last----| | - | | d / - ------------------ -} +@centerline[pict-diagram] That is, the bounding box has a width @math{w} and a height @math{h}. For a single text line, @math{d} is descent below the @@ -65,7 +57,7 @@ picts. The functions @racket[pict-width], @racket[pict-height], @racket[pict-descent], and @racket[pict-ascent] extract bounding-box information from a pict. -A pict is a convertible datatype through the @racket[file/convertible] +A pict is a convertible datatype through the @racketmodname[file/convertible] protocol. Supported conversions include @racket['png-bytes], @racket['eps-bytes], and @racket['pdf-bytes]. From 430d45b471aff9d3b09f21ed11aedae1b4067396 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 27 Nov 2010 08:28:57 -0700 Subject: [PATCH 165/255] doc correction Closes PR 11465 --- collects/scribblings/gui/editor-overview.scrbl | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/collects/scribblings/gui/editor-overview.scrbl b/collects/scribblings/gui/editor-overview.scrbl index 6558dc3a7d..f8cbcfcc64 100644 --- a/collects/scribblings/gui/editor-overview.scrbl +++ b/collects/scribblings/gui/editor-overview.scrbl @@ -720,11 +720,10 @@ An editor is not tied to any particular thread or eventspace, except to the degree that it is displayed in a canvas (which has an eventspace). Concurrent access of an editor is always safe, in the sense that the editor will not become corrupted. However, because - editor access can trigger locks, and because lock-rejected operations - tend to fail silently, concurrent access can produce unexpected - results. + editor access can trigger locks, concurrent access can produce + contract failures or unexpected results. -Nevertheless, the editor supports certain concurrent patterns +An editor supports certain concurrent patterns reliably. One relevant pattern is updating an editor in one thread while the editor is displayed in a canvas that is managed by a different (handler) thread. To ensure that canvas refreshes are not From 0b19c6e798b031bc191a3721f351cd4cb4a43ac0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 27 Nov 2010 09:52:11 -0700 Subject: [PATCH 166/255] fix bug in composable continuations --- as deiscovered by Casey's random tester --- collects/tests/racket/prompt-tests.rktl | 119 +++++++++++++++++++++++- src/racket/src/fun.c | 2 +- 2 files changed, 119 insertions(+), 2 deletions(-) diff --git a/collects/tests/racket/prompt-tests.rktl b/collects/tests/racket/prompt-tests.rktl index 3fea812086..6460afba5a 100644 --- a/collects/tests/racket/prompt-tests.rktl +++ b/collects/tests/racket/prompt-tests.rktl @@ -2011,9 +2011,126 @@ (test 2 count 2) (test 4 count 3)) +;; ---------------------------------------- +;; Test genearted by a random tester that turns out +;; to check meta-continuation continuation-mark lookup +;; in a dynamic-wind thunk: +(test + 'exn + 'random-dc-test + (with-handlers ([exn:fail? (lambda (exn) 'exn)]) + (let () + (define tag + (let ([tags (make-hash)]) + (λ (v) + (hash-ref tags v + (λ () + (let ([t (make-continuation-prompt-tag)]) + (hash-set! tags v t) + t)))))) - + (define-syntax-rule (% tag-val expr handler) + (call-with-continuation-prompt + (λ () expr) + (let ([v tag-val]) + (if (let comparable? ([v v]) + (cond [(procedure? v) #f] + [(list? v) (andmap comparable? v)] + [else #t])) + (tag v) + (raise-type-error '% "non-procedure" v))) + (let ([h handler]) + (λ (x) (h x))))) + (define (abort tag-val result) + (abort-current-continuation (tag tag-val) result)) + (define (call/comp proc tag-val) + (call-with-composable-continuation (compose proc force-unary) (tag tag-val))) + (define (call/cm key val thunk) + (with-continuation-mark key val (thunk))) + + (define (current-marks key tag-val) + (continuation-mark-set->list + (current-continuation-marks (tag tag-val)) + key)) + + (define ((force-unary f) x) (f x)) + + (define (_call/cc proc tag-val) + (call/cc (compose proc force-unary) (tag tag-val))) + + (letrec ((CEJ-comp-cont_13 #f) + (CEJ-skip-pre?_12 #f) + (CEJ-allocated?_11 #f) + (s-comp-cont_9 #f) + (s-skip-pre?_8 #f) + (s-allocated?_7 #f) + (N-comp-cont_4 #f) + (N-skip-pre?_3 #f) + (N-allocated?_2 #f) + (handlers-disabled?_0 #f)) + (% + #t + ((begin + (set! handlers-disabled?_0 #t) + ((λ (v_1) + (% + v_1 + ((λ (t_5) + (if N-allocated?_2 + (begin (if handlers-disabled?_0 #f (set! N-skip-pre?_3 #t)) (N-comp-cont_4 t_5)) + (% + 1 + (dynamic-wind + (λ () + (if handlers-disabled?_0 + #f + (if N-allocated?_2 + (if N-skip-pre?_3 + (set! N-skip-pre?_3 #f) + (begin + (set! handlers-disabled?_0 #t) + ((λ (v_6) + (% v_6 (_call/cc (λ (k) (abort v_6 k)) v_6) (λ (x) (begin (set! handlers-disabled?_0 #f) x)))) + print))) + #f))) + (λ () ((call/comp (λ (k) (begin (set! N-comp-cont_4 k) (abort 1 k))) 1))) + (λ () (if handlers-disabled?_0 (set! N-allocated?_2 #t) (if N-allocated?_2 #f (set! N-allocated?_2 #t))))) + (λ (k) (begin (if handlers-disabled?_0 #f (set! N-skip-pre?_3 #t)) (k t_5)))))) + (λ () + ((λ (t_10) + (if s-allocated?_7 + (begin (if handlers-disabled?_0 #f (set! s-skip-pre?_8 #t)) (s-comp-cont_9 t_10)) + (% + 1 + (dynamic-wind + (λ () (if handlers-disabled?_0 #f (if s-allocated?_7 (if s-skip-pre?_8 (set! s-skip-pre?_8 #f) #f) #f))) + (λ () ((call/comp (λ (k) (begin (set! s-comp-cont_9 k) (abort 1 k))) 1))) + (λ () + (if handlers-disabled?_0 (set! s-allocated?_7 #t) (if s-allocated?_7 #f (set! s-allocated?_7 #t))))) + (λ (k) (begin (if handlers-disabled?_0 #f (set! s-skip-pre?_8 #t)) (k t_10)))))) + (λ () + ((λ (t_14) + (if CEJ-allocated?_11 + (begin (if handlers-disabled?_0 #f (set! CEJ-skip-pre?_12 #t)) (CEJ-comp-cont_13 t_14)) + (% + 1 + (dynamic-wind + (λ () + (if handlers-disabled?_0 + #f + (if CEJ-allocated?_11 (if CEJ-skip-pre?_12 (set! CEJ-skip-pre?_12 #f) first) #f))) + (λ () ((call/comp (λ (k) (begin (set! CEJ-comp-cont_13 k) (abort 1 k))) 1))) + (λ () + (if handlers-disabled?_0 + (set! CEJ-allocated?_11 #t) + (if CEJ-allocated?_11 call/cm (set! CEJ-allocated?_11 #t))))) + (λ (k) (begin (if handlers-disabled?_0 #f (set! CEJ-skip-pre?_12 #t)) (k t_14)))))) + (λ () (_call/cc (λ (k) (abort v_1 k)) v_1))))))) + (λ (x) (begin (set! handlers-disabled?_0 #f) x)))) + #t)) + 1234) + (λ (x) x)))))) diff --git a/src/racket/src/fun.c b/src/racket/src/fun.c index aea64cc386..1556124815 100644 --- a/src/racket/src/fun.c +++ b/src/racket/src/fun.c @@ -9048,7 +9048,7 @@ void scheme_apply_dw_in_meta(Scheme_Dynamic_Wind *dw, int post_part, int meta_de rest = mc; for (i = 0; i < actual_depth - 1; i++) { rest->cont_mark_total = 0; - rest->cont_mark_offset = 0; + rest->cont_mark_offset = rest->cont_mark_stack; rest->cont_mark_stack_copied = NULL; sync_meta_cont(rest); rest = rest->next; From 8b3165d55b85cffbe3ad28be6d8bd4c218d21529 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 27 Nov 2010 15:53:49 -0700 Subject: [PATCH 167/255] move racket/draw overview to the Guide and expand it --- plus some minor collateral API improvements --- collects/racket/draw/private/brush.rkt | 48 +- collects/racket/draw/private/dc.rkt | 28 +- collects/racket/draw/private/pen.rkt | 82 +- collects/scribble/eval.rkt | 78 +- collects/scribblings/draw/brush-class.scrbl | 24 +- collects/scribblings/draw/draw.scrbl | 27 +- collects/scribblings/draw/guide.scrbl | 227 ---- collects/scribblings/draw/pen-class.scrbl | 33 +- collects/scribblings/draw/reference.scrbl | 29 - collects/scribblings/gui/dc-intf.scrbl | 1125 +++++++++++++++++++ collects/scribblings/guide/draw.scrbl | 642 +++++++++++ collects/scribblings/guide/fire.png | Bin 0 -> 3094 bytes collects/scribblings/guide/graphics.scrbl | 53 + collects/scribblings/guide/guide.scrbl | 2 + collects/scribblings/guide/other.scrbl | 4 - collects/scribblings/guide/water.png | Bin 0 -> 4345 bytes 16 files changed, 2017 insertions(+), 385 deletions(-) delete mode 100644 collects/scribblings/draw/guide.scrbl delete mode 100644 collects/scribblings/draw/reference.scrbl create mode 100644 collects/scribblings/gui/dc-intf.scrbl create mode 100644 collects/scribblings/guide/draw.scrbl create mode 100644 collects/scribblings/guide/fire.png create mode 100644 collects/scribblings/guide/graphics.scrbl create mode 100644 collects/scribblings/guide/water.png diff --git a/collects/racket/draw/private/brush.rkt b/collects/racket/draw/private/brush.rkt index d37775b201..f8c65ce1ce 100644 --- a/collects/racket/draw/private/brush.rkt +++ b/collects/racket/draw/private/brush.rkt @@ -28,24 +28,40 @@ (properties #:check-immutable check-immutable [[brush-style-symbol? style] 'solid]) - (init-rest args) - (super-new) + (init [(_color color) black] + [(_style style) 'solid] + [(_stipple stipple) #f]) - (case-args - args - [() (void)] - [([color% _color] - [brush-style-symbol? _style]) - (set! color (color->immutable-color _color)) - (set! style _style)] - [([string? _color] - [brush-style-symbol? _style]) - (set! color (send the-color-database find-color _color)) - (set! style _style)] - (init-name 'brush%)) + (set! color + (cond + [(string? _color) (or (send the-color-database find-color _color) black)] + [(color . is-a? . color%) + (color->immutable-color _color)] + [else + (raise-type-error (init-name 'brush%) + "string or color%" + _color)])) + + (set! style + (if (brush-style-symbol? _style) + _style + (raise-type-error (init-name 'brush%) + "brush style symbol" + _style))) (define immutable? #f) (define lock-count 0) + (define stipple #f) + + (when _stipple + (unless (_stipple . is-a? . bitmap%) + (raise-type-error (init-name 'brush%) + "bitmap% or #f" + _stipple)) + (set-stipple _stipple)) + + (super-new) + (define/public (set-immutable) (set! immutable? #t)) (define/public (is-immutable?) (or immutable? (positive? lock-count))) (define/public (adjust-lock v) (set! lock-count (+ lock-count v))) @@ -71,7 +87,6 @@ (define/public (get-color) color) - (define stipple #f) (def/public (get-stipple) stipple) (def/public (set-stipple [(make-or-false bitmap%) s]) (check-immutable 'set-stipple) @@ -95,7 +110,8 @@ (values (color->immutable-color _color) _style)] [([string? _color] [brush-style-symbol? _style]) - (values (send the-color-database find-color _color) + (values (or (send the-color-database find-color _color) + black) _style)] (method-name 'find-or-create-brush 'brush-list%))]) (let ([key (vector (send col red) (send col green) (send col blue) diff --git a/collects/racket/draw/private/dc.rkt b/collects/racket/draw/private/dc.rkt index 320d880818..e11fe0c369 100644 --- a/collects/racket/draw/private/dc.rkt +++ b/collects/racket/draw/private/dc.rkt @@ -36,15 +36,20 @@ (define 2pi (* 2 pi)) +(define black (send the-color-database find-color "black")) + (define (copy-color c) - (if (send c is-immutable?) - c - (let ([c (make-object color% - (color-red c) - (color-green c) - (color-blue c))]) - (send c set-immutable) - c))) + (if (string? c) + (or (send the-color-database find-color c) + black) + (if (send c is-immutable?) + c + (let ([c (make-object color% + (color-red c) + (color-green c) + (color-blue c))]) + (send c set-immutable) + c)))) (define -bitmap-dc% #f) (define (install-bitmap-dc-class! v) (set! -bitmap-dc% v)) @@ -268,7 +273,6 @@ (define contexts (make-vector (vector-length font-maps) #f)) (define desc-layoutss (make-vector (vector-length font-maps) #f)) - (define black (send the-color-database find-color "black")) (define pen (send the-pen-list find-or-create-pen "black" 1 'solid)) (define brush (send the-brush-list find-or-create-brush "white" 'solid)) (define font (send the-font-list find-or-create-font 12 'default)) @@ -554,11 +558,11 @@ (define/private (brush-draws?) (not (eq? (send brush get-style) 'transparent))) - (def/public (set-text-foreground [color% c]) + (def/public (set-text-foreground [(make-alts color% string?) c]) (set! text-fg (copy-color c))) - (def/public (set-text-background [color% c]) + (def/public (set-text-background [(make-alts color% string?) c]) (set! text-bg (copy-color c))) - (def/public (set-background [color% c]) + (def/public (set-background [(make-alts color% string?) c]) (set! pen-stipple-s #f) (set! brush-stipple-s #f) (set! bg (copy-color c))) diff --git a/collects/racket/draw/private/pen.rkt b/collects/racket/draw/private/pen.rkt index bd26946a1e..745aa29d14 100644 --- a/collects/racket/draw/private/pen.rkt +++ b/collects/racket/draw/private/pen.rkt @@ -42,33 +42,58 @@ [[pen-style-symbol? style] 'solid] [[pen-width? width] 0]) - (init-rest args) - (super-new) + (init [(_color color) black] + [(_width width) 0] + [(_style style) 'solid] + [(_cap cap) 'round] + [(_join join) 'round] + [(_stipple stipple) #f]) - (case-args - args - [() (void)] - [([color% _color] - [pen-width? _width] - [pen-style-symbol? _style] - [pen-cap-symbol? [_cap 'round]] - [pen-join-symbol? [_join 'round]]) - (set! color (color->immutable-color _color)) - (set! width _width) - (set! style _style) - (set! cap _cap) - (set! join _join)] - [([string? _color] - [pen-width? _width] - [pen-style-symbol? _style] - [pen-cap-symbol? [_cap 'round]] - [pen-join-symbol? [_join 'round]]) - (set! color (send the-color-database find-color _color)) - (set! width _width) - (set! style _style) - (set! cap _cap) - (set! join _join)] - (init-name 'pen%)) + (set! color + (cond + [(string? _color) (or (send the-color-database find-color _color) black)] + [(color . is-a? . color%) + (color->immutable-color _color)] + [else + (raise-type-error (init-name 'pen%) + "string or color%" + _color)])) + (set! width + (if (pen-width? _width) + _width + (raise-type-error (init-name 'pen%) + "real in [0, 255]" + _width))) + + (set! style + (if (pen-style-symbol? _style) + _style + (raise-type-error (init-name 'pen%) + "pen style symbol" + _style))) + + (set! cap + (if (pen-cap-symbol? _cap) + _cap + (raise-type-error (init-name 'pen%) + "pen cap symbol" + _cap))) + + (set! join + (if (pen-join-symbol? _join) + _join + (raise-type-error (init-name 'pen%) + "pen join symbol" + _join))) + + (when _stipple + (unless (_stipple . is-a? . bitmap%) + (raise-type-error (init-name 'pen%) + "bitmap% or #f" + _stipple)) + (set-stipple _stipple)) + + (super-new) (define immutable? #f) (define lock-count 0) @@ -78,7 +103,7 @@ (define/private (check-immutable s) (when (or immutable? (positive? lock-count)) - (error (method-name 'brush% s) "object is ~a" + (error (method-name 'pen% s) "object is ~a" (if immutable? "immutable" "locked")))) (define/public (set-color . args) @@ -128,7 +153,8 @@ [pen-style-symbol? _style] [pen-cap-symbol? [_cap 'round]] [pen-join-symbol? [_join 'round]]) - (values (send the-color-database find-color _color) + (values (or (send the-color-database find-color _color) + black) _width _style _cap _join)] (method-name 'find-or-create-pen 'pen-list%))]) (let ([key (vector (send col red) (send col green) (send col blue) diff --git a/collects/scribble/eval.rkt b/collects/scribble/eval.rkt index e204f0cb17..4fe429c5dc 100644 --- a/collects/scribble/eval.rkt +++ b/collects/scribble/eval.rkt @@ -145,50 +145,56 @@ [(syntax? s) (loop (syntax-e s) ops)] [else (loop ((car ops) s) (cdr ops))]))) - (define ((do-eval ev) s) + (define (extract-to-evaluate s) (let loop ([s s][expect #f]) (syntax-case s (code:comment eval:alts eval:check) [(code:line v (code:comment . rest)) (loop (extract s cdr car) expect)] [(code:comment . rest) - (list (list (void)) "" "")] + (values #f expect)] [(eval:alts p e) (loop (extract s cdr cdr car) expect)] [(eval:check e expect) (loop (extract s cdr car) (list (syntax->datum (datum->syntax #f (extract s cdr cdr car)))))] [else - (let ([r (with-handlers ([(lambda (x) - (not (exn:break? x))) - (lambda (e) - (list (if (exn? e) - (exn-message e) - (format "uncaught exception: ~s" e)) - (get-output ev) - (get-error-output ev)))]) - (list (let ([v (do-plain-eval ev s #t)]) - (if (call-in-sandbox-context - ev - (let ([cp (current-print)]) - (lambda () - (and (eq? (current-print) cp) - (print-as-expression))))) - (make-reader-graph (copy-value v (make-hasheq))) - (box - (call-in-sandbox-context + (values s expect)]))) + + (define ((do-eval ev) s) + (let-values ([(s expect) (extract-to-evaluate s)]) + (if s + (let ([r (with-handlers ([(lambda (x) + (not (exn:break? x))) + (lambda (e) + (list (if (exn? e) + (exn-message e) + (format "uncaught exception: ~s" e)) + (get-output ev) + (get-error-output ev)))]) + (list (let ([v (do-plain-eval ev s #t)]) + (if (call-in-sandbox-context ev - (lambda () - (let ([s (open-output-string)]) - (parameterize ([current-output-port s]) - (map (current-print) v)) - (get-output-string s))))))) - (get-output ev) - (get-error-output ev)))]) - (when expect - (let ([expect (do-plain-eval ev (car expect) #t)]) - (unless (equal? (car r) expect) - (raise-syntax-error 'eval "example result check failed" s)))) - r)]))) + (let ([cp (current-print)]) + (lambda () + (and (eq? (current-print) cp) + (print-as-expression))))) + (make-reader-graph (copy-value v (make-hasheq))) + (box + (call-in-sandbox-context + ev + (lambda () + (let ([s (open-output-string)]) + (parameterize ([current-output-port s]) + (map (current-print) v)) + (get-output-string s))))))) + (get-output ev) + (get-error-output ev)))]) + (when expect + (let ([expect (do-plain-eval ev (car expect) #t)]) + (unless (equal? (car r) expect) + (raise-syntax-error 'eval "example result check failed" s)))) + r) + (values (list (list (void)) "" ""))))) (define (install ht v v2) @@ -337,9 +343,11 @@ (define-syntax-rule (quote-expr e) 'e) (define (do-interaction-eval ev e) - (parameterize ([current-command-line-arguments #()]) - (do-plain-eval (or ev (make-base-eval)) e #f)) - "") + (let-values ([(e expect) (extract-to-evaluate e)]) + (when e + (parameterize ([current-command-line-arguments #()]) + (do-plain-eval (or ev (make-base-eval)) e #f))) + "")) (define-syntax interaction-eval (syntax-rules () diff --git a/collects/scribblings/draw/brush-class.scrbl b/collects/scribblings/draw/brush-class.scrbl index 66a5caaf17..fcc7463411 100644 --- a/collects/scribblings/draw/brush-class.scrbl +++ b/collects/scribblings/draw/brush-class.scrbl @@ -86,22 +86,18 @@ To avoid creating multiple brushes with the same characteristics, use @xmethod[dc<%> set-brush]. -@defconstructor*/make[(() - ([color (is-a?/c color%)] - [style (one-of/c 'transparent 'solid 'opaque - 'xor 'hilite 'panel - 'bdiagonal-hatch 'crossdiag-hatch - 'fdiagonal-hatch 'cross-hatch - 'horizontal-hatch 'vertical-hatch)]) - ([color-name string?] - [style (one-of/c 'transparent 'solid 'opaque - 'xor 'hilite 'panel - 'bdiagonal-hatch 'crossdiag-hatch - 'fdiagonal-hatch 'cross-hatch - 'horizontal-hatch 'vertical-hatch)]))]{ +@defconstructor[([color (or/c string? (is-a?/c color%)) "black"] + [style (one-of/c 'transparent 'solid 'opaque + 'xor 'hilite 'panel + 'bdiagonal-hatch 'crossdiag-hatch + 'fdiagonal-hatch 'cross-hatch + 'horizontal-hatch 'vertical-hatch) + 'solid] + [stipple (or/c #f (is-a?/c bitmap%)) + #f])]{ When no argument are provided, the result is a solid black brush. - Otherwise, the result is a brush with the given color and style. For + Otherwise, the result is a brush with the given color, style, and stipple. For the case that the color is specified using a name, see @scheme[color-database<%>] for information about color names; if the name is not known, the brush's color is black. diff --git a/collects/scribblings/draw/draw.scrbl b/collects/scribblings/draw/draw.scrbl index 3787105685..247cc879ae 100644 --- a/collects/scribblings/draw/draw.scrbl +++ b/collects/scribblings/draw/draw.scrbl @@ -11,12 +11,35 @@ @racketmodname[racket/draw] library provides all of the class, interface, and procedure bindings defined in this manual.} +For an overview of the drawing library, see @secref["draw" #:doc +'(lib "scribblings/guide/guide.scrbl")]. + @table-of-contents[] @;------------------------------------------------------------------------ -@include-section["guide.scrbl"] -@include-section["reference.scrbl"] +@include-section["bitmap-class.scrbl"] +@include-section["bitmap-dc-class.scrbl"] +@include-section["brush-class.scrbl"] +@include-section["brush-list-class.scrbl"] +@include-section["color-class.scrbl"] +@include-section["color-database-intf.scrbl"] +@include-section["dc-intf.scrbl"] +@include-section["dc-path-class.scrbl"] +@include-section["font-class.scrbl"] +@include-section["font-list-class.scrbl"] +@include-section["font-name-directory-intf.scrbl"] +@include-section["gl-config-class.scrbl"] +@include-section["gl-context-intf.scrbl"] +@include-section["pdf-dc-class.scrbl"] +@include-section["pen-class.scrbl"] +@include-section["pen-list-class.scrbl"] +@include-section["point-class.scrbl"] +@include-section["post-script-dc-class.scrbl"] +@include-section["ps-setup-class.scrbl"] +@include-section["region-class.scrbl"] +@include-section["draw-funcs.scrbl"] +@include-section["draw-unit.scrbl"] @;------------------------------------------------------------------------ diff --git a/collects/scribblings/draw/guide.scrbl b/collects/scribblings/draw/guide.scrbl deleted file mode 100644 index d3e912ed6a..0000000000 --- a/collects/scribblings/draw/guide.scrbl +++ /dev/null @@ -1,227 +0,0 @@ -#lang scribble/doc -@(require scribble/eval - "common.ss") - -@title[#:tag "overview"]{Overview} - -Drawing with @racketmodname[racket/draw] uses a @deftech{device context} -(@deftech{DC}), which is an instance of the @scheme[dc<%>] -interface. For example, the @racket[post-script-dc%] class implements -a @racket[dc<%>] for drawing to a PostScript file, while @racket[bitmap-dc%] -draws to a bitmap. When using the @racketmodname[racket/gui] library for GUIs, -the @method[canvas<%> get-dc] method of a -canvas returns a @scheme[dc<%>] instance for drawing into the canvas -window. - -Tools that are used for drawing include the following: @scheme[pen%] - objects for drawing lines and shape outlines, @scheme[brush%] - objects for filling shapes, @scheme[bitmap%] objects for storing - bitmaps, and @scheme[dc-path%] objects for describing paths to draw - and fill. - -The following example uses the GUI library as well as the drawing - library. It creates a frame with a drawing canvas, and then draws a - round, blue face with square, yellow eyes and a smiling, red mouth: - -@schemeblock[ -(code:comment @#,t{Make some pens and brushes}) -(define no-pen (make-object pen% "BLACK" 1 'transparent)) -(define no-brush (make-object brush% "BLACK" 'transparent)) -(define blue-brush (make-object brush% "BLUE" 'solid)) -(define yellow-brush (make-object brush% "YELLOW" 'solid)) -(define red-pen (make-object pen% "RED" 2 'solid)) - -(code:comment @#,t{Define a procedure to draw a face}) -(define (draw-face dc) - (send dc #,(:: dc<%> set-pen) no-pen) - (send dc #,(:: dc<%> set-brush) blue-brush) - (send dc #,(:: dc<%> draw-ellipse) 50 50 200 200) - - (send dc #,(:: dc<%> set-brush) yellow-brush) - (send dc #,(:: dc<%> draw-rectangle) 100 100 10 10) - (send dc #,(:: dc<%> draw-rectangle) 200 100 10 10) - - (send dc #,(:: dc<%> set-brush) no-brush) - (send dc #,(:: dc<%> set-pen) red-pen) - (let ([-pi (atan 0 -1)]) - (send dc #,(:: dc<%> draw-arc) 75 75 150 150 (* 5/4 -pi) (* 7/4 -pi)))) - -(code:comment @#,t{Make a 300 x 300 frame}) -(define frame (new frame% [label "Drawing Example"] - [width 300] - [height 300])) -(code:comment @#,t{Make the drawing area, and set its paint callback}) -(code:comment @#,t{to use the @racket[draw-face] function:}) -(define canvas (new canvas% - [parent frame] - [paint-callback (lambda (c dc) (draw-face dc))])) - -(code:comment @#,t{Show the frame}) -(send frame #,(:: top-level-window<%> show) #t) -] - -Suppose that @scheme[draw-face] creates a particularly complex face that - takes a long time to draw. We might want to draw the face once into - an offscreen bitmap, and then have the paint callback copy the cached - bitmap image onto the canvas whenever the canvas is updated. To draw - into a bitmap, we first create a @scheme[bitmap%] object, and then - we create a @scheme[bitmap-dc%] to direct drawing commands into the - bitmap: - -@schemeblock[ -(code:comment @#,t{... pens, brushes, and @scheme[draw-face] are the same as above ...}) - -(code:comment @#,t{Create a 300 x 300 bitmap}) -(define face-bitmap (make-object bitmap% 300 300)) -(code:comment @#,t{Create a drawing context for the bitmap}) -(define bm-dc (make-object bitmap-dc% face-bitmap)) -(code:comment @#,t{A bitmap's initial content is undefined; clear it before drawing}) -(send bm-dc #,(:: dc<%> clear)) - -(code:comment @#,t{Draw the face into the bitmap}) -(draw-face bm-dc) - -(code:comment @#,t{Make a 300 x 300 frame}) -(define frame (new frame% [label "Drawing Example"] - [width 300] - [height 300])) - -(code:comment @#,t{Make a drawing area whose paint callback copies the bitmap}) -(define canvas - (new canvas% [parent frame] - [paint-callback - (lambda (canvas dc) - (send dc #,(:: dc<%> draw-bitmap) face-bitmap 0 0))])) - -(code:comment @#,t{Show the frame}) -(send frame #,(:: top-level-window<%> show) #t) -] - -For all types of DCs, the drawing origin is the top-left corner of the - DC. When drawing to a window or bitmap, DC units initially correspond - to pixels, but the @method[dc<%> set-scale] method changes the - scale. When drawing to a PostScript or printer device, DC units - initially correspond to points (1/72 of an inch). - -More complex shapes are typically best implemented with - @deftech{paths}. The following example uses paths to draw the - Racket logo. It also enables smoothing, so that the logo's curves are - anti-aliased when smoothing is available. (Smoothing is always - available under Mac OS X, smoothing is available under Windows XP or - when @filepath{gdiplus.dll} is installed, and smoothing is available - under X when Cairo is installed before GRacket is compiled.) - -@(begin -#readerscribble/comment-reader -[schemeblock -(require racket/math) ; for @scheme[pi] - -;; Construct paths for a 630 x 630 logo - -(define left-lambda-path ;; left side of the lambda - (let ([p (new dc-path%)]) - (send p #,(:: dc-path% move-to) 153 44) - (send p #,(:: dc-path% line-to) 161.5 60) - (send p #,(:: dc-path% curve-to) 202.5 49 230 42 245 61) - (send p #,(:: dc-path% curve-to) 280.06 105.41 287.5 141 296.5 186) - (send p #,(:: dc-path% curve-to) 301.12 209.08 299.11 223.38 293.96 244) - (send p #,(:: dc-path% curve-to) 281.34 294.54 259.18 331.61 233.5 375) - (send p #,(:: dc-path% curve-to) 198.21 434.63 164.68 505.6 125.5 564) - (send p #,(:: dc-path% line-to) 135 572) - p)) - -(define left-logo-path ;; left side of the lambda and circle - (let ([p (new dc-path%)]) - (send p #,(:: dc-path% append) left-lambda-path) - (send p #,(:: dc-path% arc) 0 0 630 630 (* 235/360 2 pi) (* 121/360 2 pi) #f) - p)) - -(define bottom-lambda-path - (let ([p (new dc-path%)]) - (send p #,(:: dc-path% move-to) 135 572) - (send p #,(:: dc-path% line-to) 188.5 564) - (send p #,(:: dc-path% curve-to) 208.5 517 230.91 465.21 251 420) - (send p #,(:: dc-path% curve-to) 267 384 278.5 348 296.5 312) - (send p #,(:: dc-path% curve-to) 301.01 302.98 318 258 329 274) - (send p #,(:: dc-path% curve-to) 338.89 288.39 351 314 358 332) - (send p #,(:: dc-path% curve-to) 377.28 381.58 395.57 429.61 414 477) - (send p #,(:: dc-path% curve-to) 428 513 436.5 540 449.5 573) - (send p #,(:: dc-path% line-to) 465 580) - (send p #,(:: dc-path% line-to) 529 545) - p)) - -(define bottom-logo-path - (let ([p (new dc-path%)]) - (send p #,(:: dc-path% append) bottom-lambda-path) - (send p #,(:: dc-path% arc) 0 0 630 630 (* 314/360 2 pi) (* 235/360 2 pi) #f) - p)) - -(define right-lambda-path - (let ([p (new dc-path%)]) - (send p #,(:: dc-path% move-to) 153 44) - (send p #,(:: dc-path% curve-to) 192.21 30.69 233.21 14.23 275 20) - (send p #,(:: dc-path% curve-to) 328.6 27.4 350.23 103.08 364 151) - (send p #,(:: dc-path% curve-to) 378.75 202.32 400.5 244 418 294) - (send p #,(:: dc-path% curve-to) 446.56 375.6 494.5 456 530.5 537) - (send p #,(:: dc-path% line-to) 529 545) - p)) - -(define right-logo-path - (let ([p (new dc-path%)]) - (send p #,(:: dc-path% append) right-lambda-path) - (send p #,(:: dc-path% arc) 0 0 630 630 (* 314/360 2 pi) (* 121/360 2 pi) #t) - p)) - -(define lambda-path ;; the lambda by itself (no circle) - (let ([p (new dc-path%)]) - (send p #,(:: dc-path% append) left-lambda-path) - (send p #,(:: dc-path% append) bottom-lambda-path) - (let ([t (make-object dc-path%)]) - (send t #,(:: dc-path% append) right-lambda-path) - (send t #,(:: dc-path% reverse)) - (send p #,(:: dc-path% append) t)) - (send p #,(:: dc-path% close)) - p)) - -;; This function draws the paths with suitable colors: -(define (paint-plt dc) - ;; Paint white lambda, no outline: - (send dc #,(:: dc<%> set-pen) "BLACK" 0 'transparent) - (send dc #,(:: dc<%> set-brush) "WHITE" 'solid) - (send dc #,(:: dc<%> draw-path) lambda-path) - ;; Paint outline and colors... - (send dc #,(:: dc<%> set-pen) "BLACK" 0 'solid) - ;; Draw red regions - (send dc #,(:: dc<%> set-brush) "RED" 'solid) - (send dc #,(:: dc<%> draw-path) left-logo-path) - (send dc #,(:: dc<%> draw-path) bottom-logo-path) - ;; Draw blue region - (send dc #,(:: dc<%> set-brush) "BLUE" 'solid) - (send dc #,(:: dc<%> draw-path) right-logo-path)) - -;; Create a frame to display the logo on a light-purple background: -(define f (new frame% [label "Racket Logo"])) -(define c - (new canvas% - [parent f] - [paint-callback - (lambda (c dc) - (send dc #,(:: dc<%> set-background) (make-object color% 220 200 255)) - (send dc #,(:: dc<%> clear)) - (send dc #,(:: dc<%> set-smoothing) 'smoothed) - (send dc #,(:: dc<%> set-origin) 5 5) - (send dc #,(:: dc<%> set-scale) 0.5 0.5) - (paint-plt dc))])) -(send c #,(:: canvas<%> min-client-width) (/ 650 2)) -(send c #,(:: canvas<%> min-client-height) (/ 650 2)) -(send f show #t) -]) - -Drawing effects are not completely portable across platforms or across - types of DC. Drawing in smoothed mode tends to produce more reliable - and portable results than in unsmoothed mode, and drawing with paths - tends to produce more reliable results even in unsmoothed - mode. Drawing with a pen of width 0 or 1 in unsmoothed mode in an - unscaled DC produces relatively consistent results for all platforms, - but a pen width of 2 or drawing to a scaled DC looks significantly - different in unsmoothed mode on different platforms and destinations. diff --git a/collects/scribblings/draw/pen-class.scrbl b/collects/scribblings/draw/pen-class.scrbl index 7ca9b0a576..4e0b063f53 100644 --- a/collects/scribblings/draw/pen-class.scrbl +++ b/collects/scribblings/draw/pen-class.scrbl @@ -89,27 +89,24 @@ A pen of size @scheme[0] uses the minimum line size for the -@defconstructor*/make[(() - ([color (is-a?/c color%)] - [width (real-in 0 255)] - [style (one-of/c 'transparent 'solid 'xor 'hilite - 'dot 'long-dash 'short-dash 'dot-dash - 'xor-dot 'xor-long-dash 'xor-short-dash - 'xor-dot-dash)] - [cap-style (one-of/c 'round 'projecting 'butt)] - [join-style (one-of/c 'round 'bevel 'miter)]) - ([color-name string?] - [width (real-in 0 255)] - [style (one-of/c 'transparent 'solid 'xor 'dot 'hilite - 'long-dash 'short-dash 'dot-dash - 'xor-dot 'xor-long-dash 'xor-short-dash - 'xor-dot-dash)] - [cap-style (one-of/c 'round 'projecting 'butt)] - [join-style (one-of/c 'round 'bevel 'miter)]))]{ +@defconstructor[([color (or/c string? (is-a?/c color%)) "black"] + [width (real-in 0 255) 0] + [style (one-of/c 'transparent 'solid 'xor 'hilite + 'dot 'long-dash 'short-dash 'dot-dash + 'xor-dot 'xor-long-dash 'xor-short-dash + 'xor-dot-dash) + 'solid] + [cap (one-of/c 'round 'projecting 'butt) + 'round] + [join (one-of/c 'round 'bevel 'miter) + 'round] + [stipple (or/c #f (is-a?/c bitmap%)) + #f])]{ When no argument are provided, the result is a solid black pen of width @scheme[0]. Otherwise, the result is a pen with the given - color, width, style, cap style, and join style. For the case that the color is specified + color, width, style, cap style, join style, and stipple. + For the case that the color is specified using a name, see @scheme[color-database<%>] for information about color names; if the name is not known, the pen's color is black. diff --git a/collects/scribblings/draw/reference.scrbl b/collects/scribblings/draw/reference.scrbl deleted file mode 100644 index e8e05d6811..0000000000 --- a/collects/scribblings/draw/reference.scrbl +++ /dev/null @@ -1,29 +0,0 @@ -#lang scribble/doc -@(require "common.ss") - -@title[#:style '(toc reveal)]{Reference} - -@local-table-of-contents[] - -@include-section["bitmap-class.scrbl"] -@include-section["bitmap-dc-class.scrbl"] -@include-section["brush-class.scrbl"] -@include-section["brush-list-class.scrbl"] -@include-section["color-class.scrbl"] -@include-section["color-database-intf.scrbl"] -@include-section["dc-intf.scrbl"] -@include-section["dc-path-class.scrbl"] -@include-section["font-class.scrbl"] -@include-section["font-list-class.scrbl"] -@include-section["font-name-directory-intf.scrbl"] -@include-section["gl-config-class.scrbl"] -@include-section["gl-context-intf.scrbl"] -@include-section["pdf-dc-class.scrbl"] -@include-section["pen-class.scrbl"] -@include-section["pen-list-class.scrbl"] -@include-section["point-class.scrbl"] -@include-section["post-script-dc-class.scrbl"] -@include-section["ps-setup-class.scrbl"] -@include-section["region-class.scrbl"] -@include-section["draw-funcs.scrbl"] -@include-section["draw-unit.scrbl"] diff --git a/collects/scribblings/gui/dc-intf.scrbl b/collects/scribblings/gui/dc-intf.scrbl new file mode 100644 index 0000000000..ec0de7440d --- /dev/null +++ b/collects/scribblings/gui/dc-intf.scrbl @@ -0,0 +1,1125 @@ +#lang scribble/doc +@(require "common.ss") + +@definterface/title[dc<%> ()]{ + +A @scheme[dc<%>] object is a drawing context for drawing graphics and + text. It represents output devices in a generic way; e.g., a canvas + has a drawing context, as does a printer. + + +@defmethod[(cache-font-metrics-key) + exact-integer?]{ + +Returns an integer that, if not @scheme[0], corresponds to a +particular kind of device and scaling factor, such that text-extent +information (from @method[dc<%> get-text-extent], @method[dc<%> +get-char-height], etc.) is the same. The key is valid across all +@scheme[dc<%>] instances, even among different classes. + +A @scheme[0] result indicates that the current configuration of +@this-obj[] does not fit into a common category, and so no key is +available for caching text-extent information.} + + +@defmethod[(clear) + void?]{ + +Clears the drawing region (fills it with the current background color, +as determined by @method[dc<%> get-background]). + +} + +@defmethod[(copy [x real?] + [y real?] + [width (and/c real? (not/c negative?))] + [height (and/c real? (not/c negative?))] + [x2 real?] + [y2 real?]) + void?]{ + +Copies the rectangle defined by @racket[x], @racket[y], +@racket[width], and @racket[height] of the drawing context to the same +drawing context at the position specified by @racket[x2] and +@racket[y2]. + +The result is undefined if the source and destination rectangles +overlap.} + + +@defmethod[(draw-arc [x real?] + [y real?] + [width (and/c real? (not/c negative?))] + [height (and/c real? (not/c negative?))] + [start-radians real?] + [end-radians real?]) + void?]{ + +Draws a counter-clockwise circular arc, a part of the ellipse + inscribed in the rectangle specified by @scheme[x] (left), @scheme[y] + (top), @scheme[width], and @scheme[height]. The arc starts at the angle + specified by @scheme[start-radians] (@scheme[0] is three o'clock and + half-pi is twelve o'clock) and continues counter-clockwise to + @scheme[end-radians]. If @scheme[start-radians] and @scheme[end-radians] are + the same, a full ellipse is drawn. + +The current pen is used for the arc. If the current brush is not + transparent, it is used to fill the wedge bounded by the arc plus + lines (not drawn) extending to the center of the inscribed ellipse. + +If both the pen and brush are non-transparent, the wedge is filled + with the brush before the arc is drawn with the pen. The wedge and + arc meet so that no space is left between them, but the precise + overlap between the wedge and arc is platform- and size-specific. + Typically, the regions drawn by the brush and pen overlap. More + generally, the pen is centered over the outline of the arc, rounding + toward the center in unsmoothed mode. + +@|DrawSizeNote| + +} + + +@defmethod[(draw-bitmap [source (is-a?/c bitmap%)] + [dest-x real?] + [dest-y real?] + [style (one-of/c 'solid 'opaque 'xor) 'solid] + [color (is-a?/c color%) (send the-color-database find-color "black")] + [mask (or/c (is-a?/c bitmap%) false/c) #f]) + boolean?]{ + +Displays a bitmap. The @scheme[dest-x] and @scheme[dest-y] arguments + are in DC coordinates. + +For color bitmaps, the drawing style and color arguments are + ignored. For monochrome bitmaps, @method[dc<%> draw-bitmap] uses the + style and color arguments in the same way that a brush uses its style + and color settings to draw a monochrome stipple (see @scheme[brush%] + for more information). + +If a mask bitmap is supplied, it must have the same width and height + as the bitmap to display, and its @method[bitmap% ok?] must return + true, otherwise @|MismatchExn|. The bitmap to draw and the mask + bitmap can be the same object, but if the drawing context is a + @scheme[bitmap-dc%] object, both bitmaps must be distinct from the + destination bitmap, otherwise @|MismatchExn|. + +If the mask bitmap is monochrome, drawing occurs in the target + @scheme[dc<%>] only where the mask bitmap contains black pixels. + +If the mask bitmap is grayscale and the bitmap to draw is not + monochrome, then the blackness of each mask pixel controls the + opacity of the drawn pixel (i.e., the mask acts as an inverted alpha + channel). If a mask bitmap is color, the component values of a given + pixel are averaged to arrive at a gray value for the pixel. + +The current brush, current pen, current text, and current alpha + settings for the DC have no effect on how the bitmap is drawn, but + the bitmap is scaled if the DC has a scale. + +For @scheme[post-script-dc%] output, the mask bitmap is currently + ignored, and the @scheme['solid] style is treated the same as + @scheme['opaque]. (However, mask bitmaps and @scheme['solid] drawing + may become supported for @scheme[post-script-dc%] in the future.) + +The result is @scheme[#t] if the bitmap is successfully drawn, + @scheme[#f] otherwise (possibly because the bitmap's @method[bitmap% + ok?] method returns @scheme[#f]). + +See also @method[dc<%> draw-bitmap-section]. + +@|DrawSizeNote| + +} + +@defmethod[(draw-bitmap-section [source (is-a?/c bitmap%)] + [dest-x real?] + [dest-y real?] + [src-x real?] + [src-y real?] + [src-width (and/c real? (not/c negative?))] + [src-height (and/c real? (not/c negative?))] + [style (one-of/c 'solid 'opaque 'xor) 'solid] + [color (is-a?/c color%) (send the-color-database find-color "black")] + [mask (or/c (is-a?/c bitmap%) false/c) #f]) + boolean?]{ + +Displays part of a bitmap. + +The @scheme[src-x], @scheme[src-y], @scheme[src-width], and + @scheme[src-height] arguments specify a rectangle in the source + bitmap to copy into this drawing context. + +See @method[dc<%> draw-bitmap] for information about @scheme[dest-x], + @scheme[dest-y], @scheme[style], @scheme[color], and @scheme[mask]. + +} + +@defmethod[(draw-ellipse [x real?] + [y real?] + [width (and/c real? (not/c negative?))] + [height (and/c real? (not/c negative?))]) + void?]{ + +Draws an ellipse contained in a rectangle with the given top-left + corner and size. The current pen is used for the outline, and the + current brush is used for filling the shape. + +If both the pen and brush are non-transparent, the ellipse is filled + with the brush before the outline is drawn with the pen. The filling + and outline meet so that no space is left between them, but the + precise overlap between the filling and outline is platform- and + size-specific. Typically, the regions drawn by the brush and pen + overlap. More generally, the pen is centered over the outline of the + ellipse, rounding toward the center in unsmoothed mode. + +@|DrawSizeNote| + +} + +@defmethod[(draw-line [x1 real?] + [y1 real?] + [x2 real?] + [y2 real?]) + void?]{ + +Draws a line from one point to another. The current pen is used for + drawing the line. + +In unsmoothed mode, the points correspond to pixels, and the line + covers both the start and end points. For a pen whose scaled width is + larger than @scheme[1], the line is drawn centered over the start and + end points. + +See also @method[dc<%> set-smoothing] for information on the +@scheme['aligned] smoothing mode. + +@|DrawSizeNote| + +} + +@defmethod[(draw-lines [points (listof (is-a?/c point%))] + [xoffset real? 0] + [yoffset real? 0]) + void?]{ + +Draws lines using a list of @scheme[points], adding @scheme[xoffset] + and @scheme[yoffset] to each point. The current pen is used for + drawing the lines. + +See also @method[dc<%> set-smoothing] for information on the + @scheme['aligned] smoothing mode. + +@|DrawSizeNote| + +} + +@defmethod[(draw-path [path (is-a?/c dc-path%)] + [xoffset real? 0] + [yoffset real? 0] + [fill-style (one-of/c 'odd-even 'winding) 'odd-even]) + void?]{ + +Draws the sub-paths of the given @scheme[dc-path%] object, adding + @scheme[xoffset] and @scheme[yoffset] to each point. (See + @scheme[dc-path%] for general information on paths and sub-paths.) + The current pen is used for drawing the path as a line, and the + current brush is used for filling the area bounded by the path. + +If both the pen and brush are non-transparent, the path is filled with + the brush before the outline is drawn with the pen. The filling and + outline meet so that no space is left between them, but the precise + overlap between the filling and outline is platform- and + size-specific. Thus, the regions drawn by the brush and pen may + overlap. More generally, the pen is centered over the path, rounding + left and down in unsmoothed mode. + +The @scheme[fill-style] argument specifies the fill rule: + @scheme['odd-even] or @scheme['winding]. In @scheme['odd-even] mode, a + point is considered enclosed within the path if it is enclosed by an + odd number of sub-path loops. In @scheme['winding] mode, a point is + considered enclosed within the path if it is enclosed by more or less + clockwise sub-path loops than counter-clockwise sub-path loops. + +See also @method[dc<%> set-smoothing] for information on the + @scheme['aligned] smoothing mode. + +@|DrawSizeNote| + +} + +@defmethod[(draw-point [x real?] + [y real?]) + void?]{ + +Plots a single point using the current pen. + +@|DrawSizeNote| + +} + +@defmethod[(draw-polygon [points (listof (is-a?/c point%))] + [xoffset real? 0] + [yoffset real? 0] + [fill-style (one-of/c 'odd-even 'winding) 'odd-even]) + void?]{ + +Draw a filled polygon using a list of @scheme[points], adding + @scheme[xoffset] and @scheme[yoffset] to each point. The polygon is + automatically closed, so the first and last point can be + different. The current pen is used for drawing the outline, and the + current brush for filling the shape. + +If both the pen and brush are non-transparent, the polygon is filled + with the brush before the outline is drawn with the pen. The filling + and outline meet so that no space is left between them, but the + precise overlap between the filling and outline is platform- and + shape-specific. Thus, the regions drawn by the brush and pen may + overlap. More generally, the pen is centered over the polygon lines, + rounding left and down in unsmoothed mode. + +The @scheme[fill-style] argument specifies the fill rule: + @scheme['odd-even] or @scheme['winding]. In @scheme['odd-even] mode, a + point is considered enclosed within the polygon if it is enclosed by + an odd number of loops. In @scheme['winding] mode, a point is + considered enclosed within the polygon if it is enclosed by more or + less clockwise loops than counter-clockwise loops. + +See also @method[dc<%> set-smoothing] for information on the + @scheme['aligned] smoothing mode. + +@|DrawSizeNote| + +} + + +@defmethod[(draw-rectangle [x real?] + [y real?] + [width (and/c real? (not/c negative?))] + [height (and/c real? (not/c negative?))]) + void?]{ + +Draws a rectangle with the given top-left corner and size. The + current pen is used for the outline and the current brush for filling + the shape. + +If both the pen and brush are non-transparent, the rectangle is filled + with the brush before the outline is drawn with the pen. In + unsmoothed mode, when the pen is size 0 or 1, the filling precisely + overlaps the entire outline. As a result, if a rectangle is drawn + with a size-0 or size-1 @scheme['xor] @scheme[pen%] and an + @scheme['xor] @scheme[brush%], the outline is xored twice (first by + the brush, then by the pen), leaving it unchanged. More generally, + the pen is centered over the outline of the rectangle, rounding + toward the center in unsmoothed mode. + +See also @method[dc<%> set-smoothing] for information on the +@scheme['aligned] smoothing mode. + +@|DrawSizeNote| + +} + + +@defmethod[(draw-rounded-rectangle [x real?] + [y real?] + [width (and/c real? (not/c negative?))] + [height (and/c real? (not/c negative?))] + [radius real? -0.25]) + void?]{ + +Draws a rectangle with the given top-left corner, and with the given + size. The corners are quarter-circles using the given radius. The + current pen is used for the outline and the current brush for filling + the shape. + +If @scheme[radius] is positive, the value is used as the radius of the + rounded corner. If @scheme[radius] is negative, the absolute value is + used as the @italic{proportion} of the smallest dimension of the + rectangle. + +If @scheme[radius] is less than @scheme[-0.5] or more than half of + @scheme[width] or @scheme[height], @|MismatchExn|. + +If both the pen and brush are non-transparent, the rectangle is filled + with the brush before the outline is drawn with the pen. The filling + and outline meet so that no space is left between them, but the + precise overlap between the filling and outline is platform- and + size-specific. Thus, the regions drawn by the brush and pen may + partially overlap. More generally, the pen is centered over the + outline of the rounded rectangle, rounding toward the center in + unsmoothed mode. + +See also @method[dc<%> set-smoothing] for information on the +@scheme['aligned] smoothing mode. + +@|DrawSizeNote| + +} + +@defmethod[(draw-spline [x1 real?] + [y1 real?] + [x2 real?] + [y2 real?] + [x3 real?] + [y3 real?]) + void?]{ + +@index['("drawing curves")]{Draws} a spline from (@scheme[x1], + @scheme[y1]) to (@scheme[x3], @scheme[y3]) using (@scheme[x2], + @scheme[y2]) as the control point. + +See also @method[dc<%> set-smoothing] for information on the + @scheme['aligned] smoothing mode. See also @scheme[dc-path%] and + @method[dc<%> draw-path] for drawing more complex curves. + +@|DrawSizeNote| + +} + +@defmethod[(draw-text [text string?] + [x real?] + [y real?] + [combine? any/c #f] + [offset exact-nonnegative-integer? 0] + [angle real? 0]) + void?]{ + +Draws a text string at a specified point, using the current text font, + and the current text foreground and background colors. For unrotated + text, the specified point is used as the starting top-left point for + drawing characters (e.g, if ``W'' is drawn, the point is roughly the + location of the top-left pixel in the ``W''). Rotated text is rotated + around this point. + +The @scheme[text] string is drawn starting from the @scheme[offset] + character, and continuing until the end of @scheme[text] or the first + null character. + +If @scheme[combine?] is @scheme[#t], then @scheme[text] may be + measured with adjacent characters combined to ligature glyphs, with + Unicode combining characters as a single glyph, with kerning, with + right-to-left rendering of characters, etc. If @scheme[combine?] is + @scheme[#f], then the result is the same as if each character is + measured separately, and Unicode control characters are ignored. + +The string is rotated by @scheme[angle] radians counter-clockwise. If + @scheme[angle] is not zero, then the text is always drawn in + transparent mode (see @method[dc<%> set-text-mode]). + +The current brush and current pen settings for the DC have no effect + on how the text is drawn. + +See @method[dc<%> get-text-extent] for information on the size of the + drawn text. + +See also @method[dc<%> set-text-foreground], @method[dc<%> + set-text-background], and @method[dc<%> set-text-mode]. + +@|DrawSizeNote| + +} + +@defmethod[(end-doc) + void?]{ + +Ends a document, relevant only when drawing to a printer or PostScript + device (including to a PostScript file). + +For printer or PostScript output, an exception is raised if +@scheme[end-doc] is called when the document is not started with +@method[dc<%> start-doc], when a page is currently started by +@method[dc<%> start-page] and not ended with @method[dc<%> end-page], +or when the document has been ended already. + +} + +@defmethod[(end-page) + void?]{ + +Ends a single page, relevant only when drawing to a printer or + PostScript device (including to a PostScript file). + +For printer or PostScript output, an exception is raised if +@scheme[end-page] is called when a page is not currently started by +@method[dc<%> start-page]. + +} + + +@defmethod[(flush) void?]{ + +Calls the @xmethod[canvas<%> flush] method for +@racket[canvas<%>] output, and has no effect for other kinds of +drawing contexts.} + + + +@defmethod[(get-alpha) + (real-in 0 1)]{ + +Gets the current opacity for drawing; see +@method[dc<%> set-alpha]. + +} + +@defmethod[(get-background) + (is-a?/c color%)]{ + +Gets the color used for painting the background. See also +@method[dc<%> set-background]. + +} + +@defmethod[(get-brush) + (is-a?/c brush%)]{ + +Gets the current brush. See also @method[dc<%> set-brush]. + +} + +@defmethod[(get-char-height) + (and/c real? (not/c negative?))]{ + +Gets the height of a character using the current font. + +Unlike most methods, this method can be called for a + @scheme[bitmap-dc%] object without a bitmap installed. + +} + +@defmethod[(get-char-width) + (and/c real? (not/c negative?))]{ + +Gets the average width of a character using the current font. + +Unlike most methods, this method can be called for a + @scheme[bitmap-dc%] object without a bitmap installed. + +} + +@defmethod[(get-clipping-region) + (or/c (is-a?/c region%) false/c)]{ + +Gets the current clipping region, returning @scheme[#f] if the drawing + context is not clipped (i.e., the clipping region is the entire + drawing region). + +} + +@defmethod[(get-font) + (is-a?/c font%)]{ + +Gets the current font. See also @method[dc<%> set-font]. + +} + +@defmethod[(get-gl-context) + (or/c (is-a?/c gl-context<%>) false/c)]{ + +Returns a @scheme[gl-context<%>] object for this drawing context + if it supports OpenGL, @scheme[#f] otherwise. + +See @scheme[gl-context<%>] for more information. + +} + +@defmethod[(get-initial-matrix) + (vector/c real? real? real? real? real? real?)]{ + +Returns a transformation matrix that converts logical coordinates to + device coordinates. The matrix applies before additional origin + offset, scaling, and rotation. + +The vector content corresponds to a transformation matrix in the +following order: + +@itemlist[ + + @item{@racket[_xx]: a scale from the logical @racket[_x] to the device @racket[_x]} + + @item{@racket[_xy]: a scale from the logical @racket[_x] added to the device @racket[_y]} + + @item{@racket[_yx]: a scale from the logical @racket[_y] added to the device @racket[_x]} + + @item{@racket[_yy]: a scale from the logical @racket[_y] to the device @racket[_y]} + + @item{@racket[_x0]: an additional amount added to the device @racket[_x]} + + @item{@racket[_y0]: an additional amount added to the device @racket[_y]} + +] + +See also @method[dc<%> set-initial-matrix] and @method[dc<%> get-transformation]. + +} + + +@defmethod[(get-origin) + (values real? real?)]{ + +Returns the device origin, i.e., the location in device coordinates of + @math{(0,0)} in logical coordinates. The origin offset applies after + the initial transformation matrix, but before scaling and rotation. + +See also @method[dc<%> set-origin] and @method[dc<%> get-transformation]. + +} + + +@defmethod[(get-pen) + (is-a?/c pen%)]{ + +Gets the current pen. See also @method[dc<%> set-pen]. + +} + +@defmethod[(get-rotation) real?]{ + +Returns the rotation of logical coordinates in radians to device +coordinates. Rotation applies after the initial transformation matrix, +origin offset, and scaling. + +See also @method[dc<%> set-rotation] and @method[dc<%> get-transformation]. + +} + +@defmethod[(get-scale) + (values real? real?)]{ + +Returns the scaling factor that maps logical coordinates to device +coordinates. Scaling applies after the initial transformation matrix +and origin offset, but before rotation. + +See also @method[dc<%> set-scale] and @method[dc<%> get-transformation]. + +} + +@defmethod[(get-size) + (values nonnegative-real? nonnegative-real?)]{ + +Gets the size of the destination drawing area. For a @scheme[dc<%>] + object obtained from a @scheme[canvas<%>], this is the (virtual + client) size of the destination window; for a @scheme[bitmap-dc%] + object, this is the size of the selected bitmap (or 0 if no bitmap is + selected); for a @scheme[post-script-dc%] or @scheme[printer-dc%] + drawing context, this gets the horizontal and vertical size of the + drawing area. + +} + +@defmethod[(get-smoothing) + (one-of/c 'unsmoothed 'smoothed 'aligned)]{ + +Returns the current smoothing mode. See @method[dc<%> set-smoothing]. + +} + +@defmethod[(get-text-background) + (is-a?/c color%)]{ + +Gets the current text background color. See also @method[dc<%> +set-text-background]. + +} + +@defmethod[(get-text-extent [string string?] + [font (or/c (is-a?/c font%) false/c) #f] + [combine? any/c #f] + [offset exact-nonnegative-integer? 0]) + (values nonnegative-real? + nonnegative-real? + nonnegative-real? + nonnegative-real?)]{ + + +Returns the size of @scheme[str] at it would be drawn in the drawing + context, starting from the @scheme[offset] character of @scheme[str], + and continuing until the end of @scheme[str] or the first null + character. The @scheme[font] argument specifies the font to use in + measuring the text; if it is @scheme[#f], the current font of the + drawing area is used. (See also @method[dc<%> set-font].) + +The result is four real numbers: + +@itemize[ + + @item{the total width of the text (depends on both the font and the + text);} + + @item{the total height of the font (depends only on the font);} + + @item{the distance from the baseline of the font to the bottom of the + descender (included in the height, depends only on the font); and} + + @item{extra vertical space added to the font by the font designer + (included in the height, and often zero; depends only on the font).} + +] + +The returned width and height define a rectangle is that guaranteed to + contain the text string when it is drawn, but the fit is not + necessarily tight. Some undefined number of pixels on the left, + right, top, and bottom of the drawn string may be ``whitespace,'' + depending on the whims of the font designer and the platform-specific + font-scaling mechanism. + +If @scheme[combine?] is @scheme[#t], then @scheme[text] may be drawn + with adjacent characters combined to ligature glyphs, with Unicode + combining characters as a single glyph, with kerning, with + right-to-left ordering of characters, etc. If @scheme[combine?] is + @scheme[#f], then the result is the same as if each character is + drawn separately, and Unicode control characters are ignored. + +Unlike most methods, this method can be called for a + @scheme[bitmap-dc%] object without a bitmap installed. + +} + + +@defmethod[(get-text-foreground) + (is-a?/c color%)]{ + +Gets the current text foreground color. See also @method[dc<%> +set-text-foreground]. + +} + + +@defmethod[(get-text-mode) + (one-of/c 'solid 'transparent)]{ +Reports how text is drawn; see +@method[dc<%> set-text-mode].} + + +@defmethod[(get-transformation) + (vector/c (vector/c real? real? real? real? real? real?) + real? real? real? real? real?)]{ + +Returns the current transformation setting of the drawing context in a +form that is suitable for restoration via @method[dc<%> +set-transformation]. + +The vector content is as follows: + +@itemlist[ + + @item{the initial transformation matrix; see @method[dc<%> + get-initial-matrix];} + + @item{the X and Y origin; see @method[dc<%> get-origin];} + + @item{the X and Y scale; see @method[dc<%> get-origin];} + + @item{a rotation; see @method[dc<%> get-rotation].} + +]} + + +@defmethod[(glyph-exists? [c char] + [font (or/c (is-a?/c font%) false/c) #f]) + boolean?]{ + +Returns @scheme[#t] if the given character has a corresponding glyph + for this drawing context, @scheme[#f] otherwise. + +Due to automatic font substitution when drawing or measuring text, the + result of this method does not depend on the given font, which merely + provides a hint for the glyph search. If the font is @scheme[#f], the + drawing context's current font is used. The result depends on the + type of the drawing context, but the result for @scheme[canvas%] + @scheme[dc<%>] instances and @scheme[bitmap-dc%] instances is always + the same for a given platform and a given set of installed fonts. + +See also @method[font% screen-glyph-exists?] . + +} + +@defmethod[(ok?) + boolean?]{ + +Returns @scheme[#t] if the drawing context is usable. + +} + + +@defmethod[(resume-flush) void?]{ + +Calls the @xmethod[canvas<%> resume-flush] method for +@racket[canvas<%>] output, and has no effect for other kinds of +drawing contexts.} + + +@defmethod[(rotate [angle real?]) void?]{ + +Adds a rotation of @racket[angle] radians to the drawing context's +current transformation. + +Afterward, the drawing context's transformation is represented in the +initial transformation matrix, and the separate origin, scale, and +rotation settings have their identity values. + +} + +@defmethod[(scale [x-scale real?] + [y-scale real?]) + void?]{ + +Adds a scaling of @racket[x-scale] in the X-direction and +@racket[y-scale] in the Y-direction to the drawing context's current +transformation. + +Afterward, the drawing context's transformation is represented in the +initial transformation matrix, and the separate origin, scale, and +rotation settings have their identity values. + +} + +@defmethod[(set-alpha [opacity (real-in 0 1)]) + void?]{ + +Determines the opacity of drawing. A value of @scheme[0.0] corresponds +to completely transparent (i.e., invisible) drawing, and @scheme[1.0] +corresponds to completely opaque drawing. For intermediate values, +drawing is blended with the existing content of the drawing context.} + + +@defmethod[(set-background [color (or/c (is-a?/c color%) string?)]) + void?]{ + +Sets the background color for drawing in this object (e.g., using +@method[dc<%> clear] or using a stippled @scheme[brush%] with the mode +@scheme['opaque]). For monochrome drawing, all non-black colors are +treated as white. + +} + +@defmethod*[([(set-brush [brush (is-a?/c brush%)]) + void?] + [(set-brush [color (is-a?/c color%)] + [style (one-of/c 'transparent 'solid 'opaque + 'xor 'hilite 'panel + 'bdiagonal-hatch 'crossdiag-hatch + 'fdiagonal-hatch 'cross-hatch + 'horizontal-hatch 'vertical-hatch)]) + void?] + [(set-brush [color-name string?] + [style (one-of/c 'transparent 'solid 'opaque + 'xor 'hilite 'panel + 'bdiagonal-hatch 'crossdiag-hatch + 'fdiagonal-hatch 'cross-hatch + 'horizontal-hatch 'vertical-hatch)]) + void?])]{ + +Sets the current brush for drawing in this object. While a brush is + selected into a drawing context, it cannot be modified. When a color + and style are given, the arguments are as for @xmethod[brush-list% + find-or-create-brush]. + +} + + +@defmethod[(set-clipping-rect [x real?] + [y real?] + [width (and/c real? (not/c negative?))] + [height (and/c real? (not/c negative?))]) + void?]{ + +Sets the clipping region to a rectangular region. + +See also @method[dc<%> set-clipping-region] and @method[dc<%> +get-clipping-region]. + +@|DrawSizeNote| + +} + +@defmethod[(set-clipping-region [rgn (or/c (is-a?/c region%) false/c)]) + void?]{ + +Sets the clipping region for the drawing area, turning off all + clipping within the drawing region if @scheme[#f] is provided. + +The clipping region must be reset after changing a @scheme[dc<%>] + object's origin or scale (unless it is @scheme[#f]); see + @scheme[region%] for more information. + +See also @method[dc<%> set-clipping-rect] and @method[dc<%> + get-clipping-region]. + +} + +@defmethod[(set-font [font (is-a?/c font%)]) + void?]{ + +Sets the current font for drawing text in this object. + +} + +@defmethod[(set-initial-matrix [m (vector/c real? real? real? real? real? real?)]) + void?]{ + +Set a transformation matrix that converts logical coordinates to + device coordinates. The matrix applies before additional origin + offset, scaling, and rotation. + +See @method[dc<%> get-initial-matrix] for information on the matrix as + represented by a vector @racket[m]. + +See also @method[dc<%> transform], which adds a transformation to the + current transformation, instead of changing the transformation + composition in the middle. + +@|DrawSizeNote| + +} + +@defmethod[(set-origin [x real?] + [y real?]) + void?]{ + +Sets the device origin, i.e., the location in device coordinates of + @math{(0,0)} in logical coordinates. The origin offset applies after + the initial transformation matrix, but before scaling and rotation. + +See also @method[dc<%> translate], which adds a translation to the + current transformation, instead of changing the transformation + composition in the middle. + +@|DrawSizeNote| + +} + +@defmethod*[([(set-pen [pen (is-a?/c pen%)]) + void?] + [(set-pen [color (is-a?/c color%)] + [width (real-in 0 255)] + [style (one-of/c 'transparent 'solid 'xor 'hilite + 'dot 'long-dash 'short-dash 'dot-dash + 'xor-dot 'xor-long-dash 'xor-short-dash + 'xor-dot-dash)]) + void?] + [(set-pen [color-name string?] + [width (real-in 0 255)] + [style (one-of/c 'transparent 'solid 'xor 'hilite + 'dot 'long-dash 'short-dash 'dot-dash + 'xor-dot 'xor-long-dash 'xor-short-dash + 'xor-dot-dash)]) + void?])]{ + +Sets the current pen for this object. When a color, width, and style + are given, the arguments are as for @xmethod[pen-list% + find-or-create-pen]. + +The current pen does not affect text drawing; see also @method[dc<%> + set-text-foreground]. + +While a pen is selected into a drawing context, it cannot be modified. + +} + +@defmethod[(set-rotation [angle real?]) void?]{ + +Set the rotation of logical coordinates in radians to device +coordinates. Rotation applies after the initial transformation matrix, +origin offset, and scaling. + +See also @method[dc<%> rotate], which adds a rotation to the current + transformation, instead of changing the transformation composition. + +@|DrawSizeNote| + +} + +@defmethod[(set-scale [x-scale real?] + [y-scale real?]) + void?]{ + +Sets a scaling factor that maps logical coordinates to device + coordinates. Scaling applies after the initial transformation matrix + and origin offset, but before rotation. Negative scaling factors have + the effect of flipping. + +See also @method[dc<%> scale], which adds a scale to the current + transformation, instead of changing the transformation composition in + the middle. + +@|DrawSizeNote| + +} + +@defmethod[(set-smoothing [mode (one-of/c 'unsmoothed 'smoothed 'aligned)]) + void?]{ + +Enables or disables anti-aliased smoothing for drawing. (Text + smoothing is not affected by this method, and is instead controlled + through the @scheme[font%] object.) + +The smoothing mode is either @scheme['unsmoothed], @scheme['smoothed], + or @scheme['aligned]. Both @scheme['aligned] and @scheme['smoothed] + are smoothing modes. + +In @scheme['smoothed] mode for a canvas or bitmap drawing context, + integer drawing coordinates correspond to the boundary between + pixels, and pen-based drawing is centered over a given line or + curve. Thus, drawing with pen width @scheme[1] from @math{(0, 10)} to + @math{(10, 10)} draws a 2-pixel wide line with @math{50%} opacity. + +The @scheme['aligned] smoothing mode is like @scheme['smoothed], but + it paints pixels more like @scheme['unsmoothed] mode. Since it aligns + shapes to pixel boundaries, @scheme['aligned] mode often produces + better results than @scheme['smoothed], but the results depend on the + application. The @scheme['aligned] mode is defined in terms of + @scheme['smoothed] mode, except that drawing coordinates are rounded + down (via @scheme[floor], after scaling and origin translation). For + line drawing, coordinates are then shifted right and down by the + @scheme[floor] of half a pen width. In addition, for pen drawing + through @method[dc<%> draw-rectangle], @method[dc<%> draw-ellipse], + @method[dc<%> draw-rounded-rectangle], and @method[dc<%> draw-arc], + the given width and height are each decreased by @math{1.0}. + +In either smoothing mode, brush and pen stipples are ignored (except + for PostScript drawing), and @scheme['hilite] and @scheme['xor] + drawing modes are treated as @scheme['solid]. If smoothing is not + supported, then attempting to set the smoothing mode to + @scheme['smoothed] or @scheme['aligned] will have no effect, and + @method[dc<%> get-smoothing] will always return + @scheme['unsmoothed]. Similarly, @method[dc<%> get-smoothing] for a + @scheme[post-script-dc%] always returns @scheme['smoothed]. + +} + +@defmethod[(set-text-background [color (or/c (is-a?/c color%) string?)]) + void?]{ + +Sets the current text background color for this object. The text + background color is painted behind text that is drawn with + @method[dc<%> draw-text], but only for the @scheme['solid] text mode + (see @method[dc<%> set-text-mode]). + +For monochrome drawing, all non-white colors are treated as black. + +} + +@defmethod[(set-text-foreground [color (or/c (is-a?/c color%) string?)]) + void?]{ + +Sets the current text foreground color for this object, used for + drawing text with +@method[dc<%> draw-text]. + +For monochrome drawing, all non-black colors are treated as + white. + +} + +@defmethod[(set-text-mode [mode (one-of/c 'solid 'transparent)]) + void?]{ + +Determines how text is drawn: + +@itemize[ + + @item{@scheme['solid] --- Before text is drawn, the destination area + is filled with the text background color (see @method[dc<%> + set-text-background]).} + + @item{@scheme['transparent] --- Text is drawn directly over any + existing image in the destination, as if overlaying text + written on transparent film.} + +] + +} + + +@defmethod[(set-transformation + [t (vector/c (vector/c real? real? real? real? real? real?) + real? real? real? real? real?)]) + void?]{ + +Sets the draw context's transformation. See @method[dc<%> +get-transformation] for information about @racket[t].} + + +@defmethod[(start-doc [message string?]) + boolean?]{ + +Starts a document, relevant only when drawing to a printer or + PostScript device (including to a PostScript file). For some + platforms, the @scheme[message] string is displayed in a dialog until + @method[dc<%> end-doc] is called. + +For printer or PostScript output, an exception is raised if + @scheme[start-doc] has been called already (even if @method[dc<%> + end-doc] has been called as well). Furthermore, drawing methods raise + an exception if not called while a page is active as determined by + @method[dc<%> start-doc] and @method[dc<%> start-page]. + +} + +@defmethod[(start-page) + void?]{ + +Starts a page, relevant only when drawing to a printer or PostScript + device (including to a PostScript file). + +For printer or PostScript output, an exception is raised if + @scheme[start-page] is called when a page is already started, or when + @method[dc<%> start-doc] has not been called, or when @method[dc<%> + end-doc] has been called already. In addition, in the case of + PostScript output, Encapsulated PostScript (EPS) cannot contain + multiple pages, so calling @scheme[start-page] a second time for a + @scheme[post-script-dc%] instance raises an exception; to create + PostScript output with multiple pages, supply @scheme[#f] as the + @scheme[as-eps] initialization argument for @scheme[post-script-dc%]. + +} + + +@defmethod[(suspend-flush) void?]{ + +Calls the @xmethod[canvas<%> suspend-flush] method for +@racket[canvas<%>] output, and has no effect for other kinds of +drawing contexts.} + + +@defmethod[(transform [m (vector/c real? real? real? real? real? real?)]) + void?]{ + +Adds a transformation by @racket[m] to the drawing context's current +transformation. + +See @method[dc<%> get-initial-matrix] for information on the matrix as + represented by a vector @racket[m]. + +Afterward, the drawing context's transformation is represented in the +initial transformation matrix, and the separate origin, scale, and +rotation settings have their identity values. + +} + +@defmethod[(translate [dx real?] + [dy real?]) + void?]{ + +Adds a scaling of @racket[dx] in the X-direction and @racket[dy] in +the Y-direction to the drawing context's current transformation. + +Afterward, the drawing context's transformation is represented in the +initial transformation matrix, and the separate origin, scale, and +rotation settings have their identity values. + +} + + +@defmethod[(try-color [try (is-a?/c color%)] + [result (is-a?/c color%)]) + void?]{ + +Determines the actual color used for drawing requests with the given + color. The @scheme[result] color is set to the RGB values that are + actually produced for this drawing context to draw the color + @scheme[try]. + +}} diff --git a/collects/scribblings/guide/draw.scrbl b/collects/scribblings/guide/draw.scrbl new file mode 100644 index 0000000000..5b4ebc268f --- /dev/null +++ b/collects/scribblings/guide/draw.scrbl @@ -0,0 +1,642 @@ +#lang scribble/doc +@(require scribble/manual + "guide-utils.ss" + scribble/eval + scribble/racket + (for-syntax racket/base) + (for-label racket/draw + racket/math + racket/gui)) + +@(define draw-eval (make-base-eval)) +@interaction-eval[#:eval draw-eval (require racket/class + racket/draw)] +@interaction-eval[#:eval draw-eval (define (copy-bitmap bm0) + (let ([w (send bm0 get-width)] + [h (send bm0 get-height)]) + (let ([bm (make-bitmap w h)]) + (let ([dc (make-object bitmap-dc% bm)]) + (send dc draw-bitmap bm0 0 0) + (send dc set-bitmap #f)) + bm)))] +@interaction-eval[#:eval draw-eval (define (line-bitmap mode) + (let* ([bm (make-bitmap 30 4)] + [dc (make-object bitmap-dc% bm)]) + (send dc set-smoothing mode) + (send dc draw-line 0 2 30 2) + (send dc set-bitmap #f) + bm))] +@interaction-eval[#:eval draw-eval (define (path-bitmap zee join brush?) + (let* ([bm (make-bitmap 40 40)] + [dc (new bitmap-dc% [bitmap bm])]) + (send dc set-smoothing 'aligned) + (send dc set-pen (new pen% [width 5] [join join])) + (if brush? + (send dc set-brush blue-brush) + (send dc set-brush "white" 'transparent)) + (send dc draw-path zee 5 5) + (send dc set-bitmap #f) + bm))] + +@(define-syntax-rule (define-linked-method name interface) + (define-syntax name + (make-element-id-transformer + (lambda (stx) + #'(method interface name))))) +@(define-linked-method draw-line dc<%>) +@(define-linked-method draw-rectangle dc<%>) +@(define-linked-method set-pen dc<%>) +@(define-linked-method set-font dc<%>) +@(define-linked-method set-clipping-region dc<%>) +@(define-linked-method set-alpha dc<%>) +@(define-linked-method get-pen dc<%>) +@(define-linked-method set-brush dc<%>) +@(define-linked-method get-brush dc<%>) +@(define-linked-method set-smoothing dc<%>) +@(define-linked-method draw-path dc<%>) +@(define-linked-method draw-ellipse dc<%>) +@(define-linked-method draw-text dc<%>) +@(define-linked-method draw-bitmap dc<%>) +@(define-linked-method get-text-extent dc<%>) +@(define-linked-method set-text-foreground dc<%>) +@(define-linked-method draw-arc dc<%>) +@(define-linked-method erase dc<%>) +@(define-linked-method set-stipple brush%) +@(define-linked-method line-to dc-path%) +@(define-linked-method curve-to dc-path%) +@(define-linked-method move-to dc-path%) +@(define-linked-method append dc-path%) +@(define-linked-method arc dc-path%) +@(define-linked-method reverse dc-path%) +@(define-linked-method ellipse dc-path%) +@(define-linked-method translate dc<%>) +@(define-linked-method scale dc<%>) +@(define-linked-method rotate dc<%>) +@(define-linked-method set-path region%) + +@title[#:tag "draw"]{Drawing} + +The @racketmodname[racket/draw] library provides a drawing API that is +based on the PostScript drawing model. It supports line drawing, shape +filling, bitmap copying, alpha blending, and affine transformations +(i.e., scale, rotation, and translation). + +@guideother{See @secref["classes"] for an introduction to classes and +interfaces in Racket.} + +Drawing with @racketmodname[racket/draw] requires a @deftech{drawing context} +(@deftech{DC}), which is an instance of the @scheme[dc<%>] +interface. For example, the @racket[post-script-dc%] class implements +a @racket[dc<%>] for drawing to a PostScript file, while @racket[bitmap-dc%] +draws to a bitmap. When using the @racketmodname[racket/gui] library for GUIs, +the @method[canvas<%> get-dc] method of a +canvas returns a @scheme[dc<%>] instance for drawing into the canvas +window. + +@; ------------------------------------------------------------ +@section{Lines and Simple Shapes} + +To draw into a bitmap, first create the bitmap with +@racket[make-bitmap], and then create a @racket[bitmap-dc%] that draws +into the new bitmap: + +@racketblock+eval[ +#:eval draw-eval +(define target (make-bitmap 30 30)) (code:comment "A 30x30 bitmap") +(define dc (new bitmap-dc% [bitmap target])) +] + +Then, use methods like @method[dc<%> draw-line] on the @tech{DC} to draw +into the bitmap. For example, the sequence + +@racketblock+eval[ +#:eval draw-eval +(send dc draw-rectangle + 0 10 (code:comment @#,t{Top-left at (0, 10), 10 pixels down from top-left}) + 30 10) (code:comment @#,t{30 pixels wide and 10 pixels high}) +(send dc draw-line + 0 0 (code:comment @#,t{Start at (0, 0), the top-left corner}) + 30 30) (code:comment @#,t{and draw to (30, 30), the bottom-right corner}) +(send dc draw-line + 0 30 (code:comment @#,t{Start at (0, 30), the bottom-left corner}) + 30 0) (code:comment @#,t{and draw to (30, 0), the top-right corner}) +] + +draws an ``X'' on top of a smaller rectangle into the bitmap @racket[target]. If +you save the bitmap to a file with @racket[(send target #,(:: bitmap% save-file) +"box.png" 'png)], the @filepath{box.png} contains the image + +@centered{@interaction-eval-show[#:eval draw-eval (copy-bitmap target)]} + +in PNG format. + +A line-drawing drawing operation like @racket[draw-line] uses the +@tech{DC}'s current @defterm{pen} to draw the line. A pen has a color, +line width, and style, where pen styles include @racket['solid], +@racket['long-dash], and @racket['transparent]. Enclosed-shape +operations like @racket[draw-rectangle] use both the current pen and +the @tech{DC}'s current @deftech{brush}. A brush has a color and style, +where brush styles include @racket['solid], @racket['cross-hatch], and +@racket['transparent]. + +@margin-note{In DrRacket, instead of saving @racket[target] to a file +viewing the image from the file, you can use @racket[(require +racket/gui)] and @racket[(make-object image-snip% target)] to view the +bitmap in the DrRacket interactions window.} + +For example, set the brush and pen before the drawing operations to +draw a thick, red ``X'' on a green rectangle with a thin, blue border: + +@racketblock+eval[ +#:eval draw-eval +(send dc set-brush "green" 'solid) +(send dc set-pen "blue" 1 'solid) +(send dc draw-rectangle 0 10 30 10) +(send dc set-pen "red" 3 'solid) +(send dc draw-line 0 0 30 30) +(send dc draw-line 0 30 30 0) +] + +@centered{@interaction-eval-show[#:eval draw-eval (copy-bitmap target)]} + +To draw a filled shape without an outline, set the pen to +@racket['transparent] mode (with any color and line width). For +example, + +@racketblock+eval[ +#:eval draw-eval +(send dc set-pen "white" 1 'transparent) +(send dc set-brush "black" 'solid) +(send dc draw-ellipse 5 5 20 20) +] + +@centered{@interaction-eval-show[#:eval draw-eval (copy-bitmap target)]} + +By default, a @racket[bitmap-dc%] draws solid pixels without smoothing +the boundaries of shapes. To enable smoothing, set the +smoothing mode to either @racket['smoothed] or @racket['aligned]: + +@racketblock+eval[ +#:eval draw-eval +(send dc set-smoothing 'aligned) +(send dc set-brush "black" 'solid) +(send dc draw-ellipse 4 4 22 22) (code:comment @#,t{a little bigger}) +] + +@centered{@interaction-eval-show[#:eval draw-eval (copy-bitmap target)]} + +The difference between @racket['aligned] mode and @racket['smoothed] +mode is related to the relatively coarse granularity of pixels in a +bitmap. Conceptually, drawing coordinates correspond to the lines +between pixels, and the pen is centered on the line. In +@racket['smoothed] mode, drawing on a line causes the pen to draw at +half strength on either side of the line, which produces the following +result for a 1-pixel black pen: + +@centered[@interaction-eval-show[#:eval draw-eval (line-bitmap 'smoothed)]] + +but @racket['aligned] mode shifts drawing coordinates to make the pen +fall on whole pixels, so a 1-pixel black pen draws a single line of +pixels: + +@centered[@interaction-eval-show[#:eval draw-eval (line-bitmap 'aligned)]] + +@; ------------------------------------------------------------ +@section{Pen, Brush, and Color Objects} + +The @racket[set-pen] and @racket[set-brush] methods of a @tech{DC} + accept @scheme[pen%] and @scheme[brush%] objects, which group + together pen and brush settings. + +@schemeblock+eval[ +#:eval draw-eval +(require racket/math) + +(define no-pen (new pen% [style 'transparent])) +(define no-brush (new brush% [style 'transparent])) +(define blue-brush (new brush% [color "blue"])) +(define yellow-brush (new brush% [color "yellow"])) +(define red-pen (new pen% [color "red"] [width 2])) + +(define (draw-face dc) + (send dc set-smoothing 'aligned) + + (send dc set-pen no-pen) + (send dc set-brush blue-brush) + (send dc draw-ellipse 25 25 100 100) + + (send dc set-brush yellow-brush) + (send dc draw-rectangle 50 50 10 10) + (send dc draw-rectangle 90 50 10 10) + + (send dc set-brush no-brush) + (send dc set-pen red-pen) + (send dc draw-arc 37 37 75 75 (* 5/4 pi) (* 7/4 pi))) + +(define target (make-bitmap 150 150)) +(define dc (new bitmap-dc% [bitmap target])) + +(draw-face dc) +] + +@centered{@interaction-eval-show[#:eval draw-eval (copy-bitmap target)]} + +The @racket[get-pen] and @racket[get-brush] methods return a +@tech{DC}'s current pen and brush, so they can be restored after +changing them temporarily for drawing. + +Besides grouping settings, a @racket[pen%] or @racket[brush%] object +includes extra settings that are not available by using +@racket[set-pen] or @racket[set-brush] directly. For example, a pen or +brush can have a @deftech{stipple}, which is a bitmap that is used +instead of a solid color when drawing. For example, if +@filepath{water.png} has the image + +@centered{@image["water.png"]} + +then it can be loaded with @racket[read-bitmap] and installed as the +stipple for @racket[blue-brush]: + +@schemeblock+eval[ +#:eval draw-eval +(send blue-brush set-stipple (read-bitmap "water.png")) +(send dc erase) +(draw-face dc) +] + +@centered{@interaction-eval-show[#:eval draw-eval (copy-bitmap target)]} + +Along similar lines, a @racket[color%] object lets you specify a color +through its red, green, and blue components instead of a built-in +color name. Due to the way that @racket[color%] initialization is +overloaded, use @racket[make-object%] instead of @racket[new] to +instantiate @racket[color%]: + +@schemeblock+eval[ +#:eval draw-eval +(define red-pen + (new pen% [color (make-object color% 200 100 150)] [width 2])) +(send dc erase) +(draw-face dc) +] + +@centered{@interaction-eval-show[#:eval draw-eval (copy-bitmap target)]} + + +@; ------------------------------------------------------------ +@section{Transformations} + +Any coordinates or lengths supplied to drawing commends are +transformed by a @tech{DC}'s current transformation matrix. The +transformation matrix can scale an image, draw it at an offset, or +rotate all drawing. The transformation can be set directly, or the +current transformation can be transformed further with methods like +@racket[scale], @racket[translate], or @racket[rotate]: + +@schemeblock+eval[ +#:eval draw-eval +(send dc erase) +(send dc scale 0.5 0.5) +(draw-face dc) +(send dc rotate (/ pi 2)) +(send dc translate 0 150) +(draw-face dc) +(send dc translate 0 -150) +(send dc rotate (/ pi 2)) +(send dc translate 150 150) +(draw-face dc) +(send dc translate -150 -150) +(send dc rotate (/ pi 2)) +(send dc translate 150 0) +(draw-face dc) +] + +Use the @method[dc<%> get-transformation] method to get a @tech{DC}'s +current transformation, and restore a saved transformation (or any +affine transformation) using @method[dc<%> set-transformation]. + +@centered{@interaction-eval-show[#:eval draw-eval (copy-bitmap target)]} + +@; ------------------------------------------------------------ +@section{Drawing Paths} + +Drawing functions like @racket[draw-line] and @racket[draw-rectangle] + are actually convenience functions for the more general + @racket[draw-path] operation. The @racket[draw-path] operation takes + a @deftech{path}, which describes a set of line segments and curves + to draw with the pen and---in the case of closed set of lines and + curves---fill with the current brush. + +An instance of @racket[dc-path%] holds a path. Conceptually, a path + has a current pen position that is manipulated by methods like + @racket[move-to], @racket[line-to], and @racket[curve-to]. The + @racket[move-to] method starts a sub-path, and @racket[line-to] and + @racket[curve-to] extend it. The @racket[close] method moves the pen + from its current position in a straight line to its starting + position, completing the sub-path and forming a closed path that can + be filled with the brush. A @racket[dc-path%] object can have + multiple closed sub-paths and one final open path, where the open + path is drawn only with the pen. + +For example, + +@racketblock+eval[ +#:eval draw-eval +(define zee (new dc-path%)) +(send zee move-to 0 0) +(send zee line-to 30 0) +(send zee line-to 0 30) +(send zee line-to 30 30) +] + +creates an open path. Drawing this path with a black pen of width 5 +and a transparent brush produces + +@centered{@interaction-eval-show[#:eval draw-eval (path-bitmap zee 'round #f)]} + +Drawing a single path with three line segments is not the same as +drawing three separate lines. When multiple line segments are drawn at +once, the corner frm one line to the next is shaped according to the +pen's join style. The image above uses the default @racket['round] +join style. With @racket['miter], line lines are joined with sharp +corners: + +@centered{@interaction-eval-show[#:eval draw-eval (path-bitmap zee 'miter #f)]} + +If the sub-path in @racket[zee] is closed with @racket[close], then +all of the corners are joined, including the corner at the initial +point: + +@racketblock+eval[ +#:eval draw-eval +(send zee close) +] + +@centered{@interaction-eval-show[#:eval draw-eval (path-bitmap zee 'miter #f)]} + +Using @racket[blue-brush] instead of a transparent brush causes the +interior of the path to be filled: + +@centered{@interaction-eval-show[#:eval draw-eval (path-bitmap zee 'miter #t)]} + +When a sub-path is not closed, it is implicitly closed for brush +filling, but left open for pen drawing. When both a pen and brush are +available (i.e., not transparent), then the brush is used first, so +that the pen draws on top of the brush. + +At this point we can't resist showing an extended example using +@racket[dc-path%] to draw the Racket logo: + +@racketblock+eval[ +#:eval draw-eval +(define red-brush (new brush% [stipple (read-bitmap "fire.png")])) + +(define left-lambda-path + (let ([p (new dc-path%)]) + (send p move-to 153 44) + (send p line-to 161.5 60) + (send p curve-to 202.5 49 230 42 245 61) + (send p curve-to 280.06 105.41 287.5 141 296.5 186) + (send p curve-to 301.12 209.08 299.11 223.38 293.96 244) + (send p curve-to 281.34 294.54 259.18 331.61 233.5 375) + (send p curve-to 198.21 434.63 164.68 505.6 125.5 564) + (send p line-to 135 572) + p)) + +(define left-logo-path + (let ([p (new dc-path%)]) + (send p append left-lambda-path) + (send p arc 0 0 630 630 (* 235/360 2 pi) (* 121/360 2 pi) #f) + p)) + +(define bottom-lambda-path + (let ([p (new dc-path%)]) + (send p move-to 135 572) + (send p line-to 188.5 564) + (send p curve-to 208.5 517 230.91 465.21 251 420) + (send p curve-to 267 384 278.5 348 296.5 312) + (send p curve-to 301.01 302.98 318 258 329 274) + (send p curve-to 338.89 288.39 351 314 358 332) + (send p curve-to 377.28 381.58 395.57 429.61 414 477) + (send p curve-to 428 513 436.5 540 449.5 573) + (send p line-to 465 580) + (send p line-to 529 545) + p)) + +(define bottom-logo-path + (let ([p (new dc-path%)]) + (send p append bottom-lambda-path) + (send p arc 0 0 630 630 (* 314/360 2 pi) (* 235/360 2 pi) #f) + p)) + +(define right-lambda-path + (let ([p (new dc-path%)]) + (send p move-to 153 44) + (send p curve-to 192.21 30.69 233.21 14.23 275 20) + (send p curve-to 328.6 27.4 350.23 103.08 364 151) + (send p curve-to 378.75 202.32 400.5 244 418 294) + (send p curve-to 446.56 375.6 494.5 456 530.5 537) + (send p line-to 529 545) + p)) + +(define right-logo-path + (let ([p (new dc-path%)]) + (send p append right-lambda-path) + (send p arc 0 0 630 630 (* 314/360 2 pi) (* 121/360 2 pi) #t) + p)) + +(define lambda-path + (let ([p (new dc-path%)]) + (send p append left-lambda-path) + (send p append bottom-lambda-path) + (let ([t (new dc-path%)]) + (send t append right-lambda-path) + (send t reverse) + (send p append t)) + (send p close) + p)) + +(define (paint-racket dc) + (send dc set-pen "black" 0 'transparent) + (send dc set-brush "white" 'solid) + (send dc draw-path lambda-path) + + (send dc set-pen "black" 4 'solid) + + (send dc set-brush red-brush) + (send dc draw-path left-logo-path) + (send dc draw-path bottom-logo-path) + + (send dc set-brush blue-brush) + (send dc draw-path right-logo-path)) + +(define racket-logo (make-bitmap 170 170)) +(define dc (new bitmap-dc% [bitmap racket-logo])) + +(send dc set-smoothing 'smoothed) +(send dc translate 5 5) +(send dc scale 0.25 0.25) +(paint-racket dc) +] + +@centered{@interaction-eval-show[#:eval draw-eval racket-logo]} + +In addition to the core @racket[move-to], @racket[line-to], +@racket[curve-to], and @racket[close] methods, a @racket[dc-path%] +includes many convenience methods, such as @racket[ellipse] for adding +a closed elliptical sub-path to the path. + +@; ------------------------------------------------------------ +@section{Text} + +Draw text using the @racket[draw-text] method, which takes a string to +draw and a location for the top-left of the drawn text: + +@racketblock+eval[ +#:eval draw-eval +(define text-target (make-bitmap 100 30)) +(define dc (new bitmap-dc% [bitmap text-target])) +(send dc set-brush "white" 'transparent) + +(send dc draw-rectangle 0 0 100 30) +(send dc draw-text "Hello, World!" 5 1) +] + +@centered{@interaction-eval-show[#:eval draw-eval (copy-bitmap text-target)]} + +The font used to draw text is determined by the @tech{DC}'s current +font. A font is described by a @racket[font%] object and installed +with @racket[set-font]. The color of drawn text which is separate from +either the pen or brush, can be set using +@racket[set-text-foreground]. + + +@racketblock+eval[ +#:eval draw-eval +(send dc erase) +(send dc set-font (make-object font% 14 'roman 'normal 'bold)) +(send dc set-text-foreground "blue") +(send dc draw-rectangle 0 0 100 30) +(send dc draw-text "Hello, World!" 5 1) +] + +@centered{@interaction-eval-show[#:eval draw-eval (copy-bitmap text-target)]} + +To compute the size that will be used by drawn text, use +@racket[get-text-extent], which returns four values: the total width, +total height, difference between the baseline and total height, and +extra space (if any) above the text in a line. For example, the result +of @racket[get-text-extent] can be used to position text within the +center of a box: + +@racketblock+eval[ +#:eval draw-eval +(send dc erase) +(send dc draw-rectangle 0 0 100 30) +(define-values (w h d a) (send dc get-text-extent "Hello, World!")) +(send dc draw-text "Hello, World!" (/ (- 100 w) 2) (/ (- 30 h) 2)) +] + +@centered{@interaction-eval-show[#:eval draw-eval (copy-bitmap text-target)]} + + +@; ------------------------------------------------------------ +@section{Alpha Channels and Alpha Blending} + +When you create or @racket[erase] a bitmap, the content is +nothing. ``Nothing'' isn't the same as white; it's the absence of +drawing. For example, if you take @racket[text-target] from the +previous section and copy it onto another @tech{DC} using +@racket[draw-bitmap], then the black rectangle and blue text is +transferred, and the background is left alone: + +@racketblock+eval[ +#:eval draw-eval +(define new-target (make-bitmap 100 30)) +(define dc (new bitmap-dc% [bitmap new-target])) +(send dc set-pen "black" 1 'transparent) +(send dc set-brush "pink" 'solid) + +(send dc draw-rectangle 0 0 100 30) +(send dc draw-bitmap text-target 0 0) +] + +@centered{@interaction-eval-show[#:eval draw-eval (copy-bitmap new-target)]} + +The information about which pixels of a bitmap are drawn (as opposed +to ``nothing'') is the bitmap's @deftech{alpha channel}. Not all +@tech{DC}s keep an alpha channel, but bitmaps created with +@racket[make-bitmap] keep an alpha channel by default. Bitmaps loaded +with @racket[read-bitmap] preserve transparency in the image file +through the bitmap's alpha channel. + +An alpha channel isn't all or nothing. When the edges text is +anti-aliased by @racket[draw-text], for example, the pixels are +partially transparent. When the pixels are transferred to another +@tech{DC}, the partially transparent pixel is blended with the target +pixel in a process called @deftech{alpha blending}. Furthermore, a +@tech{DC} has an alpha value that is applied to all drawing +operations; an alpha value of @racket[1.0] corresponds to solid +drawing, an alpha value of @racket[0.0] makes the drawing have no +effect, and values in between make the drawing translucent. + +For example, setting the @tech{DC}'s alpha to @racket[0.25] before +calling @racket[draw-bitmap] causes the blue and black of the ``Hello, +World!'' bitmap to be quarter strength as it is blended with the +destination image: + +@racketblock+eval[ +#:eval draw-eval +(send dc erase) +(send dc draw-rectangle 0 0 100 30) +(send dc set-alpha 0.25) +(send dc draw-bitmap text-target 0 0) +] + +@centered{@interaction-eval-show[#:eval draw-eval (copy-bitmap new-target)]} + +@; ------------------------------------------------------------ +@section{Clipping} + +In addition to tempering the opacity of drawing operations, a +@tech{DC} has a @deftech{clipping region} that constrains all drawing to +inside the region. In the simplest case, a clipping region corresponds +to a closed path, but it can also be the union, intersection, +subtraction, or exclusive-or of two paths. + +For example, a clipping region could be set to three circles to clip +the drawing of a rectangle (with the 0.25 alpha still in effect): + +@racketblock+eval[ +#:eval draw-eval +(define r (new region%)) +(let ([p (new dc-path%)]) + (send p ellipse 00 0 35 30) + (send p ellipse 35 0 30 30) + (send p ellipse 65 0 35 30) + (send r set-path p)) +(send dc set-clipping-region r) +(send dc set-brush "green" 'solid) +(send dc draw-rectangle 0 0 100 30) +] + +@centered{@interaction-eval-show[#:eval draw-eval (copy-bitmap new-target)]} + +The clipping region can be viewed as a convenient alternative to path +filling or drawing with stipples. Conversely, stippled drawing can be +viewed as a convenience alternative to clipping repeated calls of +@racket[draw-bitmap]. + + +@; ------------------------------------------------------------ +@section{Portability} + +Drawing effects are not completely portable across platforms or across +types of DC. For example. drawing to a bitmap produced by +@racket[make-bitmap] may produce slightly different results than +drawing to one produced by @racketmodname[racket/gui]'s +@racket[make-screen-bitmap], but drawing to a bitmap from +@racket[make-screen-bitmap] should be the same as drawing to an +onscreen @racket[canvas%]. Fonts and text, especially, can vary across +platforms and types of @tech{DC}, but so can the precise set of pixels +touched by drawing a line. diff --git a/collects/scribblings/guide/fire.png b/collects/scribblings/guide/fire.png new file mode 100644 index 0000000000000000000000000000000000000000..102b047c7b3939875c07e7b31938bf5ca1dfd938 GIT binary patch literal 3094 zcmV+x4C(WUP)4Tx0C)j~RL^S@K@|QrZmG~B2wH0nvUrdpNm;9CMbtL^5n^i$+aIn^?(HA4aZWV5ov6ELTdbo0FI&wK{O>*+w4vx20?>!`FrQsdJlnHR>OPy zcd~b_n$otK2Za4V;76L-DzNVtaSB-y0*E}{p()372;bw_^6ZZ}PI-92wGS&j#91PI zKs7DSe@(bk%_Y-7gGe}(^>I=@oY#w#*Bu9GZf3^F5WP>3rn}7Ut74&?PWBFvy`A)a zPP5)V!Xd&78LdA?xQ(9mjMYElVd13a#D+Z_7&Y|xU=_C-srWU*6kiZcC!$nw*)9$7 zn6CX+@=AhmkT}X@VSsa5NKe;HZuq)~1$`#h6R+ZTR#D-3j}vF!)ZOnz+5)dI4jl{{ z44Mr{P!L4~VVJN`K!!XTF*LGrKO?IK8z<8w`3e3jI8lUGNUta*C8 zn(P`s>{pjD=7Kek#B;Fw@hxAK%$F&Q6vg9J^Xf~4by_hu-=A!MJ3Znq&n~srbFGPs zH&&aMXZ>nO`|hf|ljc?VPhR!${AbO?W8x_>CU%PFA&Hm8F7cAsOREdwU~R_;ot1_u z(ruCYB-LPGn!NQdT|ZlRy+(fw^-+`=%+gee_kY4FWHg<*4sZI8+sFJD270UUORdLHO0nA4V) z%{fwsET5CQ>B?eK%uw4yQc~9?*JVo2}ze(;aRcp*ceL#HUJSllrgm5wQKR zQu+C;QrUh^8rFfA`ftFz{YAidi-`aL010qNS#tmY3ljhU3ljkVnw%H_00_=WL_t(o z32m6$mgKk%1bM6Oz5V|$`qfYNdP*W4kx-4j=PXC1rYH~zBtVdw{*T_TbFS9jUj0Wq zyS3ihudV$y+8?K{cE)K8-fir*d+(#2@75R`jq(0t&40E2&;9;4GP}Kc`@PTKPvh$S z?tirPTc6)^pL6=T`q`VAo%w?{1IE2BG}5^DlU{CELwg23;~2z+&ikOTd9`+7C@nrP z#U7w{=YE)|369|6n*H2CVtkFkm{PH(0~nakU*XF#IuH;+6-6P$cp-c>tkDiNluh-} zu|$;skI`0ddv@ld6fzNqQJ9khSjBhm(Sj6AfP})I4X+A@Db*s5XzbvD7hag!_t0L% z00C>EZqh>s!7&ah;k}#}{G;=4{uGSz(a7U7g8je|i_(xkSQ9DLD%qhK2L)CEKk{JZ zZTVet+-X`K9B!t|2PktRQ0Deft+qHBr{gz*8R1XVt+m>Hx6LJ)_slpMN_sC9=2Y#Q^=6*H~B(BT)8!-?UCz>zZtcwa=Qr>g8ZrxH6oK28|^r z)g2fIZ5gU=9zWe_!3o>{cb7%l)&rx@EkdZxcwa>LUOLMQc|mBL>4SX+kpJ19Kqj0u zh&3uYC{VKG5fgwb9e~Lvv=Igr69^2NeXRS7BGlXKoF6F-vU%_sb89{rbm|V04*a!| zWelPa`|GWKe(WZ`5Wq^(u2MyZ3>agz?>PV>*Wc}ic3!CAf++j|mDIp|TItQ;Qz9Hq z3;O3l?^T1V2;=QzRy@!qvCnl~Yg7B#5MHx?-Q!2wz>6+E%ZZm2<8qyMSPBTgGDWjW zY4A`>` zgz^MD9qx|}n6A)ZAG(L(O5+HA~Bn1h2;B-Pk-$dP5J2 zIaXj(<%if&#VlxFd+rTi?4@iS6j#$=eaLfaCax3ZtVJUCb3~n8Qt3BM4P_r}zHyd1R~x5WCb==%OO|Dx5u$))PPS?h1*(zL@$z~! zVnr&lz+BOyvjtto0qR1CmGtRA*g_m95=D@2+$IVv8aB6zAbTs?RRl5FGzc!!*%hJm z*?zK3Flt;?9J8GBzW^Jr+Swc~>`bF35b1E|4ONw;4&E|a!8CX zL4^^vVgRs>iKq;Epgu-~_4v*41jHA<5;<*_0%D(Y+;&xw@oyew8%2xY=kTcO$|nmb z1FTFAADSEGfj3elF@F+g4bmwzlFHG>w2g=>RuxG(tQN}%v$wnclKH5zAYp@x&ZEsM z#|yAw#r>+{jR1nCQcl3a(EI~*?wWxoBoff_hs`?d@{%%e-H&c?q|rU*h6&Rga7rQA zn8qw@)b%nqx?`a6Vy5H;(!YV=7A{tN60vsmmgyR&1$C2)&BU6}zCFQk5>rjmp15!dt0qYoq*4Fa z{?E;qT!7JznD%QvttRBoIBsS|t~D2;4%fmgK}KRB_G;!&0a-95O)K>CB>`(3Jg(i} zIqqe;&=y10ddFA!$;BhK@`wujHklAfV@6DN!saAHp|ySTGK^VYu^q?W>2dmb_5Rfc zS)Rl0GbO;-zb{< z_A{EVD#x*aT7)V*Qa+4wY{o}FG*yKO#l%7>BcwFCAP~On_+>_p#4xwFET9|Bd-B1O ztz1=N-RBFAm1il83-fx8>RRA-@J(pIHZ#T5Z0V$v>TLYw-PNsWF0K&cc9e`yezFRR z0*zIOu;HuwEM}4dSlkX964rt$RS4*`*zz30P_C`6s<17v=N>F#u~I%&PMG9ao2vMv zsut~4U?G-Hdetik&5eZ0JF9D{2V}-+<36#N|sP4jxCD% zIwFj~3Iv)YS$L>(UAemUpK+c4>v7NBrZDC)9rc)=HP$(qrt})DIy1R#=tF4hb|?)!3;evNRdut`Oz1M z33zM)`T$#PAs11AIo1Jw69!7k;J;_aFKrNSvzHF1u!>eP&Lo$1iXazu>KI~dOZ*5n zfl+n5RxgnvbV`tKwH7De(8O}SI)#`4Tx0C)j~RL^S@K@|QrZmG~B2wH0nvUrdpNm;9CMbtL^5n^i$+aIn^?(HA4aZWV5ov6ELTdbo0FI&wK{O>*+w4vx20?>!`FrQsdJlnHR>OPy zcd~b_n$otK2Za4V;76L-DzNVtaSB-y0*E}{p()372;bw_^6ZZ}PI-92wGS&j#91PI zKs7DSe@(bk%_Y-7gGe}(^>I=@oY#w#*Bu9GZf3^F5WP>3rn}7Ut74&?PWBFvy`A)a zPP5)V!Xd&78LdA?xQ(9mjMYElVd13a#D+Z_7&Y|xU=_C-srWU*6kiZcC!$nw*)9$7 zn6CX+@=AhmkT}X@VSsa5NKe;HZuq)~1$`#h6R+ZTR#D-3j}vF!)ZOnz+5)dI4jl{{ z44Mr{P!L4~VVJN`K!!XTF*LGrKO?IK8z<8w`3e3jI8lUGNUta*C8 zn(P`s>{pjD=7Kek#B;Fw@hxAK%$F&Q6vg9J^Xf~4by_hu-=A!MJ3Znq&n~srbFGPs zH&&aMXZ>nO`|hf|ljc?VPhR!${AbO?W8x_>CU%PFA&Hm8F7cAsOREdwU~R_;ot1_u z(ruCYB-LPGn!NQdT|ZlRy+(fw^-+`=%+gee_kY4FWHg<*4sZI8+sFJD270UUORdLHO0nA4V) z%{fwsET5CQ>B?eK%uw4yQc~9?*JVo2}ze(;aRcp*ceL#HUJSllrgm5wQKR zQu+C;QrUh^8rFfA`ftFz{YAidi-`aL010qNS#tmY3ljhU3ljkVnw%H_01dH8L_t(o z300Wua@@KRgb4y9NNS~(WS^>3$47Dc^uFdkgKK`}!nwT;Os3YbIedu5LruIp;yTZY9Qkna8qe7Ete1%{#TLcgIJl>L#}F0K}?VKxTQao2F^o zwrko04eNsD0OTvLNwhj>91uL1nMHT(K2I}%#6Q-kUE6iTW1ebPm~M61)mvQ$7G!8m zW?@wyU1-`EVS=@>29%nS`B}pQso^K?l#+Qdcu2wsA6x}bS{w`b;9*%K7WE?kg@y$g zzHJ*wf}{J%2O|SO%*F}_Ag);pN|t5flWSH5 zLBP!dp)Zn;T?a4VU_es>#7%jtkq(~v*mYgb<#al&+r|R$S+-T6cL|Q?^ zd5ZyhFe8)$GJ455Pt$}+T=52PfgrdhG7G5rM3hV?B8*QVs?D9ygOvd_xTn~>zP^6l zu5Iowx9e~kO5WCW;Z3GvPQ9b|g*)OeS*qArw|!k#E_i<1%bLKGL9?V8X3Y(I*)u|a z;*Eo6KAFp0BL^EGOw4v(a? z0%6iS|G{i1)uSqFY zeY^NIC$!%{C44b04`VFM;b=%Bb8(v_!k54#cur$UDAOJl%{*SJjlTz=1CwH87KP?b z!AE0=8ZH_i@ZFZy*w$X^-HlxV3 zeN8w4(lKV=SIeYY7k&hQ{KrpK6>?7U3vmn%c-j)`J23GOlwu#NYGLN{yeq>t5;LJ9 zK#F3r8hP8InpJDa#=IR$N;#ifR0T0@!!xDtTKR3?ACF1ytKf!&#u8$MRUnmMgBaXB z=XHS?ZV0}zB&h}D21ltuUq~2)l29@orGlAIY}pYfm|^=dt+=Z1`%>XFr9K1}ky&gX zVgclfNZ6aKN&zHCUaRt5Ql1RJp|_ zYA}!NcnK{XWY%4SLMarOpO&d@o`%>uA0alc)g|A?aa^zfA7{m;?5kmm*?drG1P8Nv ze&8n+B!#FPp;^I1Jv7IIh|ooqtc$7q#(zFRr}CTk%(pG4cCQ!GA0?J|EsQB?Ytbxl z1C$Y#NQny$$>uMsg3<=o%5DvC90YQ~SEw|>@y)*4Q@XMz?JxeL_SyqwSKiWOW-V&7 z#DoMdE}gLQJn{RzR6mK++QG63Vs^$MTB8TFr*0 zw{bwRcR_)Vxep8YN61+j;EaPVmXQ@^2C%5}Pft(75K9$OuBUmO<_xR@jaJq|astUi z8Ak1g8WpNE?XWU8gNGPA%N6|>CYS-lw+OTcc$FdT=&udE18Kym0P&$;#Z9lOKQ9#L zeOh(`YkbUjO)fnKb0|lP0!?CbBI+6TSpD!3a~dUxS)GGIO^jnq2Tk0dajr8G0mX4-e)ezJ&259)2Zu~D(Kx*l(ek~QaclAGRUKHtIHI; zqh%9W|3`*?QcjSWa-oI-fg*@Y6<@)DW*7#hx?Hb6Kd-lOy54U0X`B}29zqO0(Hy8m zyC%R;Oi{Q|CC!nlrhKIdQA0$>Ms-lps0PVbDYQ(7nqOv%QGpr(|`gIF!YsYwkBsJJ2#z8e*C8Ai~8B0$h# zhn6gbrRX^+K;oH)NLR3>(#^n3YL?tY6?=Jk!IU3Aeh^-lulr-1*`lzDl?0VmOxIv? zmQ@il!8pr9CRV8eNcQLO5%SPRj-<%oeR|?7L2jEBYtamWUR@;>4BYUl$U1?iC-?lk ze2vrmb-D66FGy!G*t{=5Oeue$9ijoFvGJ{`|b%ZkNl2+=H{YV+ON6Qd1%;8}cCK%X=sU z<8&KPs-BYRSJMSnHTdRmm+@`9nn%G-*iNY_{EW=dCIMKT^64P_<#7>KQQ)%R+7s zz^GEK?Td*l2FVaIXud?u%4Ymm5@9+yL8vG=+&sVtqioZ6`B8?!yrpPe;|I{N2jg9! z96sWj-%ycl(Uh>1M5uoP#pBvz5abN#;rip_1I~_o!z9K8b4U)h>tJnQs#GH${_$16 zY88?Xa%>~-uq3k+HN3@iyo~bMJOS3|bZi*7AhOiw>TH2>gO@^whH1ZgVdC<)8G7C5 zktPq(95h(1!x^eoc#L1Q{H4!9XSet*E2Bx52zfl^toQIdTwuk|rB$8b;QE zeq`9it{+Zp(9X|bX@@R64ejUWg@w=-Prw78oYG)rp-h2`S8Z3$eM=kMhiFAIuu!5z z?VF*Z)1xC{?=(|JN{jqyQnwU2=b#If%Xi;IXqKPlK=v5T(06~lzrDSm*(iSh{v87@ zms{;J`wMc!UT5Z>r_qOwsiBs1qg}E3aqLyBAP`xu#?CIhq(U=^*ejBY;k);q`nvzn;FmpWk24Y+*ltUdRWYPKzy>&NNm$3y~rQXv+KQfym5U z;(5iFq7O;RZAb}v7(iRK7qRH&yXvT-fp-+o45UaTlls5`y<~7^A?3WjzP!J`yuF>z z=VvBi*Ta(NYh5y2#4y-5CL_?{z{IOsCz&%?i%;;_r<8u&4D@lr@%y`CNa;atLU#nA zdK8_>X|qmRAdcAny$s#AZ*PBme>=YnFGD{s(-@m>iAyLkWF0_MnO?MO`;BT-WwpRi zA&!{**I*@vQXjpRFo2!|E81*Hj2vy@%@gK3lAl2dq&%1h8nw)G5*H#u?pqp?igum; zF3(eF{HY)A_YtZfl6c#;nINrW!=d3;NU$8lu!i-mI6zw*aU<@G4nFw`CT+Zd`3tiu zoqk7U29QW0{s^yzz$U7xR+I<+Qn6`qC?`#Db3Z)~G>60U>5N9J%Y!IUiVE|69BI@@ zkSeRc%Mu`Pl(F-Rf@5`&C=GEWqvq(q3Rj9fn*X+I!39Ze7lFbc?{Pm(iBm5E#qI08 zt%t6ex-d`qIhAkUzP+5^`;VVLKd#e~I8JIhH;!qab*3Zl9K(FTS140Kmov>}Y`fS_ z@rM(A(Q~yU(0+A~x8C)S9DQ*U-{!rC(JL2j@9@ zn(4KH;}y_aoN1YiR7kw*z=~kz(6nu$G^-Po2o5?x9-^GF{RR_RoARW<-fTl|MVtF% zFtQ2%W*+2Fm(;GaD$l*cn5WYlK|s_pRhp^%w4;iAL9oF!e+`*F&<`6rQn zAILz|ZM?%oyi5zBTC1~i!iR$kye=rr#$()V)@EMFgpQiRC;13f!_}H;OXKVL9c#b7 zzRKef0zPC9C$}MQ`AWrFRsl2g!wWmQ*hIv0xDRJD2x%5(F;p-4Swf?v=y-r@Zn5ow zAgYmx6$79S@;Uf`am<0C7|S&N$*C>cB7ySE!40-?&HQR*Y;gY=0D2~N*g++{!Rd+l zMP%qKO*Kd*9t{ACfzsf_!a>@UJTZ=_*q6LDj@~}xg;RY7wHX=`$J$7c#opiFhv9^> nB@*t4BQ-g^OU*pc@Y;U>G2aScCH#!q00000NkvXXu0mjft(!SM literal 0 HcmV?d00001 From c92a6b0e3dc71f57ffd1838e9c0f116ef83dcd60 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 27 Nov 2010 16:39:25 -0700 Subject: [PATCH 168/255] fix long line --- collects/scribblings/reference/port-lib.scrbl | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/collects/scribblings/reference/port-lib.scrbl b/collects/scribblings/reference/port-lib.scrbl index d6a31a3bc8..7b5f75b8b1 100644 --- a/collects/scribblings/reference/port-lib.scrbl +++ b/collects/scribblings/reference/port-lib.scrbl @@ -51,7 +51,8 @@ Read all characters from @scheme[in], breaking them into lines. The @scheme['linefeed]. @examples[#:eval port-eval -(port->lines (open-input-string "line 1\nline 2\n line 3\nline 4")) +(port->lines + (open-input-string "line 1\nline 2\n line 3\nline 4")) ]} @defproc[(port->bytes-lines [in input-port? (current-input-port)] @@ -62,7 +63,8 @@ Like @scheme[port->lines], but reading bytes and collecting them into lines like @scheme[read-bytes-line]. @examples[#:eval port-eval -(port->bytes-lines (open-input-string "line 1\nline 2\n line 3\nline 4")) +(port->bytes-lines + (open-input-string "line 1\nline 2\n line 3\nline 4")) ]} @defproc[(display-lines [lst list?] From af318c450165f89fdca614c98e33c499de4fd45e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 27 Nov 2010 17:47:30 -0700 Subject: [PATCH 169/255] move racket/draw overview back to the racket/draw manual but keep expanded roadmap of drawing and GUI libraries --- collects/scribblings/draw/draw.scrbl | 4 +--- collects/scribblings/{guide => draw}/fire.png | Bin .../{guide/draw.scrbl => draw/guide.scrbl} | 11 +++++------ .../scribblings/{guide => draw}/water.png | Bin collects/scribblings/guide/graphics.scrbl | 16 +++++++++------- collects/scribblings/guide/guide.scrbl | 2 -- collects/scribblings/guide/other.scrbl | 18 +++++++++++++++--- 7 files changed, 30 insertions(+), 21 deletions(-) rename collects/scribblings/{guide => draw}/fire.png (100%) rename collects/scribblings/{guide/draw.scrbl => draw/guide.scrbl} (99%) rename collects/scribblings/{guide => draw}/water.png (100%) diff --git a/collects/scribblings/draw/draw.scrbl b/collects/scribblings/draw/draw.scrbl index 247cc879ae..0d7bc3c38f 100644 --- a/collects/scribblings/draw/draw.scrbl +++ b/collects/scribblings/draw/draw.scrbl @@ -11,13 +11,11 @@ @racketmodname[racket/draw] library provides all of the class, interface, and procedure bindings defined in this manual.} -For an overview of the drawing library, see @secref["draw" #:doc -'(lib "scribblings/guide/guide.scrbl")]. - @table-of-contents[] @;------------------------------------------------------------------------ +@include-section["guide.scrbl"] @include-section["bitmap-class.scrbl"] @include-section["bitmap-dc-class.scrbl"] @include-section["brush-class.scrbl"] diff --git a/collects/scribblings/guide/fire.png b/collects/scribblings/draw/fire.png similarity index 100% rename from collects/scribblings/guide/fire.png rename to collects/scribblings/draw/fire.png diff --git a/collects/scribblings/guide/draw.scrbl b/collects/scribblings/draw/guide.scrbl similarity index 99% rename from collects/scribblings/guide/draw.scrbl rename to collects/scribblings/draw/guide.scrbl index 5b4ebc268f..3b01bfc70b 100644 --- a/collects/scribblings/guide/draw.scrbl +++ b/collects/scribblings/draw/guide.scrbl @@ -1,12 +1,10 @@ #lang scribble/doc @(require scribble/manual - "guide-utils.ss" + "common.ss" scribble/eval scribble/racket (for-syntax racket/base) - (for-label racket/draw - racket/math - racket/gui)) + (for-label racket/math)) @(define draw-eval (make-base-eval)) @interaction-eval[#:eval draw-eval (require racket/class @@ -74,14 +72,15 @@ @(define-linked-method rotate dc<%>) @(define-linked-method set-path region%) -@title[#:tag "draw"]{Drawing} +@title[#:tag "overview"]{Overview} The @racketmodname[racket/draw] library provides a drawing API that is based on the PostScript drawing model. It supports line drawing, shape filling, bitmap copying, alpha blending, and affine transformations (i.e., scale, rotation, and translation). -@guideother{See @secref["classes"] for an introduction to classes and +@margin-note{See @secref["classes" #:doc '(lib +"scribblings/guide/guide.scrbl")] for an introduction to classes and interfaces in Racket.} Drawing with @racketmodname[racket/draw] requires a @deftech{drawing context} diff --git a/collects/scribblings/guide/water.png b/collects/scribblings/draw/water.png similarity index 100% rename from collects/scribblings/guide/water.png rename to collects/scribblings/draw/water.png diff --git a/collects/scribblings/guide/graphics.scrbl b/collects/scribblings/guide/graphics.scrbl index 5c82988000..e65a1cc8bd 100644 --- a/collects/scribblings/guide/graphics.scrbl +++ b/collects/scribblings/guide/graphics.scrbl @@ -2,7 +2,7 @@ @(require scribble/manual "guide-utils.ss") -@title[#:tag "graphics" #:style 'toc]{Graphics and GUIs} +@title[#:tag "graphics"]{Graphics and GUIs} Racket provides many libraries for graphics and graphical user interfaces (GUIs): @@ -10,15 +10,19 @@ interfaces (GUIs): @itemlist[ @item{The @racketmodname[racket/draw] library provides basic drawing - tools, including @tech{drawing contexts} such as bitmaps and + tools, including drawing contexts such as bitmaps and PostScript files. - See @secref["draw"] for an overview.} + See @other-doc['(lib "scribblings/draw/draw.scrbl")] + for more information.} @item{The @racketmodname[racket/gui] library provides GUI widgets such as windows, buttons, checkboxes, and text fields. The library also includes a sophisticated and extensible text - editor.} + editor. + + See @other-doc['(lib "scribblings/gui/gui.scrbl")] + for more information.} @item{The @racketmodname[slideshow/pict] library provides a more functional abstraction layer over @racketmodname[racket/draw]. @@ -29,7 +33,7 @@ interfaces (GUIs): "scribblings/scribble/scribble.scrbl") "top"]{Scribble} documents or other drawing tasks. Pictures created with the @racketmodname[slideshow/pict] library can be rendered to any - @tech{drawing context}. + drawing context. See @other-doc['(lib "scribblings/slideshow/slideshow.scrbl")] for more information.} @@ -49,5 +53,3 @@ interfaces (GUIs): information.} ] - -@include-section["draw.scrbl"] diff --git a/collects/scribblings/guide/guide.scrbl b/collects/scribblings/guide/guide.scrbl index 37091df6a8..3403354234 100644 --- a/collects/scribblings/guide/guide.scrbl +++ b/collects/scribblings/guide/guide.scrbl @@ -52,8 +52,6 @@ precise details to @|Racket| and other reference manuals. @include-section["languages.scrbl"] -@include-section["graphics.scrbl"] - @include-section["performance.scrbl"] @include-section["running.scrbl"] diff --git a/collects/scribblings/guide/other.scrbl b/collects/scribblings/guide/other.scrbl index 8db3c32999..70802e7cac 100644 --- a/collects/scribblings/guide/other.scrbl +++ b/collects/scribblings/guide/other.scrbl @@ -4,14 +4,26 @@ @title{More Libraries} -@other-manual['(lib "scribblings/foreign/foreign.scrbl")] describes -tools for using Racket to access libraries that are normally used by C -programs. +This guide covers only the Racket language and libraries that are +documented in @|Racket|. The Racket distribution includes many +additional libraries. + +@include-section["graphics.scrbl"] + +@section{The Web Server} @other-manual['(lib "web-server/scribblings/web-server.scrbl")] describes the Racket web server, which supports servlets implemented in Racket. +@section{Using Foreign Libraries} + +@other-manual['(lib "scribblings/foreign/foreign.scrbl")] describes +tools for using Racket to access libraries that are normally used by C +programs. + +@section{And More} + @link["../index.html"]{Racket Documentation} lists documentation for many other installed libraries. Run @exec{raco docs} to find documentation for libraries that are installed on your system and From 5c89df2f7fd0f4c8c0bc0219327d96d64e0c578a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 27 Nov 2010 18:34:33 -0700 Subject: [PATCH 170/255] Revise places docs to fit the reference-manual style --- .../scribblings/reference/concurrency.scrbl | 2 +- collects/scribblings/reference/futures.scrbl | 4 +- collects/scribblings/reference/places.scrbl | 184 +++++++++--------- 3 files changed, 100 insertions(+), 90 deletions(-) diff --git a/collects/scribblings/reference/concurrency.scrbl b/collects/scribblings/reference/concurrency.scrbl index e7217e6779..0f1cf00843 100644 --- a/collects/scribblings/reference/concurrency.scrbl +++ b/collects/scribblings/reference/concurrency.scrbl @@ -1,7 +1,7 @@ #lang scribble/doc @(require "mz.ss") -@title[#:tag "concurrency" #:style 'toc]{Concurrency} +@title[#:tag "concurrency" #:style 'toc]{Concurrency and Parallelism} Racket supports multiple threads of control within a program, thread-local storage, some primitive synchronization mechanisms, and a diff --git a/collects/scribblings/reference/futures.scrbl b/collects/scribblings/reference/futures.scrbl index 5094024427..896c80595e 100644 --- a/collects/scribblings/reference/futures.scrbl +++ b/collects/scribblings/reference/futures.scrbl @@ -5,7 +5,7 @@ @(define future-eval (make-base-eval)) @(interaction-eval #:eval future-eval (require racket/future)) -@title[#:tag "futures"]{Futures for Parallelism} +@title[#:tag "futures"]{Futures} @guideintro["effective-futures"]{futures} @@ -19,7 +19,7 @@ Racket.} The @racket[future] and @racket[touch] functions from @racketmodname[racket/future] provide access to parallelism as -supported by the hardware and operation system. +supported by the hardware and operating system. In contrast to @racket[thread], which provides concurrency for arbitrary computations without parallelism, @racket[future] provides parallelism for limited computations. A future executes its work in diff --git a/collects/scribblings/reference/places.scrbl b/collects/scribblings/reference/places.scrbl index 3e0d1b3e2a..fbc1fb212f 100644 --- a/collects/scribblings/reference/places.scrbl +++ b/collects/scribblings/reference/places.scrbl @@ -1,6 +1,6 @@ #lang scribble/doc -@title[#:tag "places"]{@bold{Places}: Coarse-grained Parallelism} +@title[#:tag "places"]{Places} @; ---------------------------------------------------------------------- @@ -12,70 +12,53 @@ racket/base racket/contract racket/place - racket/flonum)) + racket/future + racket/flonum + racket/fixnum)) @; ---------------------------------------------------------------------- -@deftech{Places} enable the development of parallel programs that -take advantage of machines with multiple processors, cores, or -hardware threads. +@margin-note{Parallel support for @racket[place] is currently disabled by +default. Enable places by supplying @DFlag{enable-places} to +@exec{configure} when building Racket.} @note-lib[racket/place] -Note: currently, parallel support for @racket[place] is disabled by -default, and using it will raise an exception. Support can only be -enabled if you build Racket yourself, and pass @DFlag{enable-places} to -@exec{configure}. This works only for @exec{racket} (not -@exec{gracket}), and it is supported only on Linux x86/x86_64, and Mac -OS X x86/x86_64 platforms. +@tech{Places} enable the development of parallel programs that +take advantage of machines with multiple processors, cores, or +hardware threads. -@defproc[(place [module-path module-path?] [start-proc symbol?]) place?]{ - Starts running @racket[start-proc] in parallel. @racket[start-proc] must - be a function defined in @racket[module-path]. The @racket[place] - procedure returns immediately with a place descriptor value representing the newly constructed place. - Each place descriptor value is also a @racket[place-channel] that permits communication with the place. -} +A @deftech{place} is a parallel task that is effectively a separate +instance of the Racket virtual machine. Places communicate through +@deftech{place channels}, which are endpoints for a two-way buffered +communication. -@defproc[(place-wait [p place?]) exact-integer?]{ - Returns the return value of a completed place @racket[p], blocking until - the place completes (if it has not already completed). -} +To a first approximation, place channels allow only immutable values +as messages over the channel: numbers, characters, booleans, immutable +pairs, immutable vectors, and immutable structures. In addition, place +channels themselves can be sent across channels to establish new +(possibly more direct) lines of communication in addition to any +existing lines. Finally, mutable values produced by +@racket[shared-flvector], @racket[make-shared-flvector], +@racket[shared-fxvector], @racket[make-shared-fxvector], +@racket[shared-bytes], and @racket[make-shared-bytes] can be sent +across place channels; mutation of such values is visible to all +places that share the value, because they are allowed in a +@deftech{shared memory space}. -@defproc[(place? [x any/c]) boolean?]{ - Returns @racket[#t] if @racket[x] is a place-descriptor value, @racket[#f] otherwise. -} +A @tech{place channel} can be used as a @tech{synchronizable event} +(see @secref["sync"]) to receive a value through the channel. A place +can also receive messages with @racket[place-channel-recv], and +messages can be sent with @racket[place-channel-send]. -@defproc[(place-channel) (values place-channel? place-channel?)]{ - Returns two @racket[place-channel] endpoint objects. - - One @racket[place-channel] endpoint should be used by the current @racket[place] to send - messages to a destination @racket[place]. +Constraints on messages across a place channel---and therefore on the +kinds of data that places share---enable greater parallelism than +@racket[future], even including separate @tech{garbage collection} of +separate places. At the same time, the setup and communication costs +for places can be higher than for futures. - The other @racket[place-channel] endpoint should be sent to a destination @racket[place] over - an existing @racket[place-channel]. -} - -@defproc[(place-channel-send [ch place-channel?] [x any/c]) void]{ - Sends an immutable message @racket[x] on channel @racket[ch]. -} - -@defproc[(place-channel-recv [p place-channel?]) any/c]{ - Returns an immutable message received on channel @racket[ch]. -} - -@defproc[(place-channel? [x any/c]) boolean?]{ - Returns @racket[#t] if @racket[x] is a place-channel object. -} - -@defproc[(place-channel-send/recv [ch place-channel?] [x any/c]) void]{ - Sends an immutable message @racket[x] on channel @racket[ch] and then - waits for a repy message. - Returns an immutable message received on channel @racket[ch]. -} - -@section[#:tag "example"]{Basic Example} - -This code launches two places, echos a message to them and then waits for the places to complete and return. +For example, the following expression lanches two places, echoes a +message to each, and then waits for the places to complete and return: @racketblock[ (let ([pls (for/list ([i (in-range 2)]) @@ -87,48 +70,75 @@ This code launches two places, echos a message to them and then waits for the pl (map place-wait pls)) ] -This is the code for the place-worker.ss module that each place will execute. +The @filepath{place-worker.rkt} module must export the +@racket[place-main] function that each place executes, where +@racket[place-main] must accept a single @tech{place channel} +argument: -@racketblock[ -(module place-worker racket - (provide place-main) +@racketmod[ +racket +(provide place-main) - (define (place-main ch) - (place-channel-send ch (format "Hello from place ~a" (place-channel-recv ch))))) +(define (place-main ch) + (place-channel-send ch (format "Hello from place ~a" + (place-channel-recv ch)))) ] -@section[#:tag "place-channels"]{Place Channels} -Place channels can be used with @racket[place-channel-recv], or as a -@tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{synchronizable event} - (see @secref[#:doc '(lib "scribblings/reference/reference.scrbl") "sync"]) to receive a value -through the channel. The channel can be used with @racket[place-channel-send] -to send a value through the channel. -@section[#:tag "messagepassingparallelism"]{Message Passing Parallelism} +@defproc[(place? [x any/c]) boolean?]{ + Returns @racket[#t] if @racket[x] is a @deftech{place descriptor} + value, @racket[#f] otherwise. Every @tech{place descriptor} + is also a @tech{place channel}. +} -Places communicate by passing messages on place-channels. -Only atomic values, immutable pairs, vectors, and structs can be -communicated across places channels. +@defproc[(place-channel? [x any/c]) boolean?]{ + Returns @racket[#t] if @racket[x] is @tech{place channel}, + @racket[#f] otherwise. +} -@section[#:tag "places-architecture"]{Architecture and Garbage Collection} +@defproc[(place [module-path module-path?] [start-proc symbol?]) place?]{ -Places enables a @deftech{shared memory space} between all places. -References from the @tech{shared memory space} back into a places memory space. -The invariant of allowing no backpointers is enforced by only allowing immutable -datastructures to be deep copied into the @tech{shared memory space}. + Creates a @tech{place} to run the procedure that is identified by + @racket[module-path] and @racket[start-proc]. The result is a + @tech{place descriptor} value that represents the new parallel task; + the place descriptor is returned immediately. The place descriptor + value is also a @tech{place channel} that permits communication with + the place. -However, mutation of atomic values in -the @tech{shared memory space} is permitted to improve performace of -shared-memory parallel programs. + The module indicated by @racket[module-path] must export a function + with the name @racket[start-proc]. The function must accept a single + argument, which is a @tech{place channel} that corresponds to the + other end of communication for the @tech{place descriptor} returned + by @racket[place].} -Special functions such as @racket[shared-flvector] and @racket[shared-bytes] allocate -vectors of mutable atomic values into the @tech{shared memory space}. -Parallel mutation of these atomic values -can possibly lead to data races, but will not cause @exec{racket} to -crash. In practice however, parallel tasks usually write to disjoint -partitions of a shared vector. +@defproc[(place-wait [p place?]) exact-integer?]{ + Returns the completion value of the place indicated by @racket[p], + blocking until the place completes if it has not already completed. +} -Places are allowed to garbage collect independently of one another. -The shared-memory collector, however, has to pause all -places before it can collect garbage. + +@defproc[(place-channel) (values place-channel? place-channel?)]{ + + Returns two @tech{place channels}. Data send through the first + channel can be received through the second channel, and data send + through the second channel can be received from the first. + + Typically, one place channel is used by the current @tech{place} to + send messages to a destination @tech{place}; the other place channel + us sent to the destination @tech{place} (via an existing @tech{place + channel}). +} + +@defproc[(place-channel-send [ch place-channel?] [v any/c]) void]{ + Sends a message @racket[v] on channel @racket[ch]. +} + +@defproc[(place-channel-recv [p place-channel?]) any/c]{ + Returns a message received on channel @racket[ch]. +} + +@defproc[(place-channel-send/recv [ch place-channel?] [v any/c]) void]{ + Sends an immutable message @racket[v] on channel @racket[ch] and then + waits for a reply message on the same channel. +} From 57f0fe841457b7d5fa14272132258d0b10fcd83b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 27 Nov 2010 18:47:49 -0700 Subject: [PATCH 171/255] fix reference description of GRacket --- collects/scribblings/reference/startup.scrbl | 30 +++++++++++--------- 1 file changed, 17 insertions(+), 13 deletions(-) diff --git a/collects/scribblings/reference/startup.scrbl b/collects/scribblings/reference/startup.scrbl index 800a9998e2..6000b8dae9 100644 --- a/collects/scribblings/reference/startup.scrbl +++ b/collects/scribblings/reference/startup.scrbl @@ -26,12 +26,15 @@ The core Racket run-time system is available in two main variants: @as-index{@exec{racket}}. Under Windows, the executable is called @as-index{@exec{Racket.exe}}.} - @item{GRacket, which extends @exec{racket} with GUI primitives on - which @racketmodname[racket/gui/base] is implemented. Under - Unix, the executable is called @as-index{@exec{gracket}}. Under - Windows, the executable is called - @as-index{@exec{GRacket.exe}}. Under Mac OS X, the @exec{gracket} - script launches @as-index{@exec{GRacket.app}}.} + @item{GRacket, which is a GUI variant of @exec{racket} to the degree + that the system distinguishes them. Under Unix, the executable + is called @as-index{@exec{gracket}}, and single-instance flags + and X11-related flags are handled and communicated specially to + the @racket[racket/gui/base] library. Under Windows, the + executable is called @as-index{@exec{GRacket.exe}}, and it is a + GUI application (as opposed to a console application) that + implements singe-instance support. Under Mac OS X, the + @exec{gracket} script launches @as-index{@exec{GRacket.app}}.} ] @@ -92,10 +95,11 @@ is started, Racket loads the file @racket[(find-system-path @racket[(find-graphical-system-path 'init-file)] is loaded, unless the @Flag{q}/@DFlag{no-init-file} flag is specified on the command line. -Finally, before GRacket exists, it waits for all frames to class, all -timers to stop, @|etc| in the main @|eventspace| by evaluating -@racket[(racket 'yield)]. This waiting step can be suppressed with the -@Flag{V}/@DFlag{no-yield} command-line flag. +Finally, before Racket or GRacket exits, it calls the procedure that +is the current value of @racket[executable-yield-handler] in the main +thread, unless the @Flag{V}/@DFlag{no-yield} command-line flag is +specified. Requiring @racketmodname[racket/gui/base] sets this parameter call +@racket[(racket 'yield)]. @; ---------------------------------------------------------------------- @@ -212,9 +216,9 @@ flags: leave application in the background.} @item{@FlagFirst{V} @DFlagFirst{no-yield} : Skips final - @racket[(yield 'wait)] action, which normally waits until all + @racket[executable-yield-handler] action, which normally waits until all frames are closed, @|etc| in the main @|eventspace| before - exiting.} + exiting for programs that use @racketmodname[racket/gui/base].} ]} @@ -333,7 +337,7 @@ the insertion of @Flag{u}/@DFlag{require-script}): @FlagFirst{xnllanguage} @nonterm{arg}, or @FlagFirst{xrm} @nonterm{arg} : Standard X11 arguments that are mostly ignored but accepted for compatibility with other X11 programs. The - @Flag{synchronous} and @Flag{xrm} flags behave in the usual + @Flag{synchronous} flag behaves in the usual way.} @item{@FlagFirst{singleInstance} : If an existing GRacket is already From e20b411712a894e446501a8d4f844ced30b0c167 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 27 Nov 2010 18:54:32 -0700 Subject: [PATCH 172/255] explain gracket a bit better in the Guide --- collects/scribblings/guide/running.scrbl | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/collects/scribblings/guide/running.scrbl b/collects/scribblings/guide/running.scrbl index 7310ac79b9..10f34c3151 100644 --- a/collects/scribblings/guide/running.scrbl +++ b/collects/scribblings/guide/running.scrbl @@ -18,6 +18,12 @@ explains how to run @exec{racket} and @exec{gracket}. @section[#:tag "racket"]{Running @exec{racket} and @exec{gracket}} +The @exec{gracket} executable is the same as @exec{racket}, but with +small adjustments to behave as a GUI application rather than a console +application. For example, @exec{gracket} by default runs in +interactive mode with a GUI window instead of a console prompt. GUI +applications can be run with plain @exec{racket}, however. + Depending on command-line arguments, @exec{racket} or @exec{gracket} runs in @seclink["start-interactive-mode"]{interactive mode}, @seclink["start-module-mode"]{module mode}, or From 94e2d46a8eea69ea3705c3747152e9c578d0fff2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 27 Nov 2010 19:01:17 -0700 Subject: [PATCH 173/255] move Typed Racket manuals to the Languages section --- collects/typed-scheme/info.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/info.rkt b/collects/typed-scheme/info.rkt index c18cc35e7b..30046e0591 100644 --- a/collects/typed-scheme/info.rkt +++ b/collects/typed-scheme/info.rkt @@ -1,4 +1,4 @@ #lang setup/infotab -(define scribblings '(("scribblings/ts-reference.scrbl" ()) - ("scribblings/ts-guide.scrbl" (multi-page)))) +(define scribblings '(("scribblings/ts-reference.scrbl" () (language -1)) + ("scribblings/ts-guide.scrbl" (multi-page) (language)))) From 68391fe2ea94af688bcc8c5825fb92d66fc0784d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 27 Nov 2010 20:01:41 -0700 Subject: [PATCH 174/255] reorganize racket/gui docs and expand canvas-drawing overview --- collects/scribblings/draw/guide.scrbl | 4 + collects/scribblings/gui/dynamic.scrbl | 20 ++- .../scribblings/gui/editor-overview.scrbl | 2 +- collects/scribblings/gui/gui.scrbl | 26 +++- collects/scribblings/gui/guide.scrbl | 21 ---- collects/scribblings/gui/win-overview.scrbl | 117 +++++++++++++++--- 6 files changed, 136 insertions(+), 54 deletions(-) diff --git a/collects/scribblings/draw/guide.scrbl b/collects/scribblings/draw/guide.scrbl index 3b01bfc70b..9b40ce1708 100644 --- a/collects/scribblings/draw/guide.scrbl +++ b/collects/scribblings/draw/guide.scrbl @@ -92,6 +92,10 @@ the @method[canvas<%> get-dc] method of a canvas returns a @scheme[dc<%>] instance for drawing into the canvas window. +@margin-note{See @secref["canvas-drawing" #:doc '(lib +"scribblings/gui/gui.scrbl")] for an introduction to drawing +in a GUI window.} + @; ------------------------------------------------------------ @section{Lines and Simple Shapes} diff --git a/collects/scribblings/gui/dynamic.scrbl b/collects/scribblings/gui/dynamic.scrbl index b0f35c3f6b..2e4e52f85d 100644 --- a/collects/scribblings/gui/dynamic.scrbl +++ b/collects/scribblings/gui/dynamic.scrbl @@ -5,21 +5,17 @@ @title{Dynamic Loading} @defmodule[racket/gui/dynamic]{The @racketmodname[racket/gui/dynamic] -library provides functions for dynamically accessing the Racket -GUI toolbox, instead of directly requiring @racket[racket/gui] or -@racket[racket/gui/base].} +library provides functions for dynamically accessing the +@racketmodname[racket/gui/base] library, instead of directly requiring +@racketmodname[racket/gui] or @racketmodname[racket/gui/base].} @defproc[(gui-available?) boolean?]{ -Returns @racket[#t] if dynamic access to the GUI bindings are -available---that is, that the program is being run as a -GRacket-based application, as opposed to a pure -Racket-based application, and that GUI modules are attached -to the namespace in which @racket[racket/gui/dynamic] was -instantiated. - -This predicate can be used in code that optionally uses GUI elements -when they are available.} +Returns @racket[#t] if dynamic access to the GUI bindings is +available. The bindings are available if +@racketmodname[racket/gui/base] has been loaded, instantiated, and +attached to the namespace in which @racket[racket/gui/dynamic] was +instantiated.} @defproc[(gui-dynamic-require [sym symbol?]) any]{ diff --git a/collects/scribblings/gui/editor-overview.scrbl b/collects/scribblings/gui/editor-overview.scrbl index f8cbcfcc64..bc0c15bf1f 100644 --- a/collects/scribblings/gui/editor-overview.scrbl +++ b/collects/scribblings/gui/editor-overview.scrbl @@ -2,7 +2,7 @@ @(require scribble/bnf "common.ss") -@title[#:tag "editor-overview"]{Editor} +@title[#:tag "editor-overview"]{Editors} The editor toolbox provides a foundation for two common kinds of applications: diff --git a/collects/scribblings/gui/gui.scrbl b/collects/scribblings/gui/gui.scrbl index 31cdac7af2..fe6050f7a0 100644 --- a/collects/scribblings/gui/gui.scrbl +++ b/collects/scribblings/gui/gui.scrbl @@ -17,13 +17,35 @@ to the bindings of @racketmodname[racket/draw].} @racketmodname[racket] language and the @racketmodname[racket/gui/base] and @racketmodname[racket/draw] modules.} +The @racketmodname[racket/draw] toolbox is roughly organized into two +parts: + +@itemize[ + + @item{The @deftech{windowing toolbox}, for implementing windows, + buttons, menus, text fields, and other controls.} + + @item{The @deftech{editor toolbox}, for developing traditional text + editors, editors that mix text and graphics, or free-form layout + editors (such as a word processor, HTML editor, or icon-based file + browser).} + +] + +Both parts of the toolbox rely extensively on the +@racketmodname[racket/draw] drawing library. @table-of-contents[] @;------------------------------------------------------------------------ -@include-section["guide.scrbl"] -@include-section["reference.scrbl"] +@include-section["win-overview.scrbl"] +@include-section["win-classes.scrbl"] +@include-section["win-funcs.scrbl"] +@include-section["editor-overview.scrbl"] +@include-section["editor-classes.scrbl"] +@include-section["editor-funcs.scrbl"] +@include-section["wxme.scrbl"] @include-section["prefs.scrbl"] @include-section["dynamic.scrbl"] diff --git a/collects/scribblings/gui/guide.scrbl b/collects/scribblings/gui/guide.scrbl index 3b4058e5c8..25d2702939 100644 --- a/collects/scribblings/gui/guide.scrbl +++ b/collects/scribblings/gui/guide.scrbl @@ -3,27 +3,6 @@ @title[#:style '(toc reveal)]{Overview} -For documentation purposes, the graphics toolbox is organized into - two parts: - -@itemize[ - - @item{The @deftech{windowing toolbox}, for implementing form-filling - GUI programs (such as a database query window) using buttons, menus, - text fields, and events. The windowing toolbox is described in - @secref["windowing-overview"].} - - @item{The @deftech{editor toolbox}, for developing traditional text - editors, editors that mix text and graphics, or free-form layout - editors (such as a word processor, HTML editor, or icon-based file - browser). The editor toolbox is described in - @secref["editor-overview"].} - -] - -Simple GUI programs access only the windowing toolbox directly, while - large-scale applications tend to use the editor toolbox as well. - @local-table-of-contents[] @;------------------------------------------------------------------------ diff --git a/collects/scribblings/gui/win-overview.scrbl b/collects/scribblings/gui/win-overview.scrbl index 1b632b55a4..45ad0a0aa7 100644 --- a/collects/scribblings/gui/win-overview.scrbl +++ b/collects/scribblings/gui/win-overview.scrbl @@ -5,11 +5,19 @@ @title[#:tag "windowing-overview"]{Windowing} -The Racket windowing toolbox provides the basic building blocks of GUI +The windowing toolbox provides the basic building blocks of GUI programs, including frames (top-level windows), modal dialogs, menus, - buttons, check boxes, text fields, and radio buttons. The toolbox - provides these building blocks via built-in classes, such as the - @scheme[frame%] class: + buttons, check boxes, text fields, and radio buttons---all as + classes. + +@margin-note{See @secref["classes" #:doc '(lib +"scribblings/guide/guide.scrbl")] for an introduction to classes and +interfaces in Racket.} + +@section{Creating Windows} + +To create a new top-level window, instantiate the @scheme[frame%] + class: @schemeblock[ (code:comment @#,t{Make a frame by instantiating the @scheme[frame%] class}) @@ -21,7 +29,7 @@ The Racket windowing toolbox provides the basic building blocks of GUI The built-in classes provide various mechanisms for handling GUI events. For example, when instantiating the @scheme[button%] class, - the programmer supplies an event callback procedure to be invoked + supply an event callback procedure to be invoked when the user clicks the button. The following example program creates a frame with a text message and a button; when the user clicks the button, the message changes: @@ -46,18 +54,18 @@ The built-in classes provide various mechanisms for handling GUI ] Programmers never implement the GUI event loop directly. Instead, the - system automatically pulls each event from an internal queue and + windowing system automatically pulls each event from an internal queue and dispatches the event to an appropriate window. The dispatch invokes the window's callback procedure or calls one of the window's - methods. In the above program, the system automatically invokes the + methods. In the above program, the windowing system automatically invokes the button's callback procedure whenever the user clicks @onscreen{Click Me}. If a window receives multiple kinds of events, the events are dispatched to methods of the window's class instead of to a callback procedure. For example, a drawing canvas receives update events, - mouse events, keyboard events, and sizing events; to handle them, a - programmer must derive a new class from the built-in + mouse events, keyboard events, and sizing events; to handle them, + derive a new class from the built-in @scheme[canvas%] class and override the event-handling methods. The following expression extends the frame created above with a canvas that handles mouse and keyboard events: @@ -86,10 +94,10 @@ After running the above code, manually resize the frame to see the on-event]. While the canvas has the keyboard focus, typing on the keyboard invokes the canvas's @method[canvas<%> on-char] method. -The system dispatches GUI events sequentially; that is, after invoking - an event-handling callback or method, the system waits until the +The windowing system dispatches GUI events sequentially; that is, after invoking + an event-handling callback or method, the windowing system waits until the handler returns before dispatching the next event. To illustrate the - sequential nature of events, we extend the frame again, adding a + sequential nature of events, extend the frame again, adding a @onscreen{Pause} button: @schemeblock[ @@ -99,7 +107,7 @@ The system dispatches GUI events sequentially; that is, after invoking ] After the user clicks @onscreen{Pause}, the entire frame becomes - unresponsive for five seconds; the system cannot dispatch more events + unresponsive for five seconds; the windowing system cannot dispatch more events until the call to @scheme[sleep] returns. For more information about event dispatching, see @secref["eventspaceinfo"]. @@ -111,7 +119,7 @@ In addition to dispatching events, the GUI classes also handle the as a frame, arranges its children in a column, and a horizontal container arranges its children in a row. A container can be a child of another container; for example, to place two buttons side-by-side - in our frame, we create a horizontal panel for the new buttons: + in our frame, create a horizontal panel for the new buttons: @schemeblock[ (define panel (new horizontal-panel% [parent frame])) @@ -128,6 +136,49 @@ In addition to dispatching events, the GUI classes also handle the For more information about window layout and containers, see @secref["containeroverview"]. + +@section[#:tag "canvas-drawing"]{Drawing in Canvases} + +The content of a canvas is determined by its @method[canvas% on-paint] +method, where the default @method[canvas% on-paint] calls the +@racket[paint-callback] function that is supplied when the canvas is +created. The @method[canvas% on-paint] method receives no arguments +and uses the canvas's @method[canvas<%> get-dc] method to obtain a +@tech[#:doc '(lib "scribblings/draw/draw.scrbl")]{drawing context} +(DC) for drawing; the default @method[canvas% on-paint] method passes +the canvas and this DC on to the @racket[paint-callback] function. +Drawing operations of the @racket[racket/draw] toolbox on the DC are +reflected in the content of the canvas onscreen. + +For example, the following program creates a canvas +that displays large, friendly letters: + +@schemeblock[ +(define frame (new frame% + [label "Example"] + [width 300] + [height 300])) +(new canvas% [parent frame] + [paint-callback + (lambda (canvas dc) + (send dc #,(:: dc<%> set-scale) 3 3) + (send dc #,(:: dc<%> set-text-foreground) "blue") + (send dc #,(:: dc<%> draw-text) "Don't Panic!" 0 0))]) +(send frame #,(:: top-level-window<%> show) #t) +] + +The background color of a canvas can be set through the +@method[canvas<%> set-canvas-background] method. To make the canvas +transparent (so that it takes on its parent's color and texture as its +initial content), supply @racket['transparent] in the @racket[style] +argument when creating the canvas. + +See @secref["overview" #:doc '(lib "scribblings/draw/draw.scrbl")] in +@other-doc['(lib "scribblings/draw/draw.scrbl")] for an overview of +drawing with the @racket[racket/draw] library. For more advanced +information on canvas drawing, see @secref["animation"]. + + @section{Core Windowing Classes} The fundamental graphical element in the windowing toolbox is an @@ -328,7 +379,7 @@ The built-in container classes include horizontal panels (and panes), which align their children in a row, and vertical panels (and panes), which align their children in a column. By nesting horizontal and vertical containers, a programmer can achieve most any layout. For - example, we can construct a dialog with the following shape: + example, to construct a dialog with the shape @verbatim[#:indent 2]{ ------------------------------------------------------ @@ -654,10 +705,9 @@ Whenever the user moves the mouse, clicks or releases a mouse button, target window. A program can use the @method[window<%> focus] method to move the focus to a subwindow or to set the initial focus. - Under X, a @indexed-scheme['wheel-up] or @indexed-scheme['wheel-down] + A @indexed-scheme['wheel-up] or @indexed-scheme['wheel-down] event may be sent to a window other than the one with the keyboard - focus, because X generates wheel events based on the location of the - mouse pointer. + focus, depending on how the operating system handles wheel events. A key-press event may correspond to either an actual key press or an auto-key repeat. Multiple key-press events without intervening @@ -942,3 +992,34 @@ This expression installs an exception handler that prints an error handler during the call to @scheme[yield], an error message is printed before control returns to the event dispatcher within @scheme[yield]. + + +@section[#:tag "animation"]{Animation in Canvases} + +The content of a canvas is buffered, so if a canvas must be redrawn, +the @method[canvas% on-paint] method or @racket[paint-callback] function +usually does not need to be called again. To further reduce flicker, +while the @method[canvas% on-paint] method or @racket[paint-callback] function +is called, the windowing system avoids flushing the canvas-content +buffer to the screen. + +Canvas content can be updated at any time by drawing with the result +of the canvas's @method[canvas<%> get-dc] method, and drawing is +thread-safe. Changes to the canvas's content are flushed to the screen +periodically (not necessarily on an event-handling boundary), but the +@method[canvas<%> flush] method immediately flushes to the screen---as +long as flushing has not been suspended. The @method[canvas<%> +suspend-flush] and @method[canvas<%> resume-flush] methods suspend and +resume both automatic and explicit flushes, although on some +platforms, automatic flushes are forced in rare cases. + +For most animation purposes, @method[canvas<%> suspend-flush], +@method[canvas<%> resume-flush], and @method[canvas<%> flush] can be +used to avoid flicker and the need for an additional drawing buffer +for animations. During an animation, bracket the construction of each +animation frame with @method[canvas<%> suspend-flush] and +@method[canvas<%> resume-flush] to ensure that partially drawn frames +are not flushed to the screen. Use @method[canvas<%> flush] to ensure +that canvas content is flushed when it is ready if a @method[canvas<%> +suspend-flush] will soon follow, because the process of flushing to +the screen can be starved if flushing is frequently suspend. From de775e6dc19511017a8991425e5e8f8cc2555bc5 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Sun, 28 Nov 2010 06:39:55 -0600 Subject: [PATCH 175/255] Fixes bug in typesetting tests --- collects/redex/tests/bitmap-test-util.rkt | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/redex/tests/bitmap-test-util.rkt b/collects/redex/tests/bitmap-test-util.rkt index 943bdbb9a9..f717586c9b 100644 --- a/collects/redex/tests/bitmap-test-util.rkt +++ b/collects/redex/tests/bitmap-test-util.rkt @@ -92,10 +92,10 @@ (let loop ([y 0]) (unless (= y h) (cond - [(and (<= x (send new-bitmap get-width)) - (<= y (send new-bitmap get-height)) - (<= x (send old-bitmap get-width)) - (<= y (send old-bitmap get-height))) + [(and (< x (send new-bitmap get-width)) + (< y (send new-bitmap get-height)) + (< x (send old-bitmap get-width)) + (< y (send old-bitmap get-height))) (send new get-pixel x y new-c) (send old get-pixel x y old-c) (cond From 805a4a66c94f45438ffe8dc45ef02e1a25553031 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Sun, 28 Nov 2010 06:40:53 -0600 Subject: [PATCH 176/255] Increases timeout for redex/examples/delim-cont/randomized-tests-test.rkt --- collects/meta/props | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/meta/props b/collects/meta/props index 9677c869e6..5a1bd9abe7 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1198,7 +1198,7 @@ path/s is either such a string or a list of them. "collects/redex/examples/church.rkt" drdr:command-line (mzc *) "collects/redex/examples/combinators.rkt" drdr:command-line (mzc *) "collects/redex/examples/compatible-closure.rkt" drdr:command-line (mzc *) -"collects/redex/examples/delim-cont/randomized-tests-test.rkt" drdr:timeout 120 drdr:random #t +"collects/redex/examples/delim-cont/randomized-tests-test.rkt" drdr:timeout 180 drdr:random #t "collects/redex/examples/delim-cont/randomized-tests.rkt" drdr:random #t "collects/redex/examples/delim-cont/test.rkt" drdr:command-line (mzc *) "collects/redex/examples/letrec.rkt" drdr:command-line (mzc *) From f88735ef20e1dfb8c1cb46984a2936f9bdfe2c12 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 27 Nov 2010 20:19:11 -0700 Subject: [PATCH 177/255] fix typo --- collects/scribblings/gui/gui.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/gui/gui.scrbl b/collects/scribblings/gui/gui.scrbl index fe6050f7a0..b51741fe77 100644 --- a/collects/scribblings/gui/gui.scrbl +++ b/collects/scribblings/gui/gui.scrbl @@ -17,7 +17,7 @@ to the bindings of @racketmodname[racket/draw].} @racketmodname[racket] language and the @racketmodname[racket/gui/base] and @racketmodname[racket/draw] modules.} -The @racketmodname[racket/draw] toolbox is roughly organized into two +The @racketmodname[racket/gui] toolbox is roughly organized into two parts: @itemize[ From cc82d3728525b5bac3f2cb91d249d5404a7a3bd0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 28 Nov 2010 07:46:23 -0700 Subject: [PATCH 178/255] Scribble Latex image support (missed an earlier commit) --- collects/scribble/latex-render.rkt | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/collects/scribble/latex-render.rkt b/collects/scribble/latex-render.rkt index 7fa0e56b98..d722697d9f 100644 --- a/collects/scribble/latex-render.rkt +++ b/collects/scribble/latex-render.rkt @@ -249,15 +249,13 @@ (image-element-scale e) fn))] [(and (convertible? e) (not (disable-images)) - (convert e 'pdf-bytes)) - => (lambda (bstr) - (let ([fn (install-file "pict.pdf" bstr)]) - (printf "\\includegraphics{~a}" fn)))] - [(and (convertible? e) - (not (disable-images)) - (convert e 'png-bytes)) - => (lambda (bstr) - (let ([fn (install-file "pict.png" bstr)]) + (let ([ftag (lambda (v suffix) (and v (list v suffix)))]) + (or (ftag (convert e 'pdf-bytes) ".pdf") + (ftag (convert e 'eps-bytes) ".ps") + (ftag (convert e 'png-bytes) ".png")))) + => (lambda (bstr+suffix) + (let ([fn (install-file (format "pict.~a" (cadr bstr+suffix)) + (car bstr+suffix))]) (printf "\\includegraphics{~a}" fn)))] [else (parameterize ([rendering-tt (or tt? (rendering-tt))]) From 262531e23121a4a11b5e683923a961712d003b10 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 28 Nov 2010 07:46:36 -0700 Subject: [PATCH 179/255] cocoa: fix enable & disable of windows --- collects/mred/private/wx/cocoa/canvas.rkt | 14 +++++++++++++- collects/mred/private/wx/cocoa/frame.rkt | 7 ++++++- collects/mred/private/wx/cocoa/item.rkt | 10 +++++----- collects/mred/private/wx/cocoa/panel.rkt | 8 +++++++- collects/mred/private/wx/cocoa/tab-panel.rkt | 16 +++++++++++++++- collects/mred/private/wx/cocoa/window.rkt | 16 ++++++++++++---- 6 files changed, 58 insertions(+), 13 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 34f80512e4..551eed0d95 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -234,6 +234,9 @@ make-graphics-context is-shown-to-root? is-shown-to-before-root? + is-enabled-to-root? + is-window-enabled? + block-mouse-events move get-x get-y on-size register-as-child @@ -608,6 +611,15 @@ (scroller-page scroller) 1)])) + (define/override (enable-window on?) + (let ([on? (and on? (is-window-enabled?))]) + (let ([w (tell content-cocoa window)]) + (when (ptr-equal? content-cocoa (tell w firstResponder)) + (tellv w makeFirstResponder: #f))) + (block-mouse-events (not on?)) + (when is-combo? + (tellv content-cocoa setEnabled: #:type _BOOL on?)))) + (define/public (clear-combo-items) (tellv content-cocoa removeAllItems)) (define/public (append-combo-item str) @@ -698,7 +710,7 @@ (define/override (gets-focus?) wants-focus?) (define/override (can-be-responder?) - wants-focus?) + (and wants-focus? (is-enabled-to-root?))) (define/private (on-menu-click? e) ;; Called in Cocoa event-handling mode diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index eb2053c75c..ffe008e466 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -141,7 +141,8 @@ get-eventspace pre-on-char pre-on-event get-x - on-new-child) + on-new-child + is-window-enabled?) (super-new [parent parent] [cocoa @@ -333,6 +334,10 @@ (when saved-child (send saved-child child-accept-drag on?))) + (define/override (enable-window on?) + (when saved-child + (send saved-child enable-window (and on? (is-window-enabled?))))) + (define/override (is-shown?) (tell #:type _bool cocoa isVisible)) diff --git a/collects/mred/private/wx/cocoa/item.rkt b/collects/mred/private/wx/cocoa/item.rkt index e04a375195..2ff73fa109 100644 --- a/collects/mred/private/wx/cocoa/item.rkt +++ b/collects/mred/private/wx/cocoa/item.rkt @@ -29,16 +29,16 @@ (tellv cocoa setFont: sys-font))) (defclass item% window% - (inherit get-cocoa) + (inherit get-cocoa + is-window-enabled?) (init-field callback) (define/public (get-cocoa-control) (get-cocoa)) - (define/override (enable on?) - (tellv (get-cocoa-control) setEnabled: #:type _BOOL on?)) - (define/override (is-window-enabled?) - (tell #:type _BOOL (get-cocoa-control) isEnabled)) + (define/override (enable-window on?) + (let ([on? (and on? (is-window-enabled?))]) + (tellv (get-cocoa-control) setEnabled: #:type _BOOL on?))) (define/override (gets-focus?) (tell #:type _BOOL (get-cocoa-control) canBecomeKeyView)) diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt index 6d57fecc04..85864672ae 100644 --- a/collects/mred/private/wx/cocoa/panel.rkt +++ b/collects/mred/private/wx/cocoa/panel.rkt @@ -19,7 +19,8 @@ (define (panel-mixin %) (class % - (inherit register-as-child on-new-child) + (inherit register-as-child on-new-child + is-window-enabled?) (define lbl-pos 'horizontal) (define children null) @@ -52,6 +53,11 @@ (define/override (children-accept-drag on?) (for ([child (in-list children)]) (send child child-accept-drag on?))) + + (define/override (enable-window on?) + (let ([on? (and on? (is-window-enabled?))]) + (for ([child (in-list children)]) + (send child enable-window on?)))) (define/override (set-size x y w h) (super set-size x y w h) diff --git a/collects/mred/private/wx/cocoa/tab-panel.rkt b/collects/mred/private/wx/cocoa/tab-panel.rkt index d67e669e69..6b11d595df 100644 --- a/collects/mred/private/wx/cocoa/tab-panel.rkt +++ b/collects/mred/private/wx/cocoa/tab-panel.rkt @@ -23,6 +23,9 @@ (void (ffi-lib (build-path psm-tab-bar-dir "PSMTabBarControl"))) (define NSNoTabsNoBorder 6) +(define NSDefaultControlTint 0) +(define NSClearControlTint 7) + (import-class NSView NSTabView NSTabViewItem PSMTabBarControl) (import-protocol NSTabViewDelegate) @@ -44,7 +47,9 @@ x y w h style labels) - (inherit get-cocoa register-as-child) + (inherit get-cocoa register-as-child + is-window-enabled? + block-mouse-events) (define tabv-cocoa (as-objc-allocation (tell (tell MyTabView alloc) init))) @@ -154,6 +159,15 @@ (when control-cocoa (set-ivar! control-cocoa wxb (->wxb this))) + (define/override (enable-window on?) + (super enable-window on?) + (let ([on? (and on? (is-window-enabled?))]) + (block-mouse-events (not on?)) + (tellv tabv-cocoa setControlTint: #:type _int + (if on? NSDefaultControlTint NSClearControlTint)) + (when control-cocoa + (tellv control-cocoa setEnabled: #:type _BOOL on?)))) + (define/override (maybe-register-as-child parent on?) (register-as-child parent on?))) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 11ae6cda57..0c37a04e5f 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -520,7 +520,14 @@ (define/public (is-window-enabled?) enabled?) (define/public (enable on?) - (set! enabled? on?)) + (set! enabled? on?) + (enable-window on?)) + (define/public (enable-window on?) + (void)) + + (define block-all-mouse-events? #f) + (define/public (block-mouse-events block?) + (set! block-all-mouse-events? block?)) (define/private (get-frame) (let ([v (tell #:type _NSRect cocoa frame)]) @@ -621,7 +628,8 @@ (accept-drags-everywhere (or accept-drag? accept-parent-drag?)))) (define/public (set-focus) - (when (gets-focus?) + (when (and (gets-focus?) + (is-enabled-to-root?)) (let ([w (tell cocoa window)]) (when w (tellv w makeFirstResponder: (get-cocoa-content)))))) @@ -664,7 +672,7 @@ (cond [(other-modal? this) #t] [(call-pre-on-event this e) #t] - [just-pre? #f] + [just-pre? block-all-mouse-events?] [else (when enabled? (on-event e)) #t])) (define/public (call-pre-on-event w e) @@ -773,7 +781,7 @@ (define/public (get-cursor-width-delta) 0) (define/public (gets-focus?) #f) - (define/public (can-be-responder?) #t) + (define/public (can-be-responder?) (is-enabled-to-root?)) (define/public (on-color-change) (send parent on-color-change)) From f090e732fd8fb63f92dfb30391c9bd8d3910c281 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 28 Nov 2010 07:52:01 -0700 Subject: [PATCH 180/255] cocoa: fix relabel of image checkbox --- collects/mred/private/wx/cocoa/button.rkt | 73 ++++++++++++----------- 1 file changed, 37 insertions(+), 36 deletions(-) diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt index 94cf0f6a72..1987e278ee 100644 --- a/collects/mred/private/wx/cocoa/button.rkt +++ b/collects/mred/private/wx/cocoa/button.rkt @@ -87,41 +87,42 @@ (NSSize-height (NSRect-size frame))))))) cocoa)) - (define cocoa (if (and button-type - (not (string? label)) - (send label ok?)) - ;; Check-box image: need an view to join a button and an image view: - ;; (Could we use the NSImageButtonCell from the radio-box implementation - ;; instead?) - (let* ([frame (tell #:type _NSRect button-cocoa frame)] - [new-width (+ (NSSize-width (NSRect-size frame)) - (send label get-width))] - [new-height (max (NSSize-height (NSRect-size frame)) - (send label get-height))]) - (let ([cocoa (as-objc-allocation - (tell (tell NSView alloc) - initWithFrame: #:type _NSRect - (make-NSRect (NSRect-origin frame) - (make-NSSize new-width - new-height))))] - [image-cocoa (as-objc-allocation - (tell (tell NSImageView alloc) init))]) - (tellv cocoa addSubview: button-cocoa) - (tellv cocoa addSubview: image-cocoa) - (tellv image-cocoa setImage: (bitmap->image label)) - (tellv image-cocoa setFrame: #:type _NSRect - (make-NSRect (make-NSPoint (NSSize-width (NSRect-size frame)) - (quotient (- new-height - (send label get-height)) - 2)) - (make-NSSize (send label get-width) - (send label get-height)))) - (tellv button-cocoa setFrame: #:type _NSRect - (make-NSRect (make-NSPoint 0 0) - (make-NSSize new-width new-height))) - (set-ivar! button-cocoa wxb (->wxb this)) - cocoa)) - button-cocoa)) + (define-values (cocoa image-cocoa) + (if (and button-type + (not (string? label)) + (send label ok?)) + ;; Check-box image: need an view to join a button and an image view: + ;; (Could we use the NSImageButtonCell from the radio-box implementation + ;; instead?) + (let* ([frame (tell #:type _NSRect button-cocoa frame)] + [new-width (+ (NSSize-width (NSRect-size frame)) + (send label get-width))] + [new-height (max (NSSize-height (NSRect-size frame)) + (send label get-height))]) + (let ([cocoa (as-objc-allocation + (tell (tell NSView alloc) + initWithFrame: #:type _NSRect + (make-NSRect (NSRect-origin frame) + (make-NSSize new-width + new-height))))] + [image-cocoa (as-objc-allocation + (tell (tell NSImageView alloc) init))]) + (tellv cocoa addSubview: button-cocoa) + (tellv cocoa addSubview: image-cocoa) + (tellv image-cocoa setImage: (bitmap->image label)) + (tellv image-cocoa setFrame: #:type _NSRect + (make-NSRect (make-NSPoint (NSSize-width (NSRect-size frame)) + (quotient (- new-height + (send label get-height)) + 2)) + (make-NSSize (send label get-width) + (send label get-height)))) + (tellv button-cocoa setFrame: #:type _NSRect + (make-NSRect (make-NSPoint 0 0) + (make-NSSize new-width new-height))) + (set-ivar! button-cocoa wxb (->wxb this)) + (values cocoa image-cocoa))) + (values button-cocoa #f))) (define we (make-will-executor)) @@ -146,7 +147,7 @@ [(string? label) (tellv cocoa setTitleWithMnemonic: #:type _NSString label)] [else - (tellv cocoa setImage: (bitmap->image label))])) + (tellv (or image-cocoa cocoa) setImage: (bitmap->image label))])) (define callback cb) (define/public (clicked) From 36669b821a350a5f8efb466bb3f6b13c0feb73c4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 28 Nov 2010 07:56:33 -0700 Subject: [PATCH 181/255] re-fix Scribble Latex image support --- collects/scribble/latex-render.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribble/latex-render.rkt b/collects/scribble/latex-render.rkt index d722697d9f..e1f006bb00 100644 --- a/collects/scribble/latex-render.rkt +++ b/collects/scribble/latex-render.rkt @@ -254,7 +254,7 @@ (ftag (convert e 'eps-bytes) ".ps") (ftag (convert e 'png-bytes) ".png")))) => (lambda (bstr+suffix) - (let ([fn (install-file (format "pict.~a" (cadr bstr+suffix)) + (let ([fn (install-file (format "pict~a" (cadr bstr+suffix)) (car bstr+suffix))]) (printf "\\includegraphics{~a}" fn)))] [else From d37cc7b3ec702c9d89a6fc3a18f65c873fdd2c11 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 28 Nov 2010 10:41:59 -0700 Subject: [PATCH 182/255] cocoa: fix problem with tab panel --- collects/mred/private/wx/cocoa/tab-panel.rkt | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/collects/mred/private/wx/cocoa/tab-panel.rkt b/collects/mred/private/wx/cocoa/tab-panel.rkt index 6b11d595df..5b5b220597 100644 --- a/collects/mred/private/wx/cocoa/tab-panel.rkt +++ b/collects/mred/private/wx/cocoa/tab-panel.rkt @@ -29,6 +29,17 @@ (import-class NSView NSTabView NSTabViewItem PSMTabBarControl) (import-protocol NSTabViewDelegate) +(define NSOrderedAscending -1) +(define NSOrderedSame 0) +(define NSOrderedDescending 1) +(define (order-content-first a b data) + (cond + [(ptr-equal? a data) NSOrderedDescending] + [(ptr-equal? b data) NSOrderedAscending] + [else NSOrderedSame])) +(define order_content_first (function-ptr order-content-first + (_fun #:atomic? #t _id _id _id -> _int))) + (define-objc-class MyTabView NSTabView #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) [wxb] @@ -131,7 +142,11 @@ (tell (tell NSTabViewItem alloc) initWithIdentifier: #f))]) (tellv item setLabel: #:type _NSString (label->plain-label lbl)) (tellv tabv-cocoa addTabViewItem: item) - (set! item-cocoas (append item-cocoas (list item))))) + (set! item-cocoas (append item-cocoas (list item))) + ;; Sometimes the sub-view for the tab buttons gets put in front + ;; of the content view, so fix the order: + (tellv tabv-cocoa sortSubviewsUsingFunction: #:type _fpointer order_content_first + context: #:type _pointer content-cocoa))) (define/public (delete i) (let ([item-cocoa (list-ref item-cocoas i)]) From 2282cae59ab233d9f054bb87d1eefb72f82a74ac Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 28 Nov 2010 09:21:16 -0700 Subject: [PATCH 183/255] cocoa: fix removal of menu shortcut Closes PR 11463 --- collects/mred/private/wx/cocoa/menu-item.rkt | 37 ++++++++++---------- 1 file changed, 19 insertions(+), 18 deletions(-) diff --git a/collects/mred/private/wx/cocoa/menu-item.rkt b/collects/mred/private/wx/cocoa/menu-item.rkt index 6f26da2455..bea50304ee 100644 --- a/collects/mred/private/wx/cocoa/menu-item.rkt +++ b/collects/mred/private/wx/cocoa/menu-item.rkt @@ -80,21 +80,22 @@ (define (set-menu-item-shortcut item label) (let ([shortcut (regexp-match #rx"\tCut=(.)(.*)" label)]) - (when shortcut - (let* ([s (string-downcase (string (integer->char (string->number (caddr shortcut)))))] - [flags (- (char->integer (string-ref (cadr shortcut) 0)) - (char->integer #\A))] - [mods (+ (if (positive? (bitwise-and flags 1)) - NSShiftKeyMask - 0) - (if (positive? (bitwise-and flags 2)) - NSAlternateKeyMask - 0) - (if (positive? (bitwise-and flags 4)) - NSControlKeyMask - 0) - (if (positive? (bitwise-and flags 8)) - 0 - NSCommandKeyMask))]) - (tellv item setKeyEquivalent: #:type _NSString s) - (tellv item setKeyEquivalentModifierMask: #:type _NSUInteger mods))))) + (if shortcut + (let* ([s (string-downcase (string (integer->char (string->number (caddr shortcut)))))] + [flags (- (char->integer (string-ref (cadr shortcut) 0)) + (char->integer #\A))] + [mods (+ (if (positive? (bitwise-and flags 1)) + NSShiftKeyMask + 0) + (if (positive? (bitwise-and flags 2)) + NSAlternateKeyMask + 0) + (if (positive? (bitwise-and flags 4)) + NSControlKeyMask + 0) + (if (positive? (bitwise-and flags 8)) + 0 + NSCommandKeyMask))]) + (tellv item setKeyEquivalent: #:type _NSString s) + (tellv item setKeyEquivalentModifierMask: #:type _NSUInteger mods)) + (tellv item setKeyEquivalent: #:type _NSString "")))) From d879f751528abc68ceb3740dfc8e7ac648b1edc8 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 28 Nov 2010 15:24:49 -0600 Subject: [PATCH 184/255] adjusted the registration mechanism for planet-terse-register to be clearer and simpler --- collects/planet/planet.scrbl | 33 +++++++++++++++++---------------- collects/planet/terse-info.rkt | 34 ++++++++++++++++------------------ 2 files changed, 33 insertions(+), 34 deletions(-) diff --git a/collects/planet/planet.scrbl b/collects/planet/planet.scrbl index fd3c4fee09..59d31e9fe8 100644 --- a/collects/planet/planet.scrbl +++ b/collects/planet/planet.scrbl @@ -736,30 +736,31 @@ namespace-specific. @defproc[(planet-terse-register [proc (-> (or/c 'download 'install 'docs-build 'finish) string? - any/c)] - [key symbol? (planet-terse-log-key-param)]) + any/c)]) void?]{ Registers @racket[proc] as a function to be called when -@racket[planet-terse-log] is called with a matching namespace argument. - Note that @racket[proc] is called +@racket[planet-terse-log] is called. + +Note that @racket[proc] is called asynchronously (ie, on some thread other than the one calling @racket[planet-terse-register]). } @defproc[(planet-terse-log [id (or/c 'download 'install 'finish)] - [msg string?] - [key symbol? (planet-terse-log-key-param)]) void?]{ -This function is called by PLaneT to announce when things are happening. -The namespace passed along is used to identify the procs to notify. This function -invokes all of the callbacks registered with @racket[key], and when PLaneT invokes it, -the @racket[key] argument is always @racket[(planet-terse-log-key-param)]. + [msg string?]) void?]{ +This function is called by PLaneT to announce when things are happening. See also +@racket[planet-terse-set-key]. } -@defparam[planet-terse-log-key-param key symbol?]{ - Holds the current value of the key used for getting and setting the @PLaneT logging information. -} - -@defproc[(planet-terse-set-key [key symbol?]) void?]{ - Equivalent to @racket[(planet-terse-log-key-param new-key)]. +@defproc[(planet-terse-set-key [key any/c]) void?]{ + This sets a @seclink["threadcells" #:doc '(lib "scribblings/reference/reference.scrbl")]{thread cell} + to the value of @racket[key]. + The value of the thread cell is used as an index into a table to determine which + of the functions passed to @racket[planet-terse-register] to call when + @racket[planet-terse-log] is called. + + The table holding the key uses ephemerons and a weak hash table to ensure that + when the @racket[key] is unreachable, then the procedures passed to @racket[planet-terse-log] + cannot be reached through the table. } @section{Developing Packages for PLaneT} diff --git a/collects/planet/terse-info.rkt b/collects/planet/terse-info.rkt index 51519fb078..c4d256ae9a 100644 --- a/collects/planet/terse-info.rkt +++ b/collects/planet/terse-info.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base #| @@ -14,12 +14,11 @@ seems little point to that). (provide planet-terse-register planet-terse-log - planet-terse-set-key - planet-terse-log-key-param) + planet-terse-set-key) (define terse-log-message-chan (make-channel)) (define terse-log-proc-chan (make-channel)) -(define planet-terse-log-key-param (make-parameter (gensym))) +(define log-key-tc (make-thread-cell (gensym) #t)) (define thd (thread @@ -33,30 +32,29 @@ seems little point to that). (let ([registry (list-ref msg 0)] [id (list-ref msg 1)] [str (list-ref msg 2)]) - (for-each (lambda (eph) - (let ([proc (weak-box-value eph)]) - (when proc - (proc id str)))) - (hash-ref procs registry '()))) + (for ([eph (in-list (hash-ref procs registry '()))]) + (let ([proc (ephemeron-value eph)]) + (when proc + (proc id str))))) (loop))) (handle-evt terse-log-proc-chan (lambda (rp) - (let ([registry (list-ref rp 0)] - [proc (list-ref rp 1)]) + (let* ([registry (list-ref rp 0)] + [proc (list-ref rp 1)]) (hash-update! procs registry - (lambda (x) (cons (make-weak-box proc) x)) + (lambda (x) (cons (make-ephemeron registry proc) x)) '()) (loop)))))))))) -(define (planet-terse-log id str [key (planet-terse-log-key-param)]) - (sync (channel-put-evt terse-log-message-chan (list key id str))) +(define (planet-terse-log id str) + (sync (channel-put-evt terse-log-message-chan (list (thread-cell-ref log-key-tc) id str))) (void)) - -(define (planet-terse-register proc [key (planet-terse-log-key-param)]) - (sync (channel-put-evt terse-log-proc-chan (list key proc))) + +(define (planet-terse-register proc) + (sync (channel-put-evt terse-log-proc-chan (list (thread-cell-ref log-key-tc) proc))) (void)) (define (planet-terse-set-key new-key) - (planet-terse-log-key-param new-key)) + (thread-cell-set! log-key-tc new-key)) From c123a8cc5d306e5d6aa4bf70317f1c7d1c7ae489 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 28 Nov 2010 15:46:22 -0600 Subject: [PATCH 185/255] fixed a bug that caused a leak that held onto drracket frames. The bug was that the planet log message registration was happening on drracket's thread instead of on the user's thread, so it was using the wrong keys in the ephemerons. --- collects/drracket/private/rep.rkt | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/collects/drracket/private/rep.rkt b/collects/drracket/private/rep.rkt index 4c4fedc842..ccc32f1945 100644 --- a/collects/drracket/private/rep.rkt +++ b/collects/drracket/private/rep.rkt @@ -1320,15 +1320,17 @@ TODO (initialize-parameters snip-classes)))) - ;; register drscheme with the planet-terse-register for the user's namespace - ;; must be called after 'initialize-parameters' is called (since it initializes - ;; the user's namespace) - (planet-terse-set-key (gensym)) - (planet-terse-register - (lambda (tag package) - (parameterize ([current-eventspace drracket:init:system-eventspace]) - (queue-callback (λ () (new-planet-info tag package)))))) - + (queue-user/wait + (λ () + ;; register drscheme with the planet-terse-register for the user's namespace + ;; must be called after 'initialize-parameters' is called (since it initializes + ;; the user's namespace) + (planet-terse-set-key (namespace-module-registry (current-namespace))) + (planet-terse-register + (lambda (tag package) + (parameterize ([current-eventspace drracket:init:system-eventspace]) + (queue-callback (λ () (new-planet-info tag package)))))))) + ;; disable breaks until an evaluation actually occurs (send context set-breakables #f #f) From 62f3d7e254c99b20bb93dbacb4538e3e1d05535a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 28 Nov 2010 16:04:13 -0600 Subject: [PATCH 186/255] tried to clarify the ephemeron docs by setting the stage for the precise definition that was already there a little bit. --- collects/scribblings/reference/memory.scrbl | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/collects/scribblings/reference/memory.scrbl b/collects/scribblings/reference/memory.scrbl index bfd2496cc4..3088f51fff 100644 --- a/collects/scribblings/reference/memory.scrbl +++ b/collects/scribblings/reference/memory.scrbl @@ -37,13 +37,20 @@ Returns @racket[#t] if @racket[v] is a weak box, @racket[#f] otherwise.} @;------------------------------------------------------------------------ @section[#:tag "ephemerons"]{Ephemerons} -An @deftech{ephemeron} is similar to a weak box (see -@secref["weakbox"]), except that +An @deftech{ephemeron} is a generalization of a weak box (see +@secref["weakbox"]). Instead of just containing one value, it holds two, +the value of the ephemeron, plus a key. Like a weak box, the +value in the ephemeron may be replaced by @racket[#f], but it does +this when the key is no longer reachable. In addition, the memory +manager specially treats links from the value to the key. +A weak box can be seen as a specialization of an ephemeron where +the key and value are the same. + +More precisely, @itemize[ - @item{an ephemeron contains a key and a value; the value can be - extracted from the ephemeron, but the value is replaced + @item{the value in an ephemeron is replaced by @racket[#f] when the automatic memory manager can prove that either the ephemeron or the key is reachable only through weak references (see @secref["weakbox"]); and} @@ -57,7 +64,7 @@ An @deftech{ephemeron} is similar to a weak box (see ] -In particular, an ephemeron can be combined with a weak hash table +On particularly common use of ephemerons is to combined them with a weak hash table (see @secref["hashtables"]) to produce a mapping where the memory manager can reclaim key--value pairs even when the value refers to the key. From eabbb7dff25fa1a0e76c15661e6a8153ea7c5509 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 28 Nov 2010 19:26:38 -0600 Subject: [PATCH 187/255] improve the leak test a little by looking to see tabs get gc'd and so do the user's namespaces. --- collects/tests/drracket/leaky-frame.rkt | 32 +++++++++++++++++++++---- 1 file changed, 28 insertions(+), 4 deletions(-) diff --git a/collects/tests/drracket/leaky-frame.rkt b/collects/tests/drracket/leaky-frame.rkt index e208572bd0..6faa4882c6 100644 --- a/collects/tests/drracket/leaky-frame.rkt +++ b/collects/tests/drracket/leaky-frame.rkt @@ -7,17 +7,41 @@ (λ () (define drs-frame1 (wait-for-drscheme-frame)) (sync (system-idle-evt)) - (test:menu-select "File" "New") - (define drs-frame2b (make-weak-box (wait-for-new-frame drs-frame1))) + + (test:menu-select "File" "New Tab") (sync (system-idle-evt)) + + (define drs-tabb (make-weak-box (send drs-frame1 get-current-tab))) + (define tab-nsb (make-weak-box (send (send (send drs-frame1 get-current-tab) get-ints) get-user-namespace))) + + (test:menu-select "File" "Close Tab") + (sync (system-idle-evt)) + + (test:menu-select "File" "New") + (sync (system-idle-evt)) + + (define drs-frame2b (make-weak-box (wait-for-new-frame drs-frame1))) + (define frame2-nsb (make-weak-box (send (send (send (weak-box-value drs-frame2b) get-current-tab) get-ints) get-user-namespace))) + (test:menu-select "File" "Close") (sync (system-idle-evt)) + (let loop ([n 30]) (cond [(zero? n) + (when (weak-box-value drs-tabb) + (fprintf (current-error-port) "frame leak!\n")) (when (weak-box-value drs-frame2b) - (fprintf (current-error-port) "leak!\n"))] + (fprintf (current-error-port) "tab leak!\n")) + (when (weak-box-value tab-nsb) + (fprintf (current-error-port) "tab namespace leak!\n")) + (when (weak-box-value frame2-nsb) + (fprintf (current-error-port) "frame namespace leak!\n"))] [else (collect-garbage) - (when (weak-box-value drs-frame2b) + (when (ormap weak-box-value + (list drs-tabb + tab-nsb + drs-frame2b + frame2-nsb)) (loop (- n 1)))]))))) From 46244f81fc4f86a7ea2514dddd006dc848d56cd9 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Sun, 28 Nov 2010 23:07:51 -0700 Subject: [PATCH 188/255] make set-union with 0 args return an empty set --- collects/racket/set.rkt | 1 + collects/tests/racket/set.rktl | 2 ++ 2 files changed, 3 insertions(+) diff --git a/collects/racket/set.rkt b/collects/racket/set.rkt index 4da3d4b8fa..0294a33570 100644 --- a/collects/racket/set.rkt +++ b/collects/racket/set.rkt @@ -111,6 +111,7 @@ (define set-union (case-lambda + [() (set)] [(set) (unless (set? set) (raise-type-error 'set-union "set" 0 set)) set] diff --git a/collects/tests/racket/set.rktl b/collects/tests/racket/set.rktl index bb91761c34..e8bd33675a 100644 --- a/collects/tests/racket/set.rktl +++ b/collects/tests/racket/set.rktl @@ -17,6 +17,8 @@ (test #t set-empty? (seteqv)) (test #t set? (seteqv 1 2 3)) (test #f set-empty? (seteqv 1 2 3)) +(test #t set? (set-union)) +(test #t set-empty? (set-union)) (test #f set-eq? (set 1 2 3)) (test #f set-eqv? (set 1 2 3)) From cf3b9680ba6725fd358ca2bf5f1b42d0e6f20a2a Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Mon, 29 Nov 2010 00:34:57 -0700 Subject: [PATCH 189/255] remove 0 arg set-union. add workaround to docs --- collects/racket/set.rkt | 7 ++++++- collects/scribblings/reference/sets.scrbl | 20 +++++++++++++++++++- collects/tests/racket/set.rktl | 2 -- 3 files changed, 25 insertions(+), 4 deletions(-) diff --git a/collects/racket/set.rkt b/collects/racket/set.rkt index 0294a33570..db396d8b6b 100644 --- a/collects/racket/set.rkt +++ b/collects/racket/set.rkt @@ -111,7 +111,12 @@ (define set-union (case-lambda - [() (set)] + ;; No 0 argument set exists because its not clear what type of set + ;; to return. A keyword is unsatisfactory because it may be hard to + ;; remember. A simple solution is just to provide the type of the + ;; empty set that you want, like (set-union (set)) or + ;; (set-union (set-eqv)) + ;; [() (set)] [(set) (unless (set? set) (raise-type-error 'set-union "set" 0 set)) set] diff --git a/collects/scribblings/reference/sets.scrbl b/collects/scribblings/reference/sets.scrbl index 794b405d1f..8ec10d98fe 100644 --- a/collects/scribblings/reference/sets.scrbl +++ b/collects/scribblings/reference/sets.scrbl @@ -3,6 +3,8 @@ (for-label racket/set)) @title[#:tag "sets"]{Sets} +@(define set-eval (make-base-eval)) +@(interaction-eval #:eval set-eval (require racket/set)) A @deftech{set} represents a set of distinct elements. For a given set, elements are equivalent via @scheme[equal?], @scheme[eqv?], or @@ -86,7 +88,22 @@ Produces a set that includes all elements of all given @scheme[set]s, which must all use the same equivalence predicate (@scheme[equal?], @scheme[eq?], or @scheme[eqv?]). This operation runs in time proportional to the total size of all given @scheme[set]s except for -the largest.} +the largest. + +At least one set must be provided to @racket[set-union] even though +mathematically @racket[set-union] could accept zero arguments. Since +there are multiple types of sets (@racket[eq?], @racket[eqv?], and +@racket[equal?]) there is no obvious choice for a default empty set +to be returned. If there is a case where @racket[set-union] may be +applied to zero arguments, instead pass an empty set of the type +you desire. + +@examples[#:eval set-eval +(set-union (set)) +(set-union (seteq)) +(set-union (set 1) (set 2)) +(set-union (set 1) (seteq 2)) (code:comment "Sets of different types cannot be unioned") +]} @defproc[(set-intersect [set set?] ...+) set?]{ @@ -151,3 +168,4 @@ other forms.} Analogous to @scheme[for/list] and @scheme[for*/list], but to construct a set instead of a list.} +@close-eval[set-eval] diff --git a/collects/tests/racket/set.rktl b/collects/tests/racket/set.rktl index e8bd33675a..bb91761c34 100644 --- a/collects/tests/racket/set.rktl +++ b/collects/tests/racket/set.rktl @@ -17,8 +17,6 @@ (test #t set-empty? (seteqv)) (test #t set? (seteqv 1 2 3)) (test #f set-empty? (seteqv 1 2 3)) -(test #t set? (set-union)) -(test #t set-empty? (set-union)) (test #f set-eq? (set 1 2 3)) (test #f set-eqv? (set 1 2 3)) From 6df50ffe8391da6b748c35fe50b0561803e427b0 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Mon, 29 Nov 2010 10:58:48 -0500 Subject: [PATCH 190/255] final world display, Closes PR11471 --- collects/2htdp/private/world.rkt | 23 ++++++++++++++--------- 1 file changed, 14 insertions(+), 9 deletions(-) diff --git a/collects/2htdp/private/world.rkt b/collects/2htdp/private/world.rkt index 9c275df1ba..1bdc37a427 100644 --- a/collects/2htdp/private/world.rkt +++ b/collects/2htdp/private/world.rkt @@ -263,14 +263,17 @@ (begin (set! nw (stop-the-world-world nw)) (send world set tag nw) - (when last-picture (last-draw)) - (when draw (pdraw)) + (cond + [last-picture (last-draw)] + [draw (pdraw)]) (callback-stop! 'name) (enable-images-button)) - (let ([changed-world? (send world set tag nw)]) + (let ([changed-world? (send world set tag nw)] + [stop? (pstop)]) ;; this is the old "Robby optimization" see checked-cell: ; unless changed-world? - (when draw + (cond + [(and draw (not stop?)) (cond [(not drawing) (set! drawing #t) @@ -285,11 +288,13 @@ ;; high!! the scheduled callback didn't fire (queue-callback (lambda () (d)) #t)] [else - (set! draw# (- draw# 1))])) - (when (pstop) - (when last-picture (last-draw)) - (callback-stop! 'name) - (enable-images-button)) + (set! draw# (- draw# 1))])] + [stop? + (cond + [last-picture (last-draw)] + [draw (pdraw)]) + (callback-stop! 'name) + (enable-images-button)]) changed-world?)))))))) ;; tick, tock : deal with a tick event for this world From e1eb3cbfba49834997293008b00545861023e055 Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Sun, 28 Nov 2010 05:35:46 -0700 Subject: [PATCH 191/255] Handle SEGFAULT return --- collects/setup/parallel-build.rkt | 9 ++++--- collects/setup/parallel-do.rkt | 45 ++++++++++++++++++++----------- 2 files changed, 35 insertions(+), 19 deletions(-) diff --git a/collects/setup/parallel-build.rkt b/collects/setup/parallel-build.rkt index 50796f83e1..a4f4e93f93 100644 --- a/collects/setup/parallel-build.rkt +++ b/collects/setup/parallel-build.rkt @@ -27,9 +27,12 @@ ((collects-queue-append-error jobqueue) cc "making" null out err "output"))]) (when last ((collects-queue-printer jobqueue) (current-output-port) "made" "~a" cc-name )))] [else - (eprintf "work-done match cc failed.\n") - (eprintf "trying to match:\n~a\n" (list work msg))])) - + (match work + [(list (list cc file last) message) + ((collects-queue-append-error jobqueue) cc "making" null "" "" "error") + (eprintf "work-done match cc failed.\n") + (eprintf "trying to match:\n~a\n" (list work msg))])])) + ;; assigns a collection to each worker to be compiled ;; when it runs out of collections, steals work from other workers collections (define (get-job jobqueue workerid) diff --git a/collects/setup/parallel-do.rkt b/collects/setup/parallel-do.rkt index 79cec4b1c0..3673f4e0d1 100644 --- a/collects/setup/parallel-do.rkt +++ b/collects/setup/parallel-do.rkt @@ -2,10 +2,11 @@ (require racket/file racket/future - scheme/fasl - scheme/match + racket/port + racket/fasl + racket/match racket/path - scheme/serialize + racket/serialize unstable/generics racket/stxparam (for-syntax syntax/parse @@ -30,14 +31,14 @@ (define-struct worker (id process-handle out in err)) (define (current-executable-path) - (parameterize ([current-directory (find-system-path 'orig-dir)]) - (find-executable-path (find-system-path 'exec-file) #f))) + (parameterize ([current-directory (find-system-path 'orig-dir)]) + (find-executable-path (find-system-path 'exec-file) #f))) (define (current-collects-path) - (let ([p (find-system-path 'collects-dir)]) - (if (complete-path? p) - p - (path->complete-path p (or (path-only (current-executable-path)) - (find-system-path 'orig-dir)))))) + (let ([p (find-system-path 'collects-dir)]) + (if (complete-path? p) + p + (path->complete-path p (or (path-only (current-executable-path)) + (find-system-path 'orig-dir)))))) (define (parallel-do-event-loop initialcode initialmsg worker-cmdline-list jobqueue nprocs stopat) @@ -96,17 +97,26 @@ [(list (and (? empty?) idle) (list) count error-count) (set! workers idle)] ;; Wait for reply from worker [(list idle inflight count error-count) + (define (remove-dead-worker id node-worker) + (loop (cons (spawn id) idle) + (remove node-worker inflight) + count + (add1 error-count))) + (apply sync (map (λ (node-worker) (match node-worker [(list node (and wrkr (worker id sh out in err))) (handle-evt out (λ (e) (let ([msg (with-handlers* ([exn:fail? (lambda (e) (printf "MASTER READ ERROR - reading from worker: ~a\n" (exn-message e)) (kill-worker wrkr) - (loop (cons (spawn id) idle) - (remove node-worker inflight) - count - (add1 error-count)))]) - (read out))]) + (remove-dead-worker id node-worker))]) + (let ([read-msg (read out)]) + (if (pair? read-msg) + read-msg + (begin + (work-done jobqueue node id (string-append read-msg (port->string out))) + (kill-worker wrkr) + (remove-dead-worker id node-worker)))))]) (work-done jobqueue node id msg) (loop (cons wrkr idle) (remove node-worker inflight) @@ -116,7 +126,10 @@ (eprintf "parallel-do-event-loop match node-worker failed.\n") (eprintf "trying to match:\n~a\n" node-worker)])) - inflight))])]) + inflight))] + [x + (eprintf "parallel-do-event-loop match-lambda* failed.\n") + (eprintf "trying to match:\n~a\n" x)])]) (loop workers null 0 0))) (lambda () (for ([p workers]) (with-handlers ([exn? void]) (send/msg (list 'DIE) (worker-in p)))) From 2a7ccc552a1fbfd3dacd65d0e2f85bceae870e5d Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 29 Nov 2010 07:39:45 -0600 Subject: [PATCH 192/255] clean up test suite ala gr2 --- collects/2htdp/tests/test-image.rkt | 37 +++++++++++++---------------- 1 file changed, 17 insertions(+), 20 deletions(-) diff --git a/collects/2htdp/tests/test-image.rkt b/collects/2htdp/tests/test-image.rkt index 084e8b0c39..f5d8123546 100644 --- a/collects/2htdp/tests/test-image.rkt +++ b/collects/2htdp/tests/test-image.rkt @@ -1229,8 +1229,8 @@ 16) (test (let () - (define bmp (make-object bitmap% 4 4)) - (define mask (make-object bitmap% 4 4)) + (define bmp (make-bitmap 4 4)) + (define mask (make-bitmap 4 4)) (define bdc (make-object bitmap-dc% bmp)) (send bdc set-brush "black" 'solid) (send bdc draw-rectangle 0 0 4 4) @@ -1242,13 +1242,13 @@ (let-values ([(bytes w h) (bitmap->bytes bmp mask)]) bytes)) => - (bytes-append #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" - #"\0\0\0\0" #"\377\0\0\0" #"\0\0\0\0" #"\0\0\0\0" - #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" - #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0")) + (bytes-append #"\377\0\0\0" #"\377\0\0\0" #"\377\0\0\0" #"\377\0\0\0" + #"\377\0\0\0" #"\377\0\0\0" #"\377\0\0\0" #"\377\0\0\0" + #"\377\0\0\0" #"\377\0\0\0" #"\377\0\0\0" #"\377\0\0\0" + #"\377\0\0\0" #"\377\0\0\0" #"\377\0\0\0" #"\377\0\0\0")) ;; ensure no error -(test (begin (scale 2 (make-object bitmap% 10 10)) +(test (begin (scale 2 (make-bitmap 10 10)) (void)) => (void)) @@ -1261,18 +1261,18 @@ (send bdc draw-rectangle x y w h) (send bdc set-bitmap #f))) -(define blue-10x20-bitmap (make-object bitmap% 10 20)) +(define blue-10x20-bitmap (make-bitmap 10 20)) (fill-bitmap blue-10x20-bitmap "blue") -(define blue-20x10-bitmap (make-object bitmap% 20 10)) +(define blue-20x10-bitmap (make-bitmap 20 10)) (fill-bitmap blue-20x10-bitmap "blue") -(define blue-20x40-bitmap (make-object bitmap% 20 40)) +(define blue-20x40-bitmap (make-bitmap 20 40)) (fill-bitmap blue-20x40-bitmap "blue") -(define green-blue-10x20-bitmap (make-object bitmap% 10 20)) +(define green-blue-10x20-bitmap (make-bitmap 10 20)) (fill-bitmap green-blue-10x20-bitmap "green") (fill-bitmap green-blue-10x20-bitmap "blue" 0 0 10 10) -(define green-blue-20x10-bitmap (make-object bitmap% 20 10)) +(define green-blue-20x10-bitmap (make-bitmap 20 10)) (fill-bitmap green-blue-20x10-bitmap "green") (fill-bitmap green-blue-20x10-bitmap "blue" 10 0 10 10) @@ -1285,9 +1285,6 @@ (test (image-baseline (image-snip->image (make-object image-snip% blue-10x20-bitmap))) => 20) -(test (scale 2 (make-object image-snip% blue-10x20-bitmap)) - => - (image-snip->image (make-object image-snip% blue-20x40-bitmap))) (test (rotate 90 (make-object image-snip% blue-10x20-bitmap)) => @@ -1489,9 +1486,9 @@ "white")) (let* ([bdc (make-object bitmap-dc%)] - [bm-ul (make-object bitmap% 10 10)] - [bm-ur (make-object bitmap% 10 10)] - [bm-ll (make-object bitmap% 10 10)]) + [bm-ul (make-bitmap 10 10)] + [bm-ur (make-bitmap 10 10)] + [bm-ll (make-bitmap 10 10)]) (send bdc set-bitmap bm-ul) (send bdc set-pen "red" 1 'transparent) (send bdc set-brush "red" 'solid) @@ -2154,8 +2151,8 @@ (let () (define w 200) (define h 200) - (define bm1 (make-object bitmap% w h)) - (define bm2 (make-object bitmap% w h)) + (define bm1 (make-bitmap w h)) + (define bm2 (make-bitmap w h)) (define bytes1 (make-bytes (* w h 4) 0)) (define bytes2 (make-bytes (* w h 4) 0)) (define bdc1 (make-object bitmap-dc% bm1)) From f11e53c68ca1fbc4e11321f97776650b8758ace3 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 29 Nov 2010 07:40:27 -0600 Subject: [PATCH 193/255] gr2 cleanup --- collects/mrlib/private/image-core-bitmap.rkt | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/collects/mrlib/private/image-core-bitmap.rkt b/collects/mrlib/private/image-core-bitmap.rkt index 7b6b2baf5d..949acdcb56 100644 --- a/collects/mrlib/private/image-core-bitmap.rkt +++ b/collects/mrlib/private/image-core-bitmap.rkt @@ -72,14 +72,8 @@ instead of this scaling code, we use the dc<%>'s scaling code. w h (* w h NUM-CHANNELS))) - (let* ([bm (make-object bitmap% w h)] - [mask (make-object bitmap% w h)] - [bdc (make-object bitmap-dc% bm)]) - (send bdc set-argb-pixels 0 0 w h bytes #f) - (send bdc set-bitmap mask) - (send bdc set-argb-pixels 0 0 w h bytes #t) - (send bdc set-bitmap #f) - (send bm set-loaded-mask mask) + (let* ([bm (make-bitmap w h)]) + (send bm set-argb-pixels 0 0 w h bytes) bm)) (define (flip-bytes bmbytes w h) From 8903d1b5c9ea728714044467f7c76c114f0e143f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 30 Nov 2010 05:14:20 -0500 Subject: [PATCH 194/255] Patch Racket manifest file too. --- collects/meta/build/versionpatch | 14 ++++++++------ src/worksp/racket/racket.manifest | 2 +- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/collects/meta/build/versionpatch b/collects/meta/build/versionpatch index a42091c1e6..d9e56341b2 100755 --- a/collects/meta/build/versionpatch +++ b/collects/meta/build/versionpatch @@ -3,8 +3,8 @@ exec racket -um "$0" "$@" |# -#lang scheme/base -(require version/utils scheme/file) +#lang racket/base +(require version/utils racket/file) (define (patches) ;; no grouping parens in regexps @@ -21,7 +21,9 @@ exec racket -um "$0" "$@" (concat "\r\n *VALUE \"FileVersion\", *\""commas "(?:\\\\0)?\"") (concat "\r\n *VALUE \"ProductVersion\", *\""commas - "(?:\\\\0)?\""))]) + "(?:\\\\0)?\""))] + [manifest-patch (list (concat "assemblyIdentity *\r\n *version *" + "= *\""periods"\" *\r\n"))]) `([#t ; only verify that it has the right contents "src/racket/src/schvers.h" ,(concat "\n#define MZSCHEME_VERSION \"<1>.<2>" @@ -35,9 +37,9 @@ exec racket -um "$0" "$@" "0" (format "<~a>" (cadr x+n)))))] ["src/worksp/racket/racket.rc" ,@rc-patch] ["src/worksp/gracket/gracket.rc" ,@rc-patch] - ["src/worksp/starters/start.rc" ,@rc-patch] - ["src/worksp/gracket/gracket.manifest" - ,(concat "assemblyIdentity *\r\n *version *= *\""periods"\" *\r\n")] + ["src/worksp/starters/start.rc" ,@rc-patch] + ["src/worksp/racket/racket.manifest" ,@manifest-patch] + ["src/worksp/gracket/gracket.manifest" ,@manifest-patch] ["src/worksp/mzcom/mzobj.rgs" ,(concat "MzCOM.MzObj."periods" = s 'MzObj Class'") ,(concat "CurVer = s 'MzCOM.MzObj."periods"'") diff --git a/src/worksp/racket/racket.manifest b/src/worksp/racket/racket.manifest index 8b66585a1d..52262cb7a4 100644 --- a/src/worksp/racket/racket.manifest +++ b/src/worksp/racket/racket.manifest @@ -1,7 +1,7 @@ Date: Tue, 30 Nov 2010 09:55:18 -0600 Subject: [PATCH 195/255] change the behavior for closing the preferences window. closes PR 11473 --- collects/framework/private/preferences.rkt | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/collects/framework/private/preferences.rkt b/collects/framework/private/preferences.rkt index 505fccaa6a..cb22974a2d 100644 --- a/collects/framework/private/preferences.rkt +++ b/collects/framework/private/preferences.rkt @@ -206,13 +206,14 @@ the state transitions / contracts are: (define (make-preferences-dialog) (letrec ([stashed-prefs (preferences:get-prefs-snapshot)] - [cancelled? #t] + [cancelled? #f] [frame-stashed-prefs% (class frame:basic% (inherit close) (define/override (on-subwindow-char receiver event) (cond [(eq? 'escape (send event get-key-code)) + (set! cancelled? #t) (close)] [else (super on-subwindow-char receiver event)])) @@ -222,7 +223,7 @@ the state transitions / contracts are: (define/override (show on?) (when on? ;; reset the flag and save new prefs when the window becomes visible - (set! cancelled? #t) + (set! cancelled? #f) (set! stashed-prefs (preferences:get-prefs-snapshot))) (super show on?)) (super-new))] @@ -280,9 +281,10 @@ the state transitions / contracts are: (for-each (λ (f) (f)) on-close-dialog-callbacks) - (set! cancelled? #f) (send frame close)))] - [cancel-callback (λ () (send frame close))]) + [cancel-callback (λ () + (set! cancelled? #t) + (send frame close))]) (new button% [label (string-constant revert-to-defaults)] [callback From 37d16cf8f81a5b486ca79d5c6b6695de5dc95455 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 28 Nov 2010 17:10:42 -0700 Subject: [PATCH 196/255] cocoa: fix race condition on window enabling --- collects/mred/private/wx/cocoa/canvas.rkt | 1 + collects/mred/private/wx/cocoa/window.rkt | 6 ++++-- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 551eed0d95..7e3d0cdb9a 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -612,6 +612,7 @@ 1)])) (define/override (enable-window on?) + ;; in atomic mode (let ([on? (and on? (is-window-enabled?))]) (let ([w (tell content-cocoa window)]) (when (ptr-equal? content-cocoa (tell w firstResponder)) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 0c37a04e5f..dbe29c728a 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -520,9 +520,11 @@ (define/public (is-window-enabled?) enabled?) (define/public (enable on?) - (set! enabled? on?) - (enable-window on?)) + (atomically + (set! enabled? on?) + (enable-window on?))) (define/public (enable-window on?) + ;; in atomic mode (void)) (define block-all-mouse-events? #f) From 64979a5480421363dad3a1e0f16753a17d37db79 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 28 Nov 2010 18:05:59 -0700 Subject: [PATCH 197/255] further refinments to the ephemeron description --- collects/scribblings/reference/memory.scrbl | 32 +++++++++++-------- .../scribblings/reference/reference.scrbl | 18 +++++++---- 2 files changed, 31 insertions(+), 19 deletions(-) diff --git a/collects/scribblings/reference/memory.scrbl b/collects/scribblings/reference/memory.scrbl index 3088f51fff..bf7236144e 100644 --- a/collects/scribblings/reference/memory.scrbl +++ b/collects/scribblings/reference/memory.scrbl @@ -37,15 +37,26 @@ Returns @racket[#t] if @racket[v] is a weak box, @racket[#f] otherwise.} @;------------------------------------------------------------------------ @section[#:tag "ephemerons"]{Ephemerons} -An @deftech{ephemeron} is a generalization of a weak box (see -@secref["weakbox"]). Instead of just containing one value, it holds two, -the value of the ephemeron, plus a key. Like a weak box, the -value in the ephemeron may be replaced by @racket[#f], but it does -this when the key is no longer reachable. In addition, the memory -manager specially treats links from the value to the key. +An @deftech{ephemeron} @cite{Hayes97} is a generalization of a +@tech{weak box} (see @secref["weakbox"]). Instead of just containing +one value, an emphemeron holds two values: one that is considered the +value of the ephemeron and another that is the ephemeron's key. Like +the value in a weak box, the value in and ephemeron may be replaced by +@racket[#f], but when the @emph{key} is no longer reachable (except +possibly via weak references) instead of when the value is no longer +reachable. -A weak box can be seen as a specialization of an ephemeron where -the key and value are the same. +As long as an ephemeron's value is retained, the reference is +considered a non-weak reference. References to the key via the value +are treated specially, however, in that the reference does not +necessarily count toward the key's reachability. A @tech{weak box} can +be seen as a specialization of an ephemeron where the key and value +are the same. + +On particularly common use of ephemerons is to combine them with a +weak hash table (see @secref["hashtables"]) to produce a mapping where +the memory manager can reclaim key--value pairs even when the value +refers to the key. More precisely, @itemize[ @@ -64,11 +75,6 @@ More precisely, ] -On particularly common use of ephemerons is to combined them with a weak hash table -(see @secref["hashtables"]) to produce a mapping where the memory -manager can reclaim key--value pairs even when the value refers to the -key. - @defproc[(make-ephemeron [key any/c] [v any/c]) ephemeron?]{ diff --git a/collects/scribblings/reference/reference.scrbl b/collects/scribblings/reference/reference.scrbl index cd4310e9f7..b5b1a67b65 100644 --- a/collects/scribblings/reference/reference.scrbl +++ b/collects/scribblings/reference/reference.scrbl @@ -111,12 +111,18 @@ The @racketmodname[racket] library combines #:title "A Generalization of Exceptions and Control in ML-like Languages" #:location "Functional Programming Languages and Computer Architecture" #:date "1995") - - (bib-entry #:key "Hieb90" - #:author "Robert Hieb and R. Kent Dybvig" - #:title "Continuations and Concurrency" - #:location "Principles and Practice of Parallel Programming" - #:date "1990") + + (bib-entry #:key "Hayes97" + #:author "Barry Hayes" + #:title "Ephemerons: a New Finalization Mechanism" + #:location "Object-Oriented Languages, Programming, Systems, and Applications" + #:date "1997") + + (bib-entry #:key "Hieb90" + #:author "Robert Hieb and R. Kent Dybvig" + #:title "Continuations and Concurrency" + #:location "Principles and Practice of Parallel Programming" + #:date "1990") (bib-entry #:key "L'Ecuyer02" #:author "Pierre L'Ecuyer, Richard Simard, E. Jack Chen, and W. David Kelton" From c81ad90161104a1e02c172cb18753ff93fdfe452 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 28 Nov 2010 19:57:38 -0700 Subject: [PATCH 198/255] fix eventspace as event --- collects/mred/private/wx/common/queue.rkt | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 5041babcae..65df083dd9 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -196,6 +196,7 @@ (define (make-eventspace* th) (let ([done-sema (make-semaphore 1)] + [done-set? #t] [frames (make-hasheq)]) (let ([e (make-eventspace th @@ -212,8 +213,12 @@ (if (or (positive? count) (positive? (hash-count frames)) (not (null? (unbox timer)))) - (semaphore-try-wait? done-sema) - (semaphore-post done-sema)))] + (when done-set? + (set! done-set? #f) + (semaphore-try-wait? done-sema)) + (unless done-set? + (set! done-set? #t) + (semaphore-post done-sema))))] [enqueue (lambda (v q) (set! count (add1 count)) (check-done) From 9f9e23f551ad1b45c9d930a89bcec58f422c4b38 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 29 Nov 2010 12:35:25 -0700 Subject: [PATCH 199/255] don't GC an eventspace with a visible frame, etc. --- collects/mred/private/wx/common/queue.rkt | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 65df083dd9..14c8006b51 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -176,6 +176,11 @@ [(< am bm) -1] [else 1])))) +;; This table refers to handle threads of eventspaces +;; that have an open window, etc., so that the eventspace +;; isn't GCed +(define active-eventspaces (make-hasheq)) + (define current-cb-box (make-parameter #f)) (define-mz scheme_add_managed (_fun _racket ; custodian @@ -192,7 +197,8 @@ (set-eventspace-shutdown?! e #t) (semaphore-post (eventspace-done-sema e)) (for ([f (in-list (get-top-level-windows e))]) - (send f destroy)))) + (send f destroy)) + (hash-remove! active-eventspaces (eventspace-handler-thread e)))) (define (make-eventspace* th) (let ([done-sema (make-semaphore 1)] @@ -214,9 +220,11 @@ (positive? (hash-count frames)) (not (null? (unbox timer)))) (when done-set? + (hash-set! active-eventspaces th #t) (set! done-set? #f) (semaphore-try-wait? done-sema)) (unless done-set? + (hash-remove! active-eventspaces th) (set! done-set? #t) (semaphore-post done-sema))))] [enqueue (lambda (v q) From 8f9a8daa27dee721545915970eaa56b0c7ec4c30 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 30 Nov 2010 07:55:41 -0700 Subject: [PATCH 200/255] fix {get,set}-event-type on mouse-event% Closes PR 11474 --- collects/mred/private/wx/common/event.rkt | 56 +++++++++++------------ collects/racket/draw/private/syntax.rkt | 16 +++++-- 2 files changed, 39 insertions(+), 33 deletions(-) diff --git a/collects/mred/private/wx/common/event.rkt b/collects/mred/private/wx/common/event.rkt index e9820fe3e5..88f1fc5fec 100644 --- a/collects/mred/private/wx/common/event.rkt +++ b/collects/mred/private/wx/common/event.rkt @@ -14,10 +14,11 @@ (super-new)) (defclass mouse-event% event% - ;; FIXME: check event-type - (init event-type) - (define et event-type) - (init-properties [[bool? left-down] #f] + (init-properties [[(symbol-in enter leave left-down left-up + middle-down middle-up + right-down right-up motion) + event-type]] + [[bool? left-down] #f] [[bool? middle-down] #f] [[bool? right-down] #f] [[exact-integer? x] 0] @@ -30,44 +31,45 @@ (init-properties [[bool? caps-down] #f]) (super-new [time-stamp time-stamp]) - (def/public (get-event-type) et) - (def/public (button-changed? [(symbol-in left middle right any) [button 'any]]) - (and (memq et (case button - [(any) '(left-down left-up middle-down middle-up right-down right-up)] - [(left) '(left-down left-up)] - [(middle) '(middle-down middle-up)] - [(right) '(right-down right-up)])) + (and (memq event-type + (case button + [(any) '(left-down left-up middle-down middle-up right-down right-up)] + [(left) '(left-down left-up)] + [(middle) '(middle-down middle-up)] + [(right) '(right-down right-up)])) #t)) (def/public (button-down? [(symbol-in left middle right any) [button 'any]]) - (and (memq et (case button - [(any) '(left-down middle-down right-down)] - [(left) '(left-down)] - [(middle) '(middle-down)] - [(right) '(right-down)])) + (and (memq event-type + (case button + [(any) '(left-down middle-down right-down)] + [(left) '(left-down)] + [(middle) '(middle-down)] + [(right) '(right-down)])) #t)) (def/public (button-up? [(symbol-in left middle right any) [button 'any]]) - (and (memq et (case button - [(any) '(left-up middle-up right-up)] - [(left) '(left-up)] - [(middle) '(middle-up)] - [(right) '(right-up)])) + (and (memq event-type + (case button + [(any) '(left-up middle-up right-up)] + [(left) '(left-up)] + [(middle) '(middle-up)] + [(right) '(right-up)])) #t)) (def/public (dragging?) - (and (eq? et 'motion) + (and (eq? event-type 'motion) (or left-down middle-down right-down))) (def/public (entering?) - (eq? et 'enter)) + (eq? event-type 'enter)) (def/public (leaving?) - (eq? et 'leave)) + (eq? event-type 'leave)) (def/public (moving?) - (eq? et 'motion))) + (eq? event-type 'motion))) (defclass key-event% event% (init-properties [[(make-alts symbol? char?) key-code] #\nul] @@ -91,9 +93,7 @@ list-box list-box-dclick text-field text-field-enter slider radio-box menu-popdown menu-popdown-none tab-panel) - event-type] - ;; FIXME: should have no default - 'button]) + event-type]]) (init [time-stamp 0]) (super-new [time-stamp time-stamp])) diff --git a/collects/racket/draw/private/syntax.rkt b/collects/racket/draw/private/syntax.rkt index b4cc868a66..53a8de40c0 100644 --- a/collects/racket/draw/private/syntax.rkt +++ b/collects/racket/draw/private/syntax.rkt @@ -226,7 +226,7 @@ (define-syntax (do-properties stx) (syntax-case stx () - [(_ define-base check-immutable [[type id] expr] ...) + [(_ define-base check-immutable [[type id] expr ...] ...) (let ([ids (syntax->list #'(id ...))]) (with-syntax ([(getter ...) (map (lambda (id) @@ -243,7 +243,7 @@ id)) ids)]) #'(begin - (define-base id expr) ... + (define-base id expr ...) ... (define/public (getter) id) ... (def/public (setter [type v]) (check-immutable 'setter) (set! id (coerce type v))) ...)))])) @@ -271,9 +271,15 @@ (do-properties define-init check-immutable . props)] [(_ . props) (do-properties define-init void . props)])) -(define-syntax-rule (define-init id val) (begin - (init [(internal id) val]) - (define id internal))) +(define-syntax define-init + (syntax-rules () + [(_ id val) (begin + (init [(internal id) val]) + (define id internal))] + [(_ id) (begin + (init [(internal id)]) + (define id internal))])) + (define (->long i) (cond From b212fc948516a21578f73b353a42cdca08254135 Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Tue, 30 Nov 2010 09:33:55 -0700 Subject: [PATCH 201/255] Parallel build match fix --- collects/setup/parallel-build.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/setup/parallel-build.rkt b/collects/setup/parallel-build.rkt index a4f4e93f93..0bf98f9ed6 100644 --- a/collects/setup/parallel-build.rkt +++ b/collects/setup/parallel-build.rkt @@ -28,7 +28,7 @@ (when last ((collects-queue-printer jobqueue) (current-output-port) "made" "~a" cc-name )))] [else (match work - [(list (list cc file last) message) + [(list-rest (list cc file last) message) ((collects-queue-append-error jobqueue) cc "making" null "" "" "error") (eprintf "work-done match cc failed.\n") (eprintf "trying to match:\n~a\n" (list work msg))])])) From 6c25210a6bb8328f580887f0dae51d7f3f885c9c Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 30 Nov 2010 15:47:03 -0600 Subject: [PATCH 202/255] refactored check syntax in preparation to fix the problem with binding identifiers being duplicated by macros --- .../drracket/private/syncheck/traversals.rkt | 45 +++++++++++++------ 1 file changed, 31 insertions(+), 14 deletions(-) diff --git a/collects/drracket/private/syncheck/traversals.rkt b/collects/drracket/private/syncheck/traversals.rkt index 64f156ddaf..fff9e42173 100644 --- a/collects/drracket/private/syncheck/traversals.rkt +++ b/collects/drracket/private/syncheck/traversals.rkt @@ -626,7 +626,19 @@ (color-unused require-for-templates unused-require-for-templates) (color-unused require-for-syntaxes unused-require-for-syntaxes) (color-unused requires unused-requires) - (hash-for-each rename-ht (lambda (k stxs) (make-rename-menu stxs id-sets))))) + + (define src-loc-id-table (make-hash)) + (for ([id-set (in-list id-sets)]) + (for-each-ids + id-set + (λ (ids) + (for ([id (in-list ids)]) + (define key (list (syntax-source id) + (syntax-position id) + (syntax-span id))) + (hash-set! src-loc-id-table key (hash-ref src-loc-id-table key '())))))) + + (hash-for-each rename-ht (lambda (k stxs) (make-rename-menu stxs id-sets src-loc-id-table))))) ;; record-renamable-var : rename-ht syntax -> void @@ -1309,8 +1321,11 @@ ; ;;; - ;; make-rename-menu : (cons stx[original,id] (listof stx[original,id])) (listof id-set) -> void - (define (make-rename-menu stxs id-sets) + ;; make-rename-menu : (cons stx[original,id] (listof stx[original,id])) + ;; (listof id-set) + ;; hash[(list source number number) -o> (listof syntax)] + ;; -> void + (define (make-rename-menu stxs id-sets src-loc-id-table) (let ([defs-text (currently-processing-definitions-text)]) (when defs-text (let* ([source (syntax-source (car stxs))] ;; all stxs in the list must have the same source @@ -1335,6 +1350,7 @@ defs-text stxs id-sets + src-loc-id-table frame-parent)))))))))))))) ;; find-parent : menu-item-container<%> -> (union #f (is-a?/c top-level-window<%>) @@ -1359,10 +1375,11 @@ ;; (and/c syncheck-text<%> definitions-text<%>) ;; (listof syntax[original]) ;; (listof id-set) + ;; hash[(list source number number) -o> (listof syntax)] ;; (union #f (is-a?/c top-level-window<%>)) ;; -> void ;; callback for the rename popup menu item - (define (rename-callback name-to-offer defs-text stxs id-sets parent) + (define (rename-callback name-to-offer defs-text stxs id-sets src-loc-id-table parent) (let ([new-str (fw:keymap:call/text-keymap-initializer (λ () @@ -1373,18 +1390,18 @@ name-to-offer)))]) (when new-str (let* ([new-sym (format "~s" (string->symbol new-str))] + [raw-to-be-renamed + (let ([raw '()]) + (for ([id-set (in-list id-sets)]) + (for ([stx (in-list stxs)]) + (for ([id (in-list (or (get-ids id-set stx) '()))]) + (set! raw (cons id raw))))) + raw)] [to-be-renamed (remove-duplicates-stx - (sort - (apply - append - (map (λ (id-set) - (apply - append - (map (λ (stx) (or (get-ids id-set stx) '())) stxs))) - id-sets)) - (λ (x y) - ((syntax-position x) . >= . (syntax-position y)))))] + (sort raw-to-be-renamed + >= + #:key syntax-position))] [do-renaming? (or (not (name-duplication? to-be-renamed id-sets new-sym)) (equal? From 7efcf808566cf91b9f27d84bb387842bc55ca858 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 30 Nov 2010 09:39:45 -0700 Subject: [PATCH 203/255] typo --- collects/scribblings/reference/memory.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/reference/memory.scrbl b/collects/scribblings/reference/memory.scrbl index bf7236144e..c6cc0d8333 100644 --- a/collects/scribblings/reference/memory.scrbl +++ b/collects/scribblings/reference/memory.scrbl @@ -53,7 +53,7 @@ necessarily count toward the key's reachability. A @tech{weak box} can be seen as a specialization of an ephemeron where the key and value are the same. -On particularly common use of ephemerons is to combine them with a +One particularly common use of ephemerons is to combine them with a weak hash table (see @secref["hashtables"]) to produce a mapping where the memory manager can reclaim key--value pairs even when the value refers to the key. From ca8b32725e8dc5cac24e6249f0c4c1b09343da06 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 30 Nov 2010 15:07:24 -0700 Subject: [PATCH 204/255] fix bloking operations during a try-atomic and remove old delim-cont support used by gr1 --- collects/ffi/unsafe/try-atomic.rkt | 8 +- src/racket/include/scheme.h | 2 +- src/racket/src/mzmark.c | 33 --- src/racket/src/mzmarksrc.c | 13 -- src/racket/src/schpriv.h | 2 + src/racket/src/schvers.h | 4 +- src/racket/src/sema.c | 88 +++++-- src/racket/src/stypes.h | 3 +- src/racket/src/thread.c | 356 +++++------------------------ 9 files changed, 138 insertions(+), 371 deletions(-) diff --git a/collects/ffi/unsafe/try-atomic.rkt b/collects/ffi/unsafe/try-atomic.rkt index 1de4186456..c1c44f2ddf 100644 --- a/collects/ffi/unsafe/try-atomic.rkt +++ b/collects/ffi/unsafe/try-atomic.rkt @@ -11,7 +11,7 @@ (define scheme_call_with_composable_no_dws (get-ffi-obj 'scheme_call_with_composable_no_dws #f (_fun _scheme _scheme -> _scheme))) (define scheme_set_on_atomic_timeout - (get-ffi-obj 'scheme_set_on_atomic_timeout #f (_fun (_fun -> _void) -> _pointer))) + (get-ffi-obj 'scheme_set_on_atomic_timeout #f (_fun (_fun _int -> _void) -> _pointer))) (define scheme_restore_on_atomic_timeout (get-ffi-obj 'scheme_set_on_atomic_timeout #f (_fun _pointer -> _pointer))) @@ -59,8 +59,10 @@ [else ;; try to do some work: (let* ([ready? #f] - [handler (lambda () - (when (and ready? (should-give-up?)) + [handler (lambda (must-give-up) + (when (and ready? + (or (positive? must-give-up) + (should-give-up?))) (scheme_call_with_composable_no_dws (lambda (proc) (set-box! b (cons proc (unbox b))) diff --git a/src/racket/include/scheme.h b/src/racket/include/scheme.h index 949f9f2dcc..2d3283e0a9 100644 --- a/src/racket/include/scheme.h +++ b/src/racket/include/scheme.h @@ -1710,7 +1710,7 @@ extern void *scheme_malloc_envunbox(size_t); /* embedding configuration and hooks */ /*========================================================================*/ -typedef void (*Scheme_On_Atomic_Timeout_Proc)(void); +typedef void (*Scheme_On_Atomic_Timeout_Proc)(int must_give_up); #if SCHEME_DIRECT_EMBEDDED diff --git a/src/racket/src/mzmark.c b/src/racket/src/mzmark.c index a9ce6020f5..9c0b9f06c5 100644 --- a/src/racket/src/mzmark.c +++ b/src/racket/src/mzmark.c @@ -4550,39 +4550,6 @@ static int mark_thread_cell_FIXUP(void *p, struct NewGC *gc) { #define mark_thread_cell_IS_CONST_SIZE 1 -static int mark_frozen_tramp_SIZE(void *p, struct NewGC *gc) { - return - gcBYTES_TO_WORDS(sizeof(FrozenTramp)); -} - -static int mark_frozen_tramp_MARK(void *p, struct NewGC *gc) { - FrozenTramp *f = (FrozenTramp *)p; - - gcMARK2(f->do_data, gc); - gcMARK2(f->old_param, gc); - gcMARK2(f->config, gc); - gcMARK2(f->progress_cont, gc); - - return - gcBYTES_TO_WORDS(sizeof(FrozenTramp)); -} - -static int mark_frozen_tramp_FIXUP(void *p, struct NewGC *gc) { - FrozenTramp *f = (FrozenTramp *)p; - - gcFIXUP2(f->do_data, gc); - gcFIXUP2(f->old_param, gc); - gcFIXUP2(f->config, gc); - gcFIXUP2(f->progress_cont, gc); - - return - gcBYTES_TO_WORDS(sizeof(FrozenTramp)); -} - -#define mark_frozen_tramp_IS_ATOMIC 0 -#define mark_frozen_tramp_IS_CONST_SIZE 1 - - #endif /* THREAD */ /**********************************************************************/ diff --git a/src/racket/src/mzmarksrc.c b/src/racket/src/mzmarksrc.c index eeb1a32bca..2c7a5a138e 100644 --- a/src/racket/src/mzmarksrc.c +++ b/src/racket/src/mzmarksrc.c @@ -1852,19 +1852,6 @@ mark_thread_cell { gcBYTES_TO_WORDS(sizeof(Thread_Cell)); } -mark_frozen_tramp { - mark: - FrozenTramp *f = (FrozenTramp *)p; - - gcMARK2(f->do_data, gc); - gcMARK2(f->old_param, gc); - gcMARK2(f->config, gc); - gcMARK2(f->progress_cont, gc); - - size: - gcBYTES_TO_WORDS(sizeof(FrozenTramp)); -} - END thread; /**********************************************************************/ diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index 86af9ddf4b..df3abad0df 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -463,6 +463,8 @@ void scheme_suspend_remembered_threads(void); void scheme_resume_remembered_threads(void); #endif +int scheme_wait_until_suspend_ok(void); + #ifdef MZ_USE_MZRT extern void scheme_check_foreign_work(void); #endif diff --git a/src/racket/src/schvers.h b/src/racket/src/schvers.h index 81f05695d2..b4f6fd217d 100644 --- a/src/racket/src/schvers.h +++ b/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "5.0.99.3" +#define MZSCHEME_VERSION "5.0.99.4" #define MZSCHEME_VERSION_X 5 #define MZSCHEME_VERSION_Y 0 #define MZSCHEME_VERSION_Z 99 -#define MZSCHEME_VERSION_W 3 +#define MZSCHEME_VERSION_W 4 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/src/racket/src/sema.c b/src/racket/src/sema.c index fb00d00c48..df7f15e7f7 100644 --- a/src/racket/src/sema.c +++ b/src/racket/src/sema.c @@ -25,6 +25,7 @@ READ_ONLY Scheme_Object *scheme_always_ready_evt; THREAD_LOCAL_DECL(Scheme_Object *scheme_system_idle_channel); +extern int scheme_assert_atomic; static Scheme_Object *make_sema(int n, Scheme_Object **p); static Scheme_Object *semap(int n, Scheme_Object **p); @@ -93,7 +94,7 @@ void scheme_init_sema(Scheme_Env *env) scheme_add_global_constant("make-semaphore", scheme_make_prim_w_arity(make_sema, "make-semaphore", - 0, 1), + 0, 2), env); scheme_add_global_constant("semaphore?", scheme_make_folding_prim(semap, @@ -226,6 +227,7 @@ Scheme_Object *scheme_make_sema(long v) static Scheme_Object *make_sema(int n, Scheme_Object **p) { long v; + Scheme_Object *s; if (n) { if (!SCHEME_INTP(p[0])) { @@ -242,7 +244,12 @@ static Scheme_Object *make_sema(int n, Scheme_Object **p) } else v = 0; - return scheme_make_sema(v); + s = scheme_make_sema(v); + + if (n > 1) + SCHEME_CPTR_FLAGS(s) |= 0x1; + + return s; } static Scheme_Object *make_sema_repost(int n, Scheme_Object **p) @@ -315,6 +322,10 @@ void scheme_post_sema(Scheme_Object *o) } else consumed = 0; + if (!consumed) + if (SCHEME_CPTR_FLAGS(o) & 0x1) + printf("here\n"); + w->in_line = 0; w->prev = NULL; w->next = NULL; @@ -633,26 +644,47 @@ int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *synci } else start_pos = 0; - /* Initial poll */ - i = 0; - for (ii = 0; ii < n; ii++) { - /* Randomized start position for poll ensures fairness: */ - i = (start_pos + ii) % n; + scheme_assert_atomic++; - if (semas[i]->so.type == scheme_sema_type) { - if (semas[i]->value) { - if ((semas[i]->value > 0) && (!syncing || !syncing->reposts || !syncing->reposts[i])) - --semas[i]->value; - if (syncing && syncing->accepts && syncing->accepts[i]) - scheme_accept_sync(syncing, i); - break; - } - } else if (semas[i]->so.type == scheme_never_evt_type) { - /* Never ready. */ - } else if (semas[i]->so.type == scheme_channel_syncer_type) { - /* Probably no need to poll */ - } else if (try_channel(semas[i], syncing, i, NULL)) - break; + /* Initial poll */ + while (1) { + i = 0; + for (ii = 0; ii < n; ii++) { + /* Randomized start position for poll ensures fairness: */ + i = (start_pos + ii) % n; + + if (semas[i]->so.type == scheme_sema_type) { + if (semas[i]->value) { + if ((semas[i]->value > 0) && (!syncing || !syncing->reposts || !syncing->reposts[i])) + --semas[i]->value; + if (syncing && syncing->accepts && syncing->accepts[i]) + scheme_accept_sync(syncing, i); + break; + } + } else if (semas[i]->so.type == scheme_never_evt_type) { + /* Never ready. */ + } else if (semas[i]->so.type == scheme_channel_syncer_type) { + /* Probably no need to poll */ + } else if (try_channel(semas[i], syncing, i, NULL)) + break; + } + + if (ii >= n) { + if (!scheme_current_thread->next) + break; + else { + --scheme_assert_atomic; + if (!scheme_wait_until_suspend_ok()) { + scheme_assert_atomic++; + break; + } else { + /* there may have been some action on one of the waitables; + try again */ + scheme_assert_atomic++; + } + } + } else + break; } /* In the following, syncers get changed back to channels, @@ -700,7 +732,9 @@ int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *synci scheme_main_was_once_suspended = 0; + scheme_assert_atomic--; scheme_block_until(out_of_line, NULL, (Scheme_Object *)a, (float)0.0); + scheme_assert_atomic++; --scheme_current_thread->suspend_break; } else { @@ -710,7 +744,9 @@ int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *synci old_nkc = (scheme_current_thread->running & MZTHREAD_NEED_KILL_CLEANUP); if (!old_nkc) scheme_current_thread->running += MZTHREAD_NEED_KILL_CLEANUP; + scheme_assert_atomic--; scheme_weak_suspend_thread(scheme_current_thread); + scheme_assert_atomic++; if (!old_nkc && (scheme_current_thread->running & MZTHREAD_NEED_KILL_CLEANUP)) scheme_current_thread->running -= MZTHREAD_NEED_KILL_CLEANUP; } @@ -758,7 +794,9 @@ int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *synci get_outof_line(semas[i], ws[i]); } + scheme_assert_atomic--; scheme_thread_block(0); /* ok if it returns multiple times */ + scheme_assert_atomic++; scheme_current_thread->ran_some = 1; /* [but why would it return multiple times?! there must have been a reason...] */ } else { @@ -800,6 +838,8 @@ int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *synci } } + scheme_assert_atomic--; + if (i == -1) { scheme_thread_block(0); /* dies or suspends */ scheme_current_thread->ran_some = 1; @@ -807,6 +847,8 @@ int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *synci if (i < n) break; + + scheme_assert_atomic++; } /* Otherwise: !syncing and someone stole the post, or we were @@ -837,6 +879,7 @@ int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *synci get_outof_line(semas[j], ws[j]); } + scheme_assert_atomic--; break; } @@ -861,7 +904,8 @@ int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *synci } /* Back to top of loop to sync again */ } - } + } else + scheme_assert_atomic--; v = i + 1; } diff --git a/src/racket/src/stypes.h b/src/racket/src/stypes.h index 889bb6ae16..0eb0c795e8 100644 --- a/src/racket/src/stypes.h +++ b/src/racket/src/stypes.h @@ -257,8 +257,7 @@ enum { scheme_rt_sfs_info, /* 233 */ scheme_rt_validate_clearing, /* 234 */ scheme_rt_rb_node, /* 235 */ - scheme_rt_frozen_tramp, /* 236 */ - scheme_rt_lightweight_cont, /* 237 */ + scheme_rt_lightweight_cont, /* 236 */ #endif diff --git a/src/racket/src/thread.c b/src/racket/src/thread.c index 60a828d734..e73a2bcecf 100644 --- a/src/racket/src/thread.c +++ b/src/racket/src/thread.c @@ -128,6 +128,8 @@ extern int scheme_jit_malloced; # define scheme_jit_malloced 0 #endif +int scheme_assert_atomic; + /*========================================================================*/ /* local variables and prototypes */ /*========================================================================*/ @@ -206,7 +208,7 @@ HOOK_SHARED_OK void (*scheme_sleep)(float seconds, void *fds); HOOK_SHARED_OK void (*scheme_notify_multithread)(int on); HOOK_SHARED_OK void (*scheme_wakeup_on_input)(void *fds); HOOK_SHARED_OK int (*scheme_check_for_break)(void); -HOOK_SHARED_OK void (*scheme_on_atomic_timeout)(void); +HOOK_SHARED_OK Scheme_On_Atomic_Timeout_Proc scheme_on_atomic_timeout; HOOK_SHARED_OK static int atomic_timeout_auto_suspend; HOOK_SHARED_OK static int atomic_timeout_atomic_level; @@ -214,7 +216,6 @@ THREAD_LOCAL_DECL(struct Scheme_GC_Pre_Post_Callback_Desc *gc_prepost_callback_d ROSYM static Scheme_Object *read_symbol, *write_symbol, *execute_symbol, *delete_symbol, *exists_symbol; ROSYM static Scheme_Object *client_symbol, *server_symbol; -ROSYM static Scheme_Object *froz_key; THREAD_LOCAL_DECL(static int do_atomic = 0); THREAD_LOCAL_DECL(static int missed_context_switch = 0); @@ -380,7 +381,6 @@ static void make_initial_config(Scheme_Thread *p); static int do_kill_thread(Scheme_Thread *p); static void suspend_thread(Scheme_Thread *p); -static void wait_until_suspend_ok(int for_stack); static int check_sleep(int need_activity, int sleep_now); @@ -471,9 +471,6 @@ void scheme_init_thread(Scheme_Env *env) client_symbol = scheme_intern_symbol("client"); server_symbol = scheme_intern_symbol("server"); - REGISTER_SO(froz_key); - froz_key = scheme_make_symbol("frozen"); /* uninterned */ - scheme_add_global_constant("dump-memory-stats", scheme_make_prim_w_arity(scheme_dump_gc_stats, "dump-memory-stats", @@ -2627,6 +2624,9 @@ static void do_swap_thread() swapping = 1; #endif + if (scheme_assert_atomic) + *(long *)0x0 = 1; + if (!swap_no_setjmp && SETJMP(scheme_current_thread)) { /* We're back! */ /* See also initial swap in in start_child() */ @@ -3311,10 +3311,6 @@ Scheme_Object *scheme_thread_w_details(Scheme_Object *thunk, if (scheme_is_stack_too_shallow()) { Scheme_Thread *p = scheme_current_thread; - /* Don't mangle the stack if we're in atomic mode, because that - probably means a stack-freeze trampoline, etc. */ - wait_until_suspend_ok(1); - p->ku.k.p1 = thunk; p->ku.k.p2 = config; p->ku.k.p3 = mgr; @@ -3379,7 +3375,7 @@ Scheme_Object *scheme_call_as_nested_thread(int argc, Scheme_Object *argv[], voi SCHEME_USE_FUEL(25); - wait_until_suspend_ok(0); + scheme_wait_until_suspend_ok(); np = MALLOC_ONE_TAGGED(Scheme_Thread); np->so.type = scheme_thread_type; @@ -4051,6 +4047,43 @@ void scheme_break_thread(Scheme_Thread *p) # endif } +static void call_on_atomic_timeout(int must) +{ + Scheme_Thread *p = scheme_current_thread; + int running; + double sleep_end; + int block_descriptor; + Scheme_Object *blocker; + Scheme_Ready_Fun block_check; + Scheme_Needs_Wakeup_Fun block_needs_wakeup; + + /* Save any state that has to do with the thread blocking or + sleeping, in case scheme_on_atomic_timeout() runs Racket code. */ + + running = p->running; + sleep_end = p->sleep_end; + block_descriptor = p->block_descriptor; + blocker = p->blocker; + block_check = p->block_check; + block_needs_wakeup = p->block_needs_wakeup; + + p->running = MZTHREAD_RUNNING; + p->sleep_end = 0.0; + p->block_descriptor = 0; + p->blocker = NULL; + p->block_check = NULL; + p->block_needs_wakeup = NULL; + + scheme_on_atomic_timeout(must); + + p->running = running; + p->sleep_end = sleep_end; + p->block_descriptor = block_descriptor; + p->blocker = blocker; + p->block_check = block_check; + p->block_needs_wakeup = block_needs_wakeup; +} + static void find_next_thread(Scheme_Thread **return_arg) { Scheme_Thread *next; Scheme_Thread *p = scheme_current_thread; @@ -4212,7 +4245,7 @@ void scheme_thread_block(float sleep_time) if ((p->running & MZTHREAD_USER_SUSPENDED) && !(p->running & MZTHREAD_NEED_SUSPEND_CLEANUP)) { /* This thread was suspended. */ - wait_until_suspend_ok(0); + scheme_wait_until_suspend_ok(); if (!p->next) { /* Suspending the main thread... */ select_thread(); @@ -4311,9 +4344,9 @@ void scheme_thread_block(float sleep_time) } #endif -/*####################################*/ -/* THREAD CONTEXT SWITCH HAPPENS HERE */ -/*####################################*/ + /*####################################*/ + /* THREAD CONTEXT SWITCH HAPPENS HERE */ + /*####################################*/ if (next) { /* Swap in `next', but first clear references to other threads. */ @@ -4329,7 +4362,7 @@ void scheme_thread_block(float sleep_time) scheme_fuel_counter = p->engine_weight; scheme_jit_stack_boundary = scheme_stack_boundary; } - scheme_on_atomic_timeout(); + call_on_atomic_timeout(0); if (atomic_timeout_auto_suspend > 1) --atomic_timeout_auto_suspend; } @@ -4360,7 +4393,7 @@ void scheme_thread_block(float sleep_time) /* Suspended while I was asleep? */ if ((p->running & MZTHREAD_USER_SUSPENDED) && !(p->running & MZTHREAD_NEED_SUSPEND_CLEANUP)) { - wait_until_suspend_ok(0); + scheme_wait_until_suspend_ok(); if (!p->next) scheme_thread_block(0.0); /* main thread handled at top of this function */ else @@ -4592,22 +4625,24 @@ void scheme_end_atomic_can_break(void) scheme_check_break_now(); } -static void wait_until_suspend_ok(int for_stack) +int scheme_wait_until_suspend_ok(void) { - if (scheme_on_atomic_timeout && atomic_timeout_auto_suspend) { + int did = 0; + + if (scheme_on_atomic_timeout) { /* new-style atomic timeout */ - if (for_stack) { - /* a stack overflow is ok for the new-style timeout */ - return; - } else if (do_atomic > atomic_timeout_atomic_level) { + if (do_atomic > atomic_timeout_atomic_level) { scheme_log_abort("attempted to wait for suspend in nested atomic mode"); abort(); } } while (do_atomic && scheme_on_atomic_timeout) { - scheme_on_atomic_timeout(); + did = 1; + call_on_atomic_timeout(1); } + + return did; } Scheme_On_Atomic_Timeout_Proc scheme_set_on_atomic_timeout(Scheme_On_Atomic_Timeout_Proc p) @@ -4631,10 +4666,6 @@ void scheme_weak_suspend_thread(Scheme_Thread *r) if (r->running & MZTHREAD_SUSPENDED) return; - if (r == scheme_current_thread) { - wait_until_suspend_ok(0); - } - if (r->prev) { r->prev->next = r->next; r->next->prev = r->prev; @@ -4679,7 +4710,6 @@ void scheme_weak_resume_thread(Scheme_Thread *r) void scheme_about_to_move_C_stack(void) { - wait_until_suspend_ok(1); } static Scheme_Object * @@ -4791,7 +4821,7 @@ void scheme_kill_thread(Scheme_Thread *p) { if (do_kill_thread(p)) { /* Suspend/kill self: */ - wait_until_suspend_ok(0); + scheme_wait_until_suspend_ok(); if (p->suspend_to_kill) suspend_thread(p); else @@ -4921,7 +4951,7 @@ static void suspend_thread(Scheme_Thread *p) p->running |= MZTHREAD_USER_SUSPENDED; } else { if (p == scheme_current_thread) { - wait_until_suspend_ok(0); + scheme_wait_until_suspend_ok(); } p->running |= MZTHREAD_USER_SUSPENDED; scheme_weak_suspend_thread(p); /* ok if p is scheme_current_thread */ @@ -8081,269 +8111,6 @@ void scheme_free_gmp(void *p, void **mem_pool) *mem_pool = SCHEME_CDR(*mem_pool); } -/*========================================================================*/ -/* stack freezer */ -/*========================================================================*/ - -/* When interacting with certain libraries that can lead to Scheme - callbacks, the stack region used by the library should not be - modified by Scheme thread swaps. In that case, the callback must be - constrained. Completely disallowing synchornization with ther - threads or unbounded computation, however, is sometimes too - difficult. A stack-freezer sequence offer a compromise, where the - callback is run as much as possible, but it can be suspended to - allow the library call to return so that normal Scheme-thread - scheduling can resume. The callback is then completed in a normal - scheduling context, where it is no longer specially constrained. - - The call process is - scheme_with_stack_freeze(f, data) - -> f(data) in frozen mode - -> ... frozen_run_some(g, data2) \ - -> Scheme code, may finish or may not | maybe loop - froz->in_progress inicates whether done / - -> continue scheme if not finished - - In this process, it's the call stack between f(data) and the call - to frozen_run_some() that won't be copied in or out until f(data) - returns. - - Nesting scheme_with_stack_freeze() calls should be safe, but it - won't achieve the goal, which is to limit the amount of work done - before returning (because the inner scheme_with_stack_freeze() will - have to run to completion). */ - -static unsigned long get_deeper_base(); - -typedef struct FrozenTramp { - MZTAG_IF_REQUIRED - Scheme_Frozen_Stack_Proc do_f; - void *do_data; - int val; - int in_progress; - int progress_is_resumed; - Scheme_Object *old_param; - Scheme_Config *config; - void *progress_base_addr; - mz_jmp_buf progress_base; - Scheme_Jumpup_Buf_Holder *progress_cont; - int timer_on; - double continue_until; -#ifdef MZ_PRECISE_GC - void *fixup_var_stack_chain; -#endif -} FrozenTramp; - -int scheme_with_stack_freeze(Scheme_Frozen_Stack_Proc wha_f, void *wha_data) -{ - FrozenTramp *froz; - Scheme_Cont_Frame_Data cframe; - Scheme_Object *bx; - int retval; - Scheme_Jumpup_Buf_Holder *pc; - - froz = MALLOC_ONE_RT(FrozenTramp); - SET_REQUIRED_TAG(froz->type = scheme_rt_frozen_tramp); - - bx = scheme_make_raw_pair((Scheme_Object *)froz, NULL); - - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(froz_key, bx); - - pc = scheme_new_jmpupbuf_holder(); - froz->progress_cont = pc; - - scheme_init_jmpup_buf(&froz->progress_cont->buf); - - scheme_start_atomic(); - retval = wha_f(wha_data); - froz->val = retval; - - if (froz->in_progress) { - /* We have leftover work; jump and finish it (non-atomically). - But don't swap until we've jumped back in, because the jump-in - point might be trying to suspend the thread (and that should - complete before any swap). */ - scheme_end_atomic_no_swap(); - SCHEME_CAR(bx) = NULL; - froz->in_progress = 0; - froz->progress_is_resumed = 1; - if (!scheme_setjmp(froz->progress_base)) { -#ifdef MZ_PRECISE_GC - froz->fixup_var_stack_chain = &__gc_var_stack__; -#endif - scheme_longjmpup(&froz->progress_cont->buf); - } - } else { - scheme_end_atomic(); - } - - scheme_pop_continuation_frame(&cframe); - - froz->old_param = NULL; - froz->progress_cont = NULL; - froz->do_data = NULL; - - return froz->val; -} - -static void suspend_froz_progress(void) -{ - FrozenTramp * volatile froz; - double msecs; - Scheme_Object *v; - - v = scheme_extract_one_cc_mark(NULL, froz_key); - froz = (FrozenTramp *)SCHEME_CAR(v); - v = NULL; - - msecs = scheme_get_inexact_milliseconds(); - if (msecs < froz->continue_until) - return; - - scheme_on_atomic_timeout = NULL; - - froz->in_progress = 1; - if (scheme_setjmpup(&froz->progress_cont->buf, (void*)froz->progress_cont, froz->progress_base_addr)) { - /* we're back */ - scheme_reset_jmpup_buf(&froz->progress_cont->buf); -#ifdef MZ_PRECISE_GC - /* Base addr points to the last valid gc_var_stack address. - Fixup that link to skip over the part of the stack we're - not using right now. */ - ((void **)froz->progress_base_addr)[0] = froz->fixup_var_stack_chain; - ((void **)froz->progress_base_addr)[1] = NULL; -#endif - } else { - /* we're leaving */ - scheme_longjmp(froz->progress_base, 1); - } -} - -static void froz_run_new(FrozenTramp * volatile froz, int run_msecs) -{ - double msecs; - - /* We're willing to start new work that is specific to this thread */ - froz->progress_is_resumed = 0; - - msecs = scheme_get_inexact_milliseconds(); - froz->continue_until = msecs + run_msecs; - - if (!scheme_setjmp(froz->progress_base)) { - Scheme_Frozen_Stack_Proc do_f; - scheme_start_atomic(); - scheme_on_atomic_timeout = suspend_froz_progress; - atomic_timeout_atomic_level = -1; - do_f = froz->do_f; - do_f(froz->do_data); - } - - if (froz->progress_is_resumed) { - /* we've already returned once; jump out to new progress base */ - scheme_longjmp(froz->progress_base, 1); - } else { - scheme_on_atomic_timeout = NULL; - scheme_end_atomic_no_swap(); - } -} - -static void froz_do_run_new(FrozenTramp * volatile froz, int *iteration, int run_msecs) -{ - /* This function just makes room on the stack, eventually calling - froz_run_new(). */ - int new_iter[32]; - - if (iteration[0] == 3) { -#ifdef MZ_PRECISE_GC - froz->progress_base_addr = (void *)&__gc_var_stack__; -#else - froz->progress_base_addr = (void *)new_iter; -#endif - froz_run_new(froz, run_msecs); - } else { - new_iter[0] = iteration[0] + 1; - froz_do_run_new(froz, new_iter, run_msecs); - } -} - -int scheme_frozen_run_some(Scheme_Frozen_Stack_Proc do_f, void *do_data, int run_msecs) -{ - FrozenTramp * volatile froz; - int more = 0; - Scheme_Object *v; - - v = scheme_extract_one_cc_mark(NULL, froz_key); - if (v) - froz = (FrozenTramp *)SCHEME_CAR(v); - else - froz = NULL; - v = NULL; - - if (froz) { - if (froz->in_progress) { - /* We have work in progress. */ - if ((unsigned long)froz->progress_base_addr < get_deeper_base()) { - /* We have stack space to resume the old work: */ - double msecs; - froz->in_progress = 0; - froz->progress_is_resumed = 1; - msecs = scheme_get_inexact_milliseconds(); - froz->continue_until = msecs + run_msecs; - scheme_start_atomic(); - scheme_on_atomic_timeout = suspend_froz_progress; - atomic_timeout_atomic_level = -1; - if (!scheme_setjmp(froz->progress_base)) { -#ifdef MZ_PRECISE_GC - froz->fixup_var_stack_chain = &__gc_var_stack__; -#endif - scheme_longjmpup(&froz->progress_cont->buf); - } else { - scheme_on_atomic_timeout = NULL; - scheme_end_atomic_no_swap(); - } - } - } else { - int iter[1]; - iter[0] = 0; - froz->do_f = do_f; - froz->do_data = do_data; - froz_do_run_new(froz, iter, run_msecs); - } - - more = froz->in_progress; - } - - return more; -} - -int scheme_is_in_frozen_stack() -{ - Scheme_Object *v; - - v = scheme_extract_one_cc_mark(NULL, froz_key); - if (v) - return 1; - else - return 0; -} - -/* Disable warning for returning address of local variable: */ -#ifdef _MSC_VER -#pragma warning (disable:4172) -#endif - -static unsigned long get_deeper_base() -{ - long here; - unsigned long here_addr = (unsigned long)&here; - return here_addr; -} - -#ifdef _MSC_VER -#pragma warning (default:4172) -#endif - /*========================================================================*/ /* precise GC */ /*========================================================================*/ @@ -8396,7 +8163,6 @@ static void register_traversers(void) GC_REG_TRAV(scheme_rt_evt, mark_evt); GC_REG_TRAV(scheme_rt_syncing, mark_syncing); GC_REG_TRAV(scheme_rt_parameterization, mark_parameterization); - GC_REG_TRAV(scheme_rt_frozen_tramp, mark_frozen_tramp); } END_XFORM_SKIP; From 72d57d8db86b53adadef214fef051a78f9965bf5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 30 Nov 2010 15:39:02 -0700 Subject: [PATCH 205/255] cocoa: explicitly re-dispatch Cmd- key combinations --- collects/mred/private/wx/cocoa/menu-bar.rkt | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wx/cocoa/menu-bar.rkt b/collects/mred/private/wx/cocoa/menu-bar.rkt index b8c70ae579..3bf4b065fe 100644 --- a/collects/mred/private/wx/cocoa/menu-bar.rkt +++ b/collects/mred/private/wx/cocoa/menu-bar.rkt @@ -41,8 +41,16 @@ ;; Disable automatic handling of keyboard shortcuts, except for ;; the Apple menu (-a _BOOL (performKeyEquivalent: [_id evt]) - (and the-apple-menu - (tell #:type _BOOL the-apple-menu performKeyEquivalent: evt)))) + (or (and the-apple-menu + (tell #:type _BOOL the-apple-menu performKeyEquivalent: evt)) + ;; Explicity send the event to the keyWindow: + (let ([w (tell app keyWindow)]) + (and w + (let ([r (tell w firstResponder)]) + (and r + (begin + (tell r keyDown: evt) + #t)))))))) (define cocoa-mb (tell (tell MyBarMenu alloc) init)) (define current-mb #f) From d95e6f35c1c06ab0288898eb58252d70d6af5e2a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 30 Nov 2010 15:43:59 -0700 Subject: [PATCH 206/255] clean up --- src/racket/src/sema.c | 33 +++------------------------------ src/racket/src/thread.c | 5 ----- 2 files changed, 3 insertions(+), 35 deletions(-) diff --git a/src/racket/src/sema.c b/src/racket/src/sema.c index df7f15e7f7..4ed250633a 100644 --- a/src/racket/src/sema.c +++ b/src/racket/src/sema.c @@ -25,7 +25,6 @@ READ_ONLY Scheme_Object *scheme_always_ready_evt; THREAD_LOCAL_DECL(Scheme_Object *scheme_system_idle_channel); -extern int scheme_assert_atomic; static Scheme_Object *make_sema(int n, Scheme_Object **p); static Scheme_Object *semap(int n, Scheme_Object **p); @@ -94,7 +93,7 @@ void scheme_init_sema(Scheme_Env *env) scheme_add_global_constant("make-semaphore", scheme_make_prim_w_arity(make_sema, "make-semaphore", - 0, 2), + 0, 1), env); scheme_add_global_constant("semaphore?", scheme_make_folding_prim(semap, @@ -244,12 +243,7 @@ static Scheme_Object *make_sema(int n, Scheme_Object **p) } else v = 0; - s = scheme_make_sema(v); - - if (n > 1) - SCHEME_CPTR_FLAGS(s) |= 0x1; - - return s; + return scheme_make_sema(v); } static Scheme_Object *make_sema_repost(int n, Scheme_Object **p) @@ -322,10 +316,6 @@ void scheme_post_sema(Scheme_Object *o) } else consumed = 0; - if (!consumed) - if (SCHEME_CPTR_FLAGS(o) & 0x1) - printf("here\n"); - w->in_line = 0; w->prev = NULL; w->next = NULL; @@ -644,8 +634,6 @@ int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *synci } else start_pos = 0; - scheme_assert_atomic++; - /* Initial poll */ while (1) { i = 0; @@ -673,14 +661,11 @@ int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *synci if (!scheme_current_thread->next) break; else { - --scheme_assert_atomic; if (!scheme_wait_until_suspend_ok()) { - scheme_assert_atomic++; break; } else { /* there may have been some action on one of the waitables; try again */ - scheme_assert_atomic++; } } } else @@ -732,9 +717,7 @@ int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *synci scheme_main_was_once_suspended = 0; - scheme_assert_atomic--; scheme_block_until(out_of_line, NULL, (Scheme_Object *)a, (float)0.0); - scheme_assert_atomic++; --scheme_current_thread->suspend_break; } else { @@ -744,9 +727,7 @@ int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *synci old_nkc = (scheme_current_thread->running & MZTHREAD_NEED_KILL_CLEANUP); if (!old_nkc) scheme_current_thread->running += MZTHREAD_NEED_KILL_CLEANUP; - scheme_assert_atomic--; scheme_weak_suspend_thread(scheme_current_thread); - scheme_assert_atomic++; if (!old_nkc && (scheme_current_thread->running & MZTHREAD_NEED_KILL_CLEANUP)) scheme_current_thread->running -= MZTHREAD_NEED_KILL_CLEANUP; } @@ -794,9 +775,7 @@ int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *synci get_outof_line(semas[i], ws[i]); } - scheme_assert_atomic--; scheme_thread_block(0); /* ok if it returns multiple times */ - scheme_assert_atomic++; scheme_current_thread->ran_some = 1; /* [but why would it return multiple times?! there must have been a reason...] */ } else { @@ -838,8 +817,6 @@ int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *synci } } - scheme_assert_atomic--; - if (i == -1) { scheme_thread_block(0); /* dies or suspends */ scheme_current_thread->ran_some = 1; @@ -847,8 +824,6 @@ int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *synci if (i < n) break; - - scheme_assert_atomic++; } /* Otherwise: !syncing and someone stole the post, or we were @@ -879,7 +854,6 @@ int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *synci get_outof_line(semas[j], ws[j]); } - scheme_assert_atomic--; break; } @@ -904,8 +878,7 @@ int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *synci } /* Back to top of loop to sync again */ } - } else - scheme_assert_atomic--; + } v = i + 1; } diff --git a/src/racket/src/thread.c b/src/racket/src/thread.c index e73a2bcecf..ed8a2e5ba1 100644 --- a/src/racket/src/thread.c +++ b/src/racket/src/thread.c @@ -128,8 +128,6 @@ extern int scheme_jit_malloced; # define scheme_jit_malloced 0 #endif -int scheme_assert_atomic; - /*========================================================================*/ /* local variables and prototypes */ /*========================================================================*/ @@ -2624,9 +2622,6 @@ static void do_swap_thread() swapping = 1; #endif - if (scheme_assert_atomic) - *(long *)0x0 = 1; - if (!swap_no_setjmp && SETJMP(scheme_current_thread)) { /* We're back! */ /* See also initial swap in in start_child() */ From e627ccb5edb6e7c030325d6c62d82c170a83f06b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 30 Nov 2010 20:17:47 -0700 Subject: [PATCH 207/255] cocoa: avoid infinite loop on re-dispatch of command keys --- collects/mred/private/wx/cocoa/menu-bar.rkt | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/collects/mred/private/wx/cocoa/menu-bar.rkt b/collects/mred/private/wx/cocoa/menu-bar.rkt index 3bf4b065fe..a8c95b94c0 100644 --- a/collects/mred/private/wx/cocoa/menu-bar.rkt +++ b/collects/mred/private/wx/cocoa/menu-bar.rkt @@ -35,6 +35,7 @@ "MrEd")) (define the-apple-menu #f) +(define recurring-for-command (make-parameter #f)) (define-objc-class MyBarMenu NSMenu [] @@ -44,13 +45,16 @@ (or (and the-apple-menu (tell #:type _BOOL the-apple-menu performKeyEquivalent: evt)) ;; Explicity send the event to the keyWindow: - (let ([w (tell app keyWindow)]) - (and w - (let ([r (tell w firstResponder)]) - (and r - (begin - (tell r keyDown: evt) - #t)))))))) + (and + (not (recurring-for-command)) + (let ([w (tell app keyWindow)]) + (and w + (let ([r (tell w firstResponder)]) + (and r + (begin + (parameterize ([recurring-for-command #t]) + (tell r keyDown: evt)) + #t))))))))) (define cocoa-mb (tell (tell MyBarMenu alloc) init)) (define current-mb #f) From 5e5678b29d4fe82bb00bd99a693a3516adafacdb Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 1 Dec 2010 03:50:10 -0500 Subject: [PATCH 208/255] New Racket version 5.0.99.4. --- src/worksp/gracket/gracket.manifest | 2 +- src/worksp/gracket/gracket.rc | 8 ++++---- src/worksp/mzcom/mzcom.rc | 8 ++++---- src/worksp/mzcom/mzobj.rgs | 6 +++--- src/worksp/racket/racket.rc | 8 ++++---- src/worksp/starters/start.rc | 8 ++++---- 6 files changed, 20 insertions(+), 20 deletions(-) diff --git a/src/worksp/gracket/gracket.manifest b/src/worksp/gracket/gracket.manifest index 722786809c..75b654dae1 100644 --- a/src/worksp/gracket/gracket.manifest +++ b/src/worksp/gracket/gracket.manifest @@ -1,7 +1,7 @@ Date: Wed, 1 Dec 2010 06:51:43 -0700 Subject: [PATCH 209/255] fix namespace-anchor on non-module namespaces --- collects/tests/racket/namespac.rktl | 6 ++++++ src/racket/src/env.c | 2 +- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/collects/tests/racket/namespac.rktl b/collects/tests/racket/namespac.rktl index bf01543a9e..0ad686ad15 100644 --- a/collects/tests/racket/namespac.rktl +++ b/collects/tests/racket/namespac.rktl @@ -162,4 +162,10 @@ ;; ---------------------------------------- +(parameterize ([current-namespace (make-base-namespace)]) + (eval '(define-namespace-anchor anchor)) + (test 1 eval '(eval 1 (namespace-anchor->namespace anchor)))) + +;; ---------------------------------------- + (report-errs) diff --git a/src/racket/src/env.c b/src/racket/src/env.c index f82162c125..ecbe832838 100644 --- a/src/racket/src/env.c +++ b/src/racket/src/env.c @@ -4578,7 +4578,7 @@ static Scheme_Object *do_variable_namespace(const char *who, int tl, int argc, S return scheme_make_integer(ph); } else if (tl) { /* return env directly; need to set up */ - if (!env->phase) + if (!env->phase && env->module) scheme_prep_namespace_rename(env); } else { /* new namespace: */ From 391adfcd3a7710a75a20db2b5ca08b73cfe64582 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 1 Dec 2010 11:10:38 -0700 Subject: [PATCH 210/255] fix chaperone bug in `checked-procedure-check-and-extract' --- src/racket/src/struct.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/racket/src/struct.c b/src/racket/src/struct.c index 4f82cb1f5c..7209922a7f 100644 --- a/src/racket/src/struct.c +++ b/src/racket/src/struct.c @@ -1754,7 +1754,8 @@ Scheme_Object *scheme_extract_checked_procedure(int argc, Scheme_Object **argv) return NULL; } - if (SCHEME_CHAPERONE_STRUCTP(v) && scheme_is_struct_instance((Scheme_Object *)stype, v)) { + /* let chaperones use the slow path, for now */ + if (SCHEME_STRUCTP(v) && scheme_is_struct_instance((Scheme_Object *)stype, v)) { checker = ((Scheme_Structure *)v)->slots[0]; proc = ((Scheme_Structure *)v)->slots[1]; From de0103129bb589fd59f618e117dde432ed1a6290 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 1 Dec 2010 14:09:03 -0600 Subject: [PATCH 211/255] avoid saving the preferences on each keystroke in the find/replace dialog --- collects/framework/private/frame.rkt | 23 +++++++++++++++-------- 1 file changed, 15 insertions(+), 8 deletions(-) diff --git a/collects/framework/private/frame.rkt b/collects/framework/private/frame.rkt index 9cff288072..0e9fa3d2d9 100644 --- a/collects/framework/private/frame.rkt +++ b/collects/framework/private/frame.rkt @@ -1693,15 +1693,22 @@ (define/augment (after-delete x y) (update-prefs) (inner (void) after-delete x y)) + (define timer #f) (define/private (update-prefs) - (preferences:set pref-sym - (let loop ([snip (find-first-snip)]) - (cond - [(not snip) '()] - [(is-a? snip string-snip%) - (cons (send snip get-text 0 (send snip get-count)) - (loop (send snip next)))] - [else (cons snip (loop (send snip next)))])))) + (unless timer + (set! timer (new timer% + [notify-callback + (λ () + (preferences:set pref-sym + (let loop ([snip (find-first-snip)]) + (cond + [(not snip) '()] + [(is-a? snip string-snip%) + (cons (send snip get-text 0 (send snip get-count)) + (loop (send snip next)))] + [else (cons snip (loop (send snip next)))]))))]))) + (send timer stop) + (send timer start 150 #t)) (define/override (get-keymaps) (editor:add-after-user-keymap search/replace-keymap (super get-keymaps))) (super-new) From a1095d2fc11db997fdb52a07f695fc47a72de119 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 15 Nov 2010 13:14:07 -0500 Subject: [PATCH 212/255] Remove unnecessary argument from make-field-map. --- collects/racket/private/class-internal.rkt | 6 ++---- collects/racket/private/classidmap.rkt | 11 ++++------- 2 files changed, 6 insertions(+), 11 deletions(-) diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index 01142d85e6..fbfcd6f65c 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -1194,8 +1194,7 @@ (quote-syntax inherit-field-name) (quote-syntax inherit-field-name-localized) (quote-syntax inherit-field-accessor) - (quote-syntax inherit-field-mutator) - '()) + (quote-syntax inherit-field-mutator)) ... (make-field-map trace-flag (quote-syntax the-finder) @@ -1204,8 +1203,7 @@ (quote-syntax local-field) (quote-syntax local-field-localized) (quote-syntax local-field-accessor) - (quote-syntax local-field-mutator) - '()) + (quote-syntax local-field-mutator)) ... (make-rename-super-map (quote-syntax the-finder) (quote the-obj) diff --git a/collects/racket/private/classidmap.rkt b/collects/racket/private/classidmap.rkt index 387400790b..1faf5ee5a2 100644 --- a/collects/racket/private/classidmap.rkt +++ b/collects/racket/private/classidmap.rkt @@ -61,7 +61,7 @@ (quasisyntax/loc stx (#,replace-stx . args))]))))) (define (make-field-map trace-flag the-finder the-obj the-unwrapper the-binder the-binder-localized - field-accessor field-mutator field-pos/null) + field-accessor field-mutator) (let ([set!-stx (datum->syntax the-finder 'set!)]) (mk-set!-trans the-binder-localized @@ -74,8 +74,7 @@ [trace (syntax/loc stx (set-event obj (quote id) id))] [set (quasisyntax/loc stx ((unsyntax field-mutator) - ((unsyntax the-unwrapper) obj) - (unsyntax-splicing field-pos/null) id))]) + ((unsyntax the-unwrapper) obj) id))]) (if trace-flag (syntax/loc stx (let* bindings trace set)) (syntax/loc stx (let* bindings set))))] @@ -84,8 +83,7 @@ [trace (syntax/loc stx (get-event obj (quote id)))] [call (quasisyntax/loc stx (((unsyntax field-accessor) - ((unsyntax the-unwrapper) obj) - (unsyntax-splicing field-pos/null)) . args))]) + ((unsyntax the-unwrapper) obj)) . args))]) (if trace-flag (syntax/loc stx (let* bindings trace call)) (syntax/loc stx (let* bindings call))))] @@ -94,8 +92,7 @@ [trace (syntax/loc stx (get-event obj (quote id)))] [get (quasisyntax/loc stx ((unsyntax field-accessor) - ((unsyntax the-unwrapper) obj) - (unsyntax-splicing field-pos/null)))]) + ((unsyntax the-unwrapper) obj)))]) (if trace-flag (syntax/loc stx (let* bindings trace get)) (syntax/loc stx (let* bindings get))))])))))) From 2bd7760412ec9c8e4af8936193cb3a6cb95518b0 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 15 Nov 2010 16:06:43 -0500 Subject: [PATCH 213/255] Conversion of object/c and object-contract to use impersonators. --- collects/mzlib/private/contract-object.rkt | 28 +- collects/racket/contract/private/object.rkt | 2 +- collects/racket/private/class-internal.rkt | 337 +++++++++----------- collects/racket/private/classidmap.rkt | 11 +- collects/tests/racket/contract-test.rktl | 3 + 5 files changed, 178 insertions(+), 203 deletions(-) diff --git a/collects/mzlib/private/contract-object.rkt b/collects/mzlib/private/contract-object.rkt index d877bac100..8daded940a 100644 --- a/collects/mzlib/private/contract-object.rkt +++ b/collects/mzlib/private/contract-object.rkt @@ -281,20 +281,22 @@ ... [field-ctc-var (coerce-contract 'object-contract field-ctc-stx)] ...) - (make-contract - #:name - `(object-contract - ,(build-compound-type-name 'method-name method-ctc-var) ... - ,(build-compound-type-name 'field 'field-name field-ctc-var) ...) - #:projection - (lambda (blame) + (define ctc + (make-contract + #:name + `(object-contract + ,(build-compound-type-name 'method-name method-ctc-var) ... + ,(build-compound-type-name 'field 'field-name field-ctc-var) ...) + #:projection + (lambda (blame) + (lambda (val) + (make-wrapper-object ctc val blame + (list 'method-name ...) (list method-ctc-var ...) + (list 'field-name ...) (list field-ctc-var ...)))) + #:first-order (lambda (val) - (make-wrapper-object val blame - (list 'method-name ...) (list method-ctc-var ...) - (list 'field-name ...) (list field-ctc-var ...)))) - #:first-order - (lambda (val) - (check-object-contract val #f (list 'method-name ...) (list 'field-name ...))))))))])))) + (check-object-contract val #f (list 'method-name ...) (list 'field-name ...)))) + ctc)))))])))) (define (check-object val blame) diff --git a/collects/racket/contract/private/object.rkt b/collects/racket/contract/private/object.rkt index 82d2965149..653109102d 100644 --- a/collects/racket/contract/private/object.rkt +++ b/collects/racket/contract/private/object.rkt @@ -39,7 +39,7 @@ (λ (ctc) (λ (blame) (λ (val) - (make-wrapper-object val blame + (make-wrapper-object ctc val blame (object-contract-methods ctc) (object-contract-method-ctcs ctc) (object-contract-fields ctc) (object-contract-field-ctcs ctc))))) #:name diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index fbfcd6f65c..d7bebeb181 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -195,30 +195,6 @@ "used before its definition: ~a" orig))) -;;-------------------------------------------------------------------- -;; object wrapper for contracts -;;-------------------------------------------------------------------- - -(define-values (wrapper-object? wrapper-object-wrapped set-wrapper-object-wrapped! struct:wrapper-object) - (let-values ([(struct:wrapper-object make-wrapper-object wrapper-object? ref set!) - (make-struct-type 'raw-wrapper-object - #f - 1 - 0)]) - (values wrapper-object? - (lambda (v) (ref v 0)) - (lambda (o v) (set! o 0 v)) - struct:wrapper-object))) - -(define-values (prop:unwrap object-unwrapper) - (let-values ([(prop:unwrap pred acc) (make-struct-type-property 'prop:unwrap)]) - (values prop:unwrap acc))) - -(define (unwrap-object o) - (if (wrapper-object? o) - (wrapper-object-wrapped o) - o)) - ;;-------------------------------------------------------------------- ;; class macros ;;-------------------------------------------------------------------- @@ -1190,7 +1166,6 @@ (make-field-map trace-flag (quote-syntax the-finder) (quote the-obj) - (quote-syntax unwrap-object) (quote-syntax inherit-field-name) (quote-syntax inherit-field-name-localized) (quote-syntax inherit-field-accessor) @@ -1199,7 +1174,6 @@ (make-field-map trace-flag (quote-syntax the-finder) (quote the-obj) - (quote-syntax unwrap-object) (quote-syntax local-field) (quote-syntax local-field-localized) (quote-syntax local-field-accessor) @@ -1354,13 +1328,19 @@ ;; Methods (when given needed super-methods, etc.): #, ;; Attach srcloc (useful for profiling) (quasisyntax/loc stx - (lambda (local-field-accessor ... - local-field-mutator ... + (lambda (local-accessor + local-mutator inherit-field-accessor ... ; inherit inherit-field-mutator ... 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 #f)] + ... + [local-field-mutator + (make-struct-field-mutator local-mutator local-field-pos #f)] + ...) (syntax-parameterize ([this-param (make-this-map (quote-syntax this-id) (quote-syntax the-finder) @@ -1482,7 +1462,7 @@ (quote-syntax plain-init-name-localized))] ...) ([(local-plain-init-name) undefined] ...) (void) ; in case the body is empty - . exprs)))))))))))) + . exprs))))))))))))) ;; Not primitive: #f)))))))))))))))) @@ -1801,13 +1781,13 @@ field-width ; total number of fields field-pub-width ; total number of public fields - field-ht ; maps public field names to vector positions + field-ht ; maps public field names to (cons class pos) field-ids ; list of public field names - int-field-refs ; vector of accessors for internal field access - int-field-sets ; vector of mutators for internal field access - ext-field-refs ; vector of accessors for external field access - ext-field-sets ; vector of mutators for internal field access + int-field-ref-projs ; vector of projections for internal field access + int-field-set-projs ; vector of projections for internal field mutation + ext-field-ref-projs ; vector of projections for external field access + ext-field-set-projs ; vector of projections for internal field mutation [struct:object ; structure type for instances #:mutable] @@ -1958,25 +1938,22 @@ ;; Put new ids in table, with pos (replace field pos with accessor info later) (unless no-new-methods? - (let loop ([ids public-names][p (class-method-width super)]) - (unless (null? ids) - (when (hash-ref method-ht (car ids) #f) - (obj-error 'class* "superclass ~e already contains method: ~a~a" - super - (car ids) - (for-class name))) - (hash-set! method-ht (car ids) p) - (loop (cdr ids) (add1 p))))) + (for ([id (in-list public-names)] + [p (in-naturals (class-method-width super))]) + (when (hash-ref method-ht id #f) + (obj-error 'class* "superclass ~e already contains method: ~a~a" + super + id + (for-class name))) + (hash-set! method-ht id p))) + ;; Keep check here for early failure, will add to hashtable later in this function. (unless no-new-fields? - (let loop ([ids public-field-names][p (class-field-pub-width super)]) - (unless (null? ids) - (when (hash-ref field-ht (car ids) #f) + (for ([id (in-list public-field-names)]) + (when (hash-ref field-ht id #f) (obj-error 'class* "superclass ~e already contains field: ~a~a" super - (car ids) - (for-class name))) - (hash-set! field-ht (car ids) p) - (loop (cdr ids) (add1 p))))) + id + (for-class name))))) ;; Check that superclass has expected fields (for-each (lambda (id) @@ -2088,17 +2065,17 @@ [meth-flags (if no-method-changes? (class-meth-flags super) (make-vector method-width))] - [int-field-refs (if no-new-fields? - (class-int-field-refs super) + [int-field-ref-projs (if no-new-fields? + (class-int-field-ref-projs super) + (make-vector field-pub-width))] + [int-field-set-projs (if no-new-fields? + (class-int-field-set-projs super) (make-vector field-pub-width))] - [int-field-sets (if no-new-fields? - (class-int-field-sets super) + [ext-field-ref-projs (if no-new-fields? + (class-ext-field-ref-projs super) (make-vector field-pub-width))] - [ext-field-refs (if no-new-fields? - (class-ext-field-refs super) - (make-vector field-pub-width))] - [ext-field-sets (if no-new-fields? - (class-ext-field-sets super) + [ext-field-set-projs (if no-new-fields? + (class-ext-field-set-projs super) (make-vector field-pub-width))] [c (class-make name (add1 (class-pos super)) @@ -2110,7 +2087,7 @@ methods super-methods int-methods beta-methods meth-flags inner-projs dynamic-idxs dynamic-projs field-width field-pub-width field-ht field-names - int-field-refs int-field-sets ext-field-refs ext-field-sets + int-field-ref-projs int-field-set-projs ext-field-ref-projs ext-field-set-projs 'struct:object 'object? 'make-object 'field-ref 'field-set! init-args init-mode @@ -2137,7 +2114,6 @@ (if make-struct:prim (make-struct:prim c prop:object preparer dispatcher - prop:unwrap values (get-properties interfaces)) (values #f #f #f))] [(struct:object object-make object? object-field-ref object-field-set!) @@ -2152,8 +2128,7 @@ num-fields undefined ;; Map object property to class: (append - (list (cons prop:object c) - (cons prop:unwrap values)) + (list (cons prop:object c)) (if deserialize-id (list (cons prop:serializable @@ -2179,33 +2154,42 @@ (set-class-field-set!! c object-field-set!)) (unless no-new-fields? - (vector-copy! int-field-refs 0 (class-int-field-refs super)) - (vector-copy! int-field-sets 0 (class-int-field-sets super)) - (vector-copy! ext-field-refs 0 (class-ext-field-refs super)) - (vector-copy! ext-field-sets 0 (class-ext-field-sets super)) + (vector-copy! int-field-ref-projs 0 (class-int-field-ref-projs super)) + (vector-copy! int-field-set-projs 0 (class-int-field-set-projs super)) + (vector-copy! ext-field-ref-projs 0 (class-ext-field-ref-projs super)) + (vector-copy! ext-field-set-projs 0 (class-ext-field-set-projs super)) ;; For public fields, set both the internal and external accessors/mutators. (for ([n (in-range (class-field-pub-width super) field-pub-width)] [i (in-naturals)] [id (in-list public-field-names)]) - (vector-set! int-field-refs n (make-struct-field-accessor object-field-ref i #f)) - (vector-set! int-field-sets n (make-struct-field-mutator object-field-set! i #f)) - (vector-set! ext-field-refs n (make-struct-field-accessor object-field-ref i id)) - (vector-set! ext-field-sets n (make-struct-field-mutator object-field-set! i id)))) + (vector-set! int-field-ref-projs n values) + (vector-set! int-field-set-projs n values) + (vector-set! ext-field-ref-projs n values) + (vector-set! ext-field-set-projs n values))) ;; --- Build field accessors and mutators --- ;; Use public field names to name the accessors and mutators - (let-values ([(local-accessors local-mutators) - (values (for/list ([n (in-range num-fields)]) - (make-struct-field-accessor object-field-ref n #f)) - (for/list ([n (in-range num-fields)]) - (make-struct-field-mutator object-field-set! n #f)))] - [(inh-accessors inh-mutators) + (let-values ([(inh-accessors inh-mutators) (values (map (lambda (id) - (vector-ref int-field-refs (hash-ref field-ht id))) + (let* ([cls/index (hash-ref field-ht id)] + [accessor + (make-struct-field-accessor (class-field-ref (car cls/index)) (cadr cls/index) #f)] + [access-proj (vector-ref int-field-ref-projs (cddr cls/index))]) + (λ (o) (access-proj (accessor o))))) inherit-field-names) (map (lambda (id) - (vector-ref int-field-sets (hash-ref field-ht id))) + (let* ([cls/index (hash-ref field-ht id)] + [mutator + (make-struct-field-mutator (class-field-set! (car cls/index)) (cadr cls/index) #f)] + [mutate-proj (vector-ref int-field-set-projs (cddr cls/index))]) + (λ (o v) (mutator o (mutate-proj v))))) inherit-field-names))]) + ;; Add class/index pairs for public fields. + (unless no-new-fields? + (let ([sup-count (class-field-pub-width super)]) + (for ([id (in-list public-field-names)] + [i (in-naturals)]) + (hash-set! field-ht id (cons c (cons i (+ i sup-count))))))) ;; -- Extract superclass methods and make rename-inners --- (let ([rename-supers (map (lambda (index mname) @@ -2300,10 +2284,8 @@ ;; -- Get new methods and initializers -- (let-values ([(new-methods override-methods augride-methods init) - (apply make-methods - (append local-accessors - local-mutators - inh-accessors + (apply make-methods object-field-ref object-field-set! + (append inh-accessors inh-mutators rename-supers rename-inners @@ -2493,7 +2475,7 @@ (make-struct-type 'props struct-type 0 0 #f props #f)]) struct:)))) -(define-values (prop:object object? object-ref) (make-struct-type-property 'object)) +(define-values (prop:object object? object-ref) (make-struct-type-property 'object 'can-impersonate)) ;;-------------------------------------------------------------------- ;; class/c @@ -2632,18 +2614,18 @@ (make-vector method-width))] [field-pub-width (class-field-pub-width cls)] [field-ht (class-field-ht cls)] - [int-field-refs (if (null? (class/c-inherit-fields ctc)) - (class-int-field-refs cls) - (make-vector field-pub-width))] - [int-field-sets (if (null? (class/c-inherit-fields ctc)) - (class-int-field-sets cls) - (make-vector field-pub-width))] - [ext-field-refs (if (null? (class/c-fields ctc)) - (class-ext-field-refs cls) - (make-vector field-pub-width))] - [ext-field-sets (if (null? (class/c-fields ctc)) - (class-ext-field-sets cls) - (make-vector field-pub-width))] + [int-field-ref-projs (if (null? (class/c-inherit-fields ctc)) + (class-int-field-ref-projs cls) + (make-vector field-pub-width))] + [int-field-set-projs (if (null? (class/c-inherit-fields ctc)) + (class-int-field-set-projs cls) + (make-vector field-pub-width))] + [ext-field-ref-projs (if (null? (class/c-fields ctc)) + (class-ext-field-ref-projs cls) + (make-vector field-pub-width))] + [ext-field-set-projs (if (null? (class/c-fields ctc)) + (class-ext-field-set-projs cls) + (make-vector field-pub-width))] [init (class-init cls)] [class-make (if name (make-naming-constructor @@ -2675,10 +2657,10 @@ field-ht (class-field-ids cls) - int-field-refs - int-field-sets - ext-field-refs - ext-field-sets + int-field-ref-projs + int-field-set-projs + ext-field-ref-projs + ext-field-set-projs 'struct:object 'object? 'make-object 'field-ref 'field-set! @@ -2713,8 +2695,7 @@ 0 ;; No new fields in this class replacement undefined ;; Map object property to class: - (list (cons prop:object c) - (cons prop:unwrap values)))]) + (list (cons prop:object c)))]) (set-class-struct:object! c struct:object) (set-class-object?! c object?) (set-class-make-object! c object-make) @@ -2759,39 +2740,35 @@ ;; Handle external field contracts (unless (null? (class/c-fields ctc)) - (vector-copy! ext-field-refs 0 (class-ext-field-refs cls)) - (vector-copy! ext-field-sets 0 (class-ext-field-sets cls)) + (vector-copy! ext-field-ref-projs 0 (class-ext-field-ref-projs cls)) + (vector-copy! ext-field-set-projs 0 (class-ext-field-set-projs cls)) (let ([bset (blame-swap blame)]) (for ([f (in-list (class/c-fields ctc))] [c (in-list (class/c-field-contracts ctc))]) (when c - (let* ([i (hash-ref field-ht f)] + (let* ([i (cddr (hash-ref field-ht f))] [p-pos ((contract-projection c) blame)] [p-neg ((contract-projection c) bset)] - [old-ref (vector-ref ext-field-refs i)] - [old-set (vector-ref ext-field-sets i)]) - (vector-set! ext-field-refs i - (λ (o) (p-pos (old-ref o)))) - (vector-set! ext-field-sets i - (λ (o v) (old-set o (p-neg v))))))))) + [old-ref-proj (vector-ref ext-field-ref-projs i)] + [old-set-proj (vector-ref ext-field-set-projs i)]) + (vector-set! ext-field-ref-projs i (compose p-pos old-ref-proj)) + (vector-set! ext-field-set-projs i (compose old-set-proj p-neg))))))) ;; Handle internal field contracts (unless (null? (class/c-inherit-fields ctc)) - (vector-copy! int-field-refs 0 (class-int-field-refs cls)) - (vector-copy! int-field-sets 0 (class-int-field-sets cls)) + (vector-copy! int-field-ref-projs 0 (class-int-field-ref-projs cls)) + (vector-copy! int-field-set-projs 0 (class-int-field-set-projs cls)) (let ([bset (blame-swap blame)]) (for ([f (in-list (class/c-inherit-fields ctc))] [c (in-list (class/c-inherit-field-contracts ctc))]) (when c - (let* ([i (hash-ref field-ht f)] + (let* ([i (cddr (hash-ref field-ht f))] [p-pos ((contract-projection c) blame)] [p-neg ((contract-projection c) bset)] - [old-ref (vector-ref int-field-refs i)] - [old-set (vector-ref int-field-sets i)]) - (vector-set! int-field-refs i - (λ (o) (p-pos (old-ref o)))) - (vector-set! int-field-sets i - (λ (o v) (old-set o (p-neg v))))))))) + [old-ref-proj (vector-ref int-field-ref-projs i)] + [old-set-proj (vector-ref int-field-set-projs i)]) + (vector-set! int-field-ref-projs i (compose p-pos old-ref-proj)) + (vector-set! int-field-set-projs i (compose old-set-proj p-neg))))))) ;; Now the trickiest of them all, internal dynamic dispatch. ;; First we update any dynamic indexes, as applicable. @@ -3163,7 +3140,7 @@ (λ (blame) (λ (obj) (check-object-contract obj blame (object/c-methods ctc) (object/c-fields ctc)) - (make-wrapper-object obj blame + (make-wrapper-object ctc obj blame (object/c-methods ctc) (object/c-method-contracts ctc) (object/c-fields ctc) (object/c-field-contracts ctc))))) @@ -3425,7 +3402,7 @@ (vector-set! (class-supers object%) 0 object%) (set-class-orig-cls! object% object%) (let*-values ([(struct:obj make-obj obj? -get -set!) - (make-struct-type 'object #f 0 0 #f (list (cons prop:object object%) (cons prop:unwrap values)) #f)]) + (make-struct-type 'object #f 0 0 #f (list (cons prop:object object%)) #f)]) (set-class-struct:object! object% struct:obj) (set-class-make-object! object% make-obj)) (set-class-object?! object% object?) ; don't use struct pred; it wouldn't work with prim classes @@ -3806,16 +3783,20 @@ name (for-class (class-name class))))))]) (values (λ (class name) - (let* ([p (check-and-get-index 'class-field-accessor class name)] - [ref (vector-ref (class-ext-field-refs class) p)]) + (let* ([cls/index (check-and-get-index 'class-field-accessor class name)] + [field-ref (class-field-ref (car cls/index))] + [field-pos (cadr cls/index)] + [proj (vector-ref (class-ext-field-ref-projs class) (cddr cls/index))]) (λ (o) (if (object? o) - (ref (unwrap-object o)) + (proj (field-ref o field-pos)) (raise-type-error 'class-field-accessor "object" o))))) (λ (class name) - (let* ([p (check-and-get-index 'class-field-mutator class name)] - [set (vector-ref (class-ext-field-sets class) p)]) + (let* ([cls/index (check-and-get-index 'class-field-mutator class name)] + [field-set! (class-field-set! (car cls/index))] + [field-pos (cadr cls/index)] + [proj (vector-ref (class-ext-field-set-projs class) (cddr cls/index))]) (λ (o v) (if (object? o) - (set (unwrap-object o) v) + (field-set! o field-pos (proj v)) (raise-type-error 'class-field-mutator "object" o)))))))) (define-struct generic (name applicable)) @@ -3967,9 +3948,12 @@ (trace (set-event obj id val)) (let* ([cls (object-ref obj)] [field-ht (class-field-ht cls)] - [index (hash-ref field-ht id #f)]) - (if index - ((vector-ref (class-ext-field-sets cls) index) obj val) + [cls/index (hash-ref field-ht id #f)]) + (if cls/index + (let ([field-set! (class-field-set! (car cls/index))] + [field-pos (cadr cls/index)] + [proj (vector-ref (class-ext-field-set-projs cls) (cddr cls/index))]) + (field-set! obj field-pos (proj val))) (raise-mismatch-error 'get-field (format "expected an object that has a field named ~s, got " id) @@ -4003,9 +3987,12 @@ (trace (get-event obj id)) (let* ([cls (object-ref obj)] [field-ht (class-field-ht cls)] - [index (hash-ref field-ht id #f)]) - (if index - ((vector-ref (class-ext-field-refs cls) index) obj) + [cls/index (hash-ref field-ht id #f)]) + (if cls/index + (let ([field-ref (class-field-ref (car cls/index))] + [field-pos (cadr cls/index)] + [proj (vector-ref (class-ext-field-ref-projs cls) (cddr cls/index))]) + (proj (field-ref obj field-pos))) (raise-mismatch-error 'get-field (format "expected an object that has a field named ~s, got " id) @@ -4143,8 +4130,8 @@ (trace (when (object? v) (inspect-event v))) (cond [(not (object? v)) #f] - [(class? c) ((class-object? (class-orig-cls c)) (unwrap-object v))] - [(interface? c) (implementation? (object-ref (unwrap-object v)) c)] + [(class? c) ((class-object? (class-orig-cls c)) v)] + [(interface? c) (implementation? (object-ref v) c)] [else (raise-type-error 'is-a? "class or interface" 1 v c)]))) (define (subclass? v c) @@ -4162,7 +4149,7 @@ (raise-type-error 'object-interface "object" o)) (trace-begin (trace (inspect-event o)) - (class-self-interface (object-ref (unwrap-object o))))) + (class-self-interface (object-ref o)))) (define-traced (object-method-arity-includes? o name cnt) (unless (object? o) @@ -4221,10 +4208,10 @@ (raise-type-error 'object-info "object" o)) (trace-begin (trace (inspect-event o)) - (let loop ([c (object-ref (unwrap-object o))] + (let loop ([c (object-ref o)] [skipped? #f]) (if (struct? ((class-insp-mk c))) - ;; current inspector can inspect this object + ;; current objec can inspect this object (values c skipped?) (if (zero? (class-pos c)) (values #f #t) @@ -4261,7 +4248,7 @@ (raise-type-error 'object->vector "object" in-o)) (trace-begin (trace (inspect-event in-o)) - (let ([o (unwrap-object in-o)]) + (let ([o in-o]) (list->vector (cons (string->symbol (format "object:~a" (class-name (object-ref o)))) @@ -4288,8 +4275,7 @@ (raise-type-error 'object=? "object" o1)) (unless (object? o2) (raise-type-error 'object=? "object" o2)) - (eq? (unwrap-object o1) - (unwrap-object o2))) + (or (impersonator-of? o1 o2) (impersonator-of? o2 o1))) ;;-------------------------------------------------------------------- ;; primitive classes @@ -4390,7 +4376,7 @@ ;; wrapper for contracts ;;-------------------------------------------------------------------- -(define (make-wrapper-class obj cls blame methods method-contracts fields field-contracts) +(define (make-wrapper-class cls blame methods method-contracts fields field-contracts) (let* ([name (class-name cls)] [method-width (class-method-width cls)] [method-ht (class-method-ht cls)] @@ -4399,10 +4385,12 @@ (make-vector method-width))] [field-pub-width (class-field-pub-width cls)] [field-ht (class-field-ht cls)] - [int-field-refs (make-vector field-pub-width)] - [int-field-sets (make-vector field-pub-width)] - [ext-field-refs (make-vector field-pub-width)] - [ext-field-sets (make-vector field-pub-width)] + [ext-field-ref-projs (if (null? fields) + (class-ext-field-ref-projs cls) + (make-vector field-pub-width))] + [ext-field-set-projs (if (null? fields) + (class-ext-field-set-projs cls) + (make-vector field-pub-width))] [class-make (if name (make-naming-constructor struct:class @@ -4433,10 +4421,10 @@ field-ht (class-field-ids cls) - int-field-refs - int-field-sets - ext-field-refs - ext-field-sets + (class-int-field-ref-projs cls) + (class-int-field-set-projs cls) + ext-field-ref-projs + ext-field-set-projs 'struct:object 'object? 'make-object 'field-ref 'field-set! @@ -4465,13 +4453,12 @@ ;; --- Make the new object struct --- (let-values ([(struct:object object-make object? object-field-ref object-field-set!) (make-struct-type obj-name - struct:wrapper-object + (class-struct:object cls) 0 ;; No init fields - 0 ;; No new fields in this wrapped object + 0 ;; No new fields in this class replacement undefined ;; Map object property to class: - (list (cons prop:object c) - (cons prop:unwrap wrapper-object-wrapped)))]) + (list (cons prop:object c)))]) (set-class-struct:object! c struct:object) (set-class-object?! c object?) (set-class-make-object! c object-make) @@ -4490,45 +4477,31 @@ [p ((contract-projection c) blame)]) (vector-set! meths i (make-method (p (vector-ref meths i)) m)))))) - ;; Redirect internal/external field accessors/mutators to old object - (let ([old-int-refs (class-int-field-refs cls)] - [old-int-sets (class-int-field-sets cls)] - [old-ext-refs (class-ext-field-refs cls)] - [old-ext-sets (class-ext-field-sets cls)]) - (for ([n (in-range (class-field-pub-width cls))]) - (let ([int-field-ref (vector-ref old-int-refs n)] - [int-field-set (vector-ref old-int-sets n)] - [ext-field-ref (vector-ref old-ext-refs n)] - [ext-field-set (vector-ref old-ext-sets n)]) - (vector-set! int-field-refs n (λ (o) (int-field-ref obj))) - (vector-set! int-field-sets n (λ (o v) (int-field-set obj v))) - (vector-set! ext-field-refs n (λ (o) (ext-field-ref obj))) - (vector-set! ext-field-sets n (λ (o v) (ext-field-set obj v)))))) - ;; Handle external field contracts (unless (null? fields) + (let ([old-ext-ref-projs (class-ext-field-ref-projs cls)] + [old-ext-set-projs (class-ext-field-set-projs cls)]) + (vector-copy! ext-field-ref-projs 0 old-ext-ref-projs) + (vector-copy! ext-field-set-projs 0 old-ext-set-projs)) (let ([bset (blame-swap blame)]) (for ([f (in-list fields)] [c (in-list field-contracts)]) (when c - (let* ([i (hash-ref field-ht f)] + (let* ([i (cddr (hash-ref field-ht f))] [p-pos ((contract-projection c) blame)] [p-neg ((contract-projection c) bset)] - [old-ref (vector-ref ext-field-refs i)] - [old-set (vector-ref ext-field-sets i)]) - (vector-set! ext-field-refs i - (λ (o) (p-pos (old-ref o)))) - (vector-set! ext-field-sets i - (λ (o v) (old-set o (p-neg v))))))))) + [old-ref (vector-ref ext-field-ref-projs i)] + [old-set (vector-ref ext-field-set-projs i)]) + (vector-set! ext-field-ref-projs i (compose p-pos old-ref)) + (vector-set! ext-field-set-projs i (compose old-set p-neg))))))) c)) -;; make-wrapper-object: object (listof symbol) (listof contract?) (listof symbol) (listof contract?) -(define (make-wrapper-object obj blame methods method-contracts fields field-contracts) +;; make-wrapper-object: contract object blame (listof symbol) (listof contract?) (listof symbol) (listof contract?) +(define (make-wrapper-object ctc obj blame methods method-contracts fields field-contracts) (check-object-contract obj blame methods fields) - (let* ([orig-obj (unwrap-object obj)] - [new-cls (make-wrapper-class orig-obj (object-ref obj) blame methods method-contracts fields field-contracts)]) - ((class-make-object new-cls) orig-obj))) + (let* ([new-cls (make-wrapper-class (object-ref obj) blame methods method-contracts fields field-contracts)]) + (impersonate-struct obj object-ref (λ (o c) new-cls) impersonator-prop:contracted ctc))) ;;-------------------------------------------------------------------- ;; misc utils diff --git a/collects/racket/private/classidmap.rkt b/collects/racket/private/classidmap.rkt index 1faf5ee5a2..f05a0cf781 100644 --- a/collects/racket/private/classidmap.rkt +++ b/collects/racket/private/classidmap.rkt @@ -60,7 +60,7 @@ [(f . args) (quasisyntax/loc stx (#,replace-stx . args))]))))) -(define (make-field-map trace-flag the-finder the-obj the-unwrapper the-binder the-binder-localized +(define (make-field-map trace-flag the-finder the-obj the-binder the-binder-localized field-accessor field-mutator) (let ([set!-stx (datum->syntax the-finder 'set!)]) (mk-set!-trans @@ -73,8 +73,7 @@ (with-syntax ([bindings (syntax/loc stx ([obj obj-expr] [id expr]))] [trace (syntax/loc stx (set-event obj (quote id) id))] [set (quasisyntax/loc stx - ((unsyntax field-mutator) - ((unsyntax the-unwrapper) obj) id))]) + ((unsyntax field-mutator) obj id))]) (if trace-flag (syntax/loc stx (let* bindings trace set)) (syntax/loc stx (let* bindings set))))] @@ -82,8 +81,7 @@ (with-syntax ([bindings (syntax/loc stx ([obj obj-expr]))] [trace (syntax/loc stx (get-event obj (quote id)))] [call (quasisyntax/loc stx - (((unsyntax field-accessor) - ((unsyntax the-unwrapper) obj)) . args))]) + (((unsyntax field-accessor) obj) . args))]) (if trace-flag (syntax/loc stx (let* bindings trace call)) (syntax/loc stx (let* bindings call))))] @@ -91,8 +89,7 @@ (with-syntax ([bindings (syntax/loc stx ([obj obj-expr]))] [trace (syntax/loc stx (get-event obj (quote id)))] [get (quasisyntax/loc stx - ((unsyntax field-accessor) - ((unsyntax the-unwrapper) obj)))]) + ((unsyntax field-accessor) obj))]) (if trace-flag (syntax/loc stx (let* bindings trace get)) (syntax/loc stx (let* bindings get))))])))))) diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 28e1e98fbc..aeadc3bc23 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -9940,6 +9940,9 @@ so that propagation occurs. (let ([ctc (vector/c number? number?)]) (test ctc value-contract (contract ctc (vector 4 5) 'pos 'neg))) + (let ([ctc (object-contract)]) + (test ctc value-contract (contract ctc (new object%) 'pos 'neg))) + ; ; ; From 68273cc31d5eab0fda1aba6fa3ea90fac5fa2eea Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 15 Nov 2010 17:07:38 -0500 Subject: [PATCH 214/255] Change field reference/mutation to use unsafe ops instead. --- collects/racket/private/class-internal.rkt | 32 ++++++++++------------ 1 file changed, 14 insertions(+), 18 deletions(-) diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index d7bebeb181..73db59d816 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -6,6 +6,7 @@ (only-in racket/contract/private/arrow making-a-method) racket/list racket/stxparam + racket/unsafe/ops "class-events.rkt" "serialize-structs.rkt" "define-struct.rkt" @@ -2172,24 +2173,23 @@ (let-values ([(inh-accessors inh-mutators) (values (map (lambda (id) (let* ([cls/index (hash-ref field-ht id)] - [accessor - (make-struct-field-accessor (class-field-ref (car cls/index)) (cadr cls/index) #f)] + [idx (cadr cls/index)] [access-proj (vector-ref int-field-ref-projs (cddr cls/index))]) - (λ (o) (access-proj (accessor o))))) + (λ (o) (access-proj (unsafe-struct-ref o idx))))) inherit-field-names) (map (lambda (id) (let* ([cls/index (hash-ref field-ht id)] - [mutator - (make-struct-field-mutator (class-field-set! (car cls/index)) (cadr cls/index) #f)] + [idx (cadr cls/index)] [mutate-proj (vector-ref int-field-set-projs (cddr cls/index))]) - (λ (o v) (mutator o (mutate-proj v))))) + (λ (o v) (unsafe-struct-set! o idx (mutate-proj v))))) inherit-field-names))]) ;; Add class/index pairs for public fields. (unless no-new-fields? - (let ([sup-count (class-field-pub-width super)]) + (let ([sup-count (class-field-width super)] + [sup-pub-count (class-field-pub-width super)]) (for ([id (in-list public-field-names)] [i (in-naturals)]) - (hash-set! field-ht id (cons c (cons i (+ i sup-count))))))) + (hash-set! field-ht id (cons c (cons (+ i sup-count) (+ i sup-pub-count))))))) ;; -- Extract superclass methods and make rename-inners --- (let ([rename-supers (map (lambda (index mname) @@ -3784,19 +3784,17 @@ (for-class (class-name class))))))]) (values (λ (class name) (let* ([cls/index (check-and-get-index 'class-field-accessor class name)] - [field-ref (class-field-ref (car cls/index))] [field-pos (cadr cls/index)] [proj (vector-ref (class-ext-field-ref-projs class) (cddr cls/index))]) (λ (o) (if (object? o) - (proj (field-ref o field-pos)) + (proj (unsafe-struct-ref o field-pos)) (raise-type-error 'class-field-accessor "object" o))))) (λ (class name) (let* ([cls/index (check-and-get-index 'class-field-mutator class name)] - [field-set! (class-field-set! (car cls/index))] [field-pos (cadr cls/index)] [proj (vector-ref (class-ext-field-set-projs class) (cddr cls/index))]) (λ (o v) (if (object? o) - (field-set! o field-pos (proj v)) + (unsafe-struct-set! o field-pos (proj v)) (raise-type-error 'class-field-mutator "object" o)))))))) (define-struct generic (name applicable)) @@ -3950,10 +3948,9 @@ [field-ht (class-field-ht cls)] [cls/index (hash-ref field-ht id #f)]) (if cls/index - (let ([field-set! (class-field-set! (car cls/index))] - [field-pos (cadr cls/index)] + (let ([field-pos (cadr cls/index)] [proj (vector-ref (class-ext-field-set-projs cls) (cddr cls/index))]) - (field-set! obj field-pos (proj val))) + (unsafe-struct-set! obj field-pos (proj val))) (raise-mismatch-error 'get-field (format "expected an object that has a field named ~s, got " id) @@ -3989,10 +3986,9 @@ [field-ht (class-field-ht cls)] [cls/index (hash-ref field-ht id #f)]) (if cls/index - (let ([field-ref (class-field-ref (car cls/index))] - [field-pos (cadr cls/index)] + (let ([field-pos (cadr cls/index)] [proj (vector-ref (class-ext-field-ref-projs cls) (cddr cls/index))]) - (proj (field-ref obj field-pos))) + (proj (unsafe-struct-ref obj field-pos))) (raise-mismatch-error 'get-field (format "expected an object that has a field named ~s, got " id) From 1b1d4d9336cfb411bb809af716b900de519a9907 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 16 Nov 2010 02:17:22 -0500 Subject: [PATCH 215/255] Use a unary identity function instead of values for better performance. --- collects/racket/private/class-internal.rkt | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index 73db59d816..8e1cc62af9 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -2159,14 +2159,14 @@ (vector-copy! int-field-set-projs 0 (class-int-field-set-projs super)) (vector-copy! ext-field-ref-projs 0 (class-ext-field-ref-projs super)) (vector-copy! ext-field-set-projs 0 (class-ext-field-set-projs super)) - ;; For public fields, set both the internal and external accessors/mutators. + ;; For new public fields, set both the internal and external accessors/mutator + ;; projections to the identity function. (for ([n (in-range (class-field-pub-width super) field-pub-width)] - [i (in-naturals)] - [id (in-list public-field-names)]) - (vector-set! int-field-ref-projs n values) - (vector-set! int-field-set-projs n values) - (vector-set! ext-field-ref-projs n values) - (vector-set! ext-field-set-projs n values))) + [i (in-naturals)]) + (vector-set! int-field-ref-projs n identity) + (vector-set! int-field-set-projs n identity) + (vector-set! ext-field-ref-projs n identity) + (vector-set! ext-field-set-projs n identity))) ;; --- Build field accessors and mutators --- ;; Use public field names to name the accessors and mutators @@ -2306,9 +2306,9 @@ (vector-set! super-methods index method) (vector-set! int-methods index (vector method)) (vector-set! beta-methods index (vector)) - (vector-set! inner-projs index values) + (vector-set! inner-projs index identity) (vector-set! dynamic-idxs index 0) - (vector-set! dynamic-projs index (vector values))) + (vector-set! dynamic-projs index (vector identity))) (append new-augonly-indices new-final-indices new-normal-indices) new-methods) ;; Override old methods: @@ -2362,7 +2362,7 @@ (let ([v (list->vector (append (vector->list (vector-ref beta-methods index)) (list #f)))]) ;; Since this starts a new part of the chain, reset the projection. - (vector-set! inner-projs index values) + (vector-set! inner-projs index identity) (vector-set! beta-methods index v)))) augonly-names) ;; Mark final methods: @@ -2793,7 +2793,7 @@ [old-int-vec (vector-ref int-methods i)]) (vector-set! dynamic-idxs i new-idx) (vector-copy! new-proj-vec 0 old-proj-vec) - (vector-set! new-proj-vec new-idx values) + (vector-set! new-proj-vec new-idx identity) (vector-set! dynamic-projs i new-proj-vec) (vector-copy! new-int-vec 0 old-int-vec) ;; Just copy over the last entry here. We'll From 2d655b6fe13ec41e7d98bd0503eb1e3c49675076 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 16 Nov 2010 12:33:18 -0500 Subject: [PATCH 216/255] Combine all field information back into one hash table. Each entry in the field info hashtable contains the following: - The absolute position of the field in object structs - The internal and external ref and set! projections Appropriate operations for extending the internal and external projections and extracting appropriate ref and set! functions are provided. --- collects/racket/private/class-internal.rkt | 776 ++++++++++----------- 1 file changed, 363 insertions(+), 413 deletions(-) diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index 8e1cc62af9..8c3520072b 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -196,6 +196,51 @@ "used before its definition: ~a" orig))) +;;-------------------------------------------------------------------- +;; field info creation/access +;;-------------------------------------------------------------------- + +;; A field-info is a (vector apos iref iset eref eset) +;; where +;; apos is the absolute position of the field in the object struct +;; used for calls to unsafe-struct-ref/-set! +;; iref, iset, eref, and eset are projections to be applied +;; on internal and external reference and setting. + +;; make-field-info creates a new field-info for a field. +;; The caller gives the absolute position, and this function fills +;; in the projections. +(define (make-field-info apos) + (vector apos identity identity identity identity)) + +(define (field-info-extend-internal! fi ppos pneg) + (unsafe-vector-set! fi 1 (compose ppos (unsafe-vector-ref fi 1))) + (unsafe-vector-set! fi 2 (compose (unsafe-vector-ref fi 2) pneg))) + +(define (field-info-extend-external! fi ppos pneg) + (unsafe-vector-set! fi 3 (compose ppos (unsafe-vector-ref fi 3))) + (unsafe-vector-set! fi 4 (compose (unsafe-vector-ref fi 4) pneg))) + +(define (field-info-internal-ref fi) + (let ([apos (unsafe-vector-ref fi 0)] + [proj (unsafe-vector-ref fi 1)]) + (λ (o) (proj (unsafe-struct-ref o apos))))) + +(define (field-info-internal-set! fi) + (let ([apos (unsafe-vector-ref fi 0)] + [proj (unsafe-vector-ref fi 2)]) + (λ (o v) (unsafe-struct-set! o apos (proj v))))) + +(define (field-info-external-ref fi) + (let ([apos (unsafe-vector-ref fi 0)] + [proj (unsafe-vector-ref fi 3)]) + (λ (o) (proj (unsafe-struct-ref o apos))))) + +(define (field-info-external-set! fi) + (let ([apos (unsafe-vector-ref fi 0)] + [proj (unsafe-vector-ref fi 4)]) + (λ (o v) (unsafe-struct-set! o apos (proj v))))) + ;;-------------------------------------------------------------------- ;; class macros ;;-------------------------------------------------------------------- @@ -1782,14 +1827,9 @@ field-width ; total number of fields field-pub-width ; total number of public fields - field-ht ; maps public field names to (cons class pos) + field-ht ; maps public field names to field-infos (see make-field-info above) field-ids ; list of public field names - int-field-ref-projs ; vector of projections for internal field access - int-field-set-projs ; vector of projections for internal field mutation - ext-field-ref-projs ; vector of projections for external field access - ext-field-set-projs ; vector of projections for internal field mutation - [struct:object ; structure type for instances #:mutable] [object? ; predicate @@ -2066,18 +2106,6 @@ [meth-flags (if no-method-changes? (class-meth-flags super) (make-vector method-width))] - [int-field-ref-projs (if no-new-fields? - (class-int-field-ref-projs super) - (make-vector field-pub-width))] - [int-field-set-projs (if no-new-fields? - (class-int-field-set-projs super) - (make-vector field-pub-width))] - [ext-field-ref-projs (if no-new-fields? - (class-ext-field-ref-projs super) - (make-vector field-pub-width))] - [ext-field-set-projs (if no-new-fields? - (class-ext-field-set-projs super) - (make-vector field-pub-width))] [c (class-make name (add1 (class-pos super)) (list->vector (append (vector->list (class-supers super)) (list #f))) @@ -2088,7 +2116,6 @@ methods super-methods int-methods beta-methods meth-flags inner-projs dynamic-idxs dynamic-projs field-width field-pub-width field-ht field-names - int-field-ref-projs int-field-set-projs ext-field-ref-projs ext-field-set-projs 'struct:object 'object? 'make-object 'field-ref 'field-set! init-args init-mode @@ -2154,42 +2181,17 @@ (set-class-field-ref! c object-field-ref) (set-class-field-set!! c object-field-set!)) - (unless no-new-fields? - (vector-copy! int-field-ref-projs 0 (class-int-field-ref-projs super)) - (vector-copy! int-field-set-projs 0 (class-int-field-set-projs super)) - (vector-copy! ext-field-ref-projs 0 (class-ext-field-ref-projs super)) - (vector-copy! ext-field-set-projs 0 (class-ext-field-set-projs super)) - ;; For new public fields, set both the internal and external accessors/mutator - ;; projections to the identity function. - (for ([n (in-range (class-field-pub-width super) field-pub-width)] - [i (in-naturals)]) - (vector-set! int-field-ref-projs n identity) - (vector-set! int-field-set-projs n identity) - (vector-set! ext-field-ref-projs n identity) - (vector-set! ext-field-set-projs n identity))) - ;; --- Build field accessors and mutators --- ;; Use public field names to name the accessors and mutators (let-values ([(inh-accessors inh-mutators) - (values (map (lambda (id) - (let* ([cls/index (hash-ref field-ht id)] - [idx (cadr cls/index)] - [access-proj (vector-ref int-field-ref-projs (cddr cls/index))]) - (λ (o) (access-proj (unsafe-struct-ref o idx))))) - inherit-field-names) - (map (lambda (id) - (let* ([cls/index (hash-ref field-ht id)] - [idx (cadr cls/index)] - [mutate-proj (vector-ref int-field-set-projs (cddr cls/index))]) - (λ (o v) (unsafe-struct-set! o idx (mutate-proj v))))) - inherit-field-names))]) + (for/lists (accs muts) ([id (in-list inherit-field-names)]) + (let ([fi (hash-ref field-ht id)]) + (values (field-info-internal-ref fi) (field-info-internal-set! fi))))]) ;; Add class/index pairs for public fields. (unless no-new-fields? - (let ([sup-count (class-field-width super)] - [sup-pub-count (class-field-pub-width super)]) - (for ([id (in-list public-field-names)] - [i (in-naturals)]) - (hash-set! field-ht id (cons c (cons (+ i sup-count) (+ i sup-pub-count))))))) + (for ([id (in-list public-field-names)] + [i (in-naturals (class-field-width super))]) + (hash-set! field-ht id (make-field-info i)))) ;; -- Extract superclass methods and make rename-inners --- (let ([rename-supers (map (lambda (index mname) @@ -2570,346 +2572,317 @@ (define (class/c-proj ctc) (λ (blame) - (λ (cls) - (class/c-check-first-order ctc cls blame) - (let* ([name (class-name cls)] - [never-wrapped? (eq? (class-orig-cls cls) cls)] - ;; Only add a new slot if we're not projecting an already contracted class. - [supers (if never-wrapped? - (list->vector (append (vector->list (class-supers cls)) - (list #f))) - (list->vector (vector->list (class-supers cls))))] - [pos (if never-wrapped? - (add1 (class-pos cls)) - (class-pos cls))] - [method-width (class-method-width cls)] - [method-ht (class-method-ht cls)] - [dynamic-features - (append (class/c-overrides ctc) - (class/c-augments ctc) - (class/c-augrides ctc) - (class/c-inherits ctc))] - [dynamic-contracts - (append (class/c-override-contracts ctc) - (class/c-augment-contracts ctc) - (class/c-augride-contracts ctc) - (class/c-inherit-contracts ctc))] - [methods (if (null? (class/c-methods ctc)) - (class-methods cls) - (make-vector method-width))] - [super-methods (if (null? (class/c-supers ctc)) - (class-super-methods cls) + (let ([bswap (blame-swap blame)]) + (λ (cls) + (class/c-check-first-order ctc cls blame) + (let* ([name (class-name cls)] + [never-wrapped? (eq? (class-orig-cls cls) cls)] + ;; Only add a new slot if we're not projecting an already contracted class. + [supers (if never-wrapped? + (list->vector (append (vector->list (class-supers cls)) + (list #f))) + (list->vector (vector->list (class-supers cls))))] + [pos (if never-wrapped? + (add1 (class-pos cls)) + (class-pos cls))] + [method-width (class-method-width cls)] + [method-ht (class-method-ht cls)] + [dynamic-features + (append (class/c-overrides ctc) + (class/c-augments ctc) + (class/c-augrides ctc) + (class/c-inherits ctc))] + [dynamic-contracts + (append (class/c-override-contracts ctc) + (class/c-augment-contracts ctc) + (class/c-augride-contracts ctc) + (class/c-inherit-contracts ctc))] + [methods (if (null? (class/c-methods ctc)) + (class-methods cls) + (make-vector method-width))] + [super-methods (if (null? (class/c-supers ctc)) + (class-super-methods cls) + (make-vector method-width))] + [int-methods (if (null? dynamic-features) + (class-int-methods cls) (make-vector method-width))] - [int-methods (if (null? dynamic-features) - (class-int-methods cls) - (make-vector method-width))] - [inner-projs (if (null? (class/c-inners ctc)) - (class-inner-projs cls) - (make-vector method-width))] - [dynamic-idxs (if (null? dynamic-features) - (class-dynamic-idxs cls) - (make-vector method-width))] - [dynamic-projs (if (null? dynamic-features) - (class-dynamic-projs cls) + [inner-projs (if (null? (class/c-inners ctc)) + (class-inner-projs cls) (make-vector method-width))] - [field-pub-width (class-field-pub-width cls)] - [field-ht (class-field-ht cls)] - [int-field-ref-projs (if (null? (class/c-inherit-fields ctc)) - (class-int-field-ref-projs cls) - (make-vector field-pub-width))] - [int-field-set-projs (if (null? (class/c-inherit-fields ctc)) - (class-int-field-set-projs cls) - (make-vector field-pub-width))] - [ext-field-ref-projs (if (null? (class/c-fields ctc)) - (class-ext-field-ref-projs cls) - (make-vector field-pub-width))] - [ext-field-set-projs (if (null? (class/c-fields ctc)) - (class-ext-field-set-projs cls) - (make-vector field-pub-width))] - [init (class-init cls)] - [class-make (if name - (make-naming-constructor - struct:class - (string->symbol (format "class:~a" name))) - make-class)] - [c (class-make name - pos - supers - (class-self-interface cls) - void ;; No inspecting - - method-width - method-ht - (class-method-ids cls) - - methods - super-methods - int-methods - (class-beta-methods cls) - (class-meth-flags cls) - - inner-projs - dynamic-idxs - dynamic-projs - - (class-field-width cls) - field-pub-width - field-ht - (class-field-ids cls) - - int-field-ref-projs - int-field-set-projs - ext-field-ref-projs - ext-field-set-projs - - 'struct:object 'object? 'make-object - 'field-ref 'field-set! - - ;; class/c introduced subclasses do not consume init args - null - 'normal - #f - - (class-orig-cls cls) - #f #f ; serializer is never set - #f)] - [obj-name (if name - (string->symbol (format "object:~a" name)) - 'object)]) - (define (make-method proc meth-name) - (procedure-rename - (procedure->method proc) - (string->symbol - (format "~a method~a~a" - meth-name - (if name " in " "") - (or name ""))))) - - (vector-set! supers pos c) - - ;; --- Make the new object struct --- - (let-values ([(struct:object object-make object? object-field-ref object-field-set!) - (make-struct-type obj-name - (class-struct:object cls) - 0 ;; No init fields - 0 ;; No new fields in this class replacement - undefined - ;; Map object property to class: - (list (cons prop:object c)))]) - (set-class-struct:object! c struct:object) - (set-class-object?! c object?) - (set-class-make-object! c object-make) - (set-class-field-ref! c object-field-ref) - (set-class-field-set!! c object-field-set!)) - - ;; Handle public method contracts - (unless (null? (class/c-methods ctc)) - ;; First, fill in from old methods - (vector-copy! methods 0 (class-methods cls)) - ;; Now apply projections - (for ([m (in-list (class/c-methods ctc))] - [c (in-list (class/c-method-contracts ctc))]) - (when c - (let ([i (hash-ref method-ht m)] - [p ((contract-projection c) blame)]) - (vector-set! methods i (make-method (p (vector-ref methods i)) m)))))) - - ;; Handle super contracts - (unless (null? (class/c-supers ctc)) - ;; First, fill in from old (possibly contracted) super methods - (vector-copy! super-methods 0 (class-super-methods cls)) - ;; Now apply projections. - (for ([m (in-list (class/c-supers ctc))] - [c (in-list (class/c-super-contracts ctc))]) - (when c - (let ([i (hash-ref method-ht m)] - [p ((contract-projection c) blame)]) - (vector-set! super-methods i (make-method (p (vector-ref super-methods i)) m)))))) - - ;; Add inner projections - (unless (null? (class/c-inners ctc)) - (vector-copy! inner-projs 0 (class-inner-projs cls)) - (let ([b (blame-swap blame)]) + [dynamic-idxs (if (null? dynamic-features) + (class-dynamic-idxs cls) + (make-vector method-width))] + [dynamic-projs (if (null? dynamic-features) + (class-dynamic-projs cls) + (make-vector method-width))] + [field-pub-width (class-field-pub-width cls)] + [no-field-ctcs? (and (null? (class/c-fields ctc)) + (null? (class/c-inherit-fields ctc)))] + [field-ht (if no-field-ctcs? + (class-field-ht cls) + (hash-copy (class-field-ht cls)))] + [init (class-init cls)] + [class-make (if name + (make-naming-constructor + struct:class + (string->symbol (format "class:~a" name))) + make-class)] + [c (class-make name + pos + supers + (class-self-interface cls) + void ;; No inspecting + + method-width + method-ht + (class-method-ids cls) + + methods + super-methods + int-methods + (class-beta-methods cls) + (class-meth-flags cls) + + inner-projs + dynamic-idxs + dynamic-projs + + (class-field-width cls) + field-pub-width + field-ht + (class-field-ids cls) + + 'struct:object 'object? 'make-object + 'field-ref 'field-set! + + ;; class/c introduced subclasses do not consume init args + null + 'normal + #f + + (class-orig-cls cls) + #f #f ; serializer is never set + #f)] + [obj-name (if name + (string->symbol (format "object:~a" name)) + 'object)]) + (define (make-method proc meth-name) + (procedure-rename + (procedure->method proc) + (string->symbol + (format "~a method~a~a" + meth-name + (if name " in " "") + (or name ""))))) + + (vector-set! supers pos c) + + ;; --- Make the new object struct --- + (let-values ([(struct:object object-make object? object-field-ref object-field-set!) + (make-struct-type obj-name + (class-struct:object cls) + 0 ;; No init fields + 0 ;; No new fields in this class replacement + undefined + ;; Map object property to class: + (list (cons prop:object c)))]) + (set-class-struct:object! c struct:object) + (set-class-object?! c object?) + (set-class-make-object! c object-make) + (set-class-field-ref! c object-field-ref) + (set-class-field-set!! c object-field-set!)) + + ;; Handle public method contracts + (unless (null? (class/c-methods ctc)) + ;; First, fill in from old methods + (vector-copy! methods 0 (class-methods cls)) + ;; Now apply projections + (for ([m (in-list (class/c-methods ctc))] + [c (in-list (class/c-method-contracts ctc))]) + (when c + (let ([i (hash-ref method-ht m)] + [p ((contract-projection c) blame)]) + (vector-set! methods i (make-method (p (vector-ref methods i)) m)))))) + + ;; Handle super contracts + (unless (null? (class/c-supers ctc)) + ;; First, fill in from old (possibly contracted) super methods + (vector-copy! super-methods 0 (class-super-methods cls)) + ;; Now apply projections. + (for ([m (in-list (class/c-supers ctc))] + [c (in-list (class/c-super-contracts ctc))]) + (when c + (let ([i (hash-ref method-ht m)] + [p ((contract-projection c) blame)]) + (vector-set! super-methods i (make-method (p (vector-ref super-methods i)) m)))))) + + ;; Add inner projections + (unless (null? (class/c-inners ctc)) + (vector-copy! inner-projs 0 (class-inner-projs cls)) (for ([m (in-list (class/c-inners ctc))] [c (in-list (class/c-inner-contracts ctc))]) (when c (let ([i (hash-ref method-ht m)] - [p ((contract-projection c) b)]) + [p ((contract-projection c) bswap)]) (vector-set! inner-projs i - (compose (vector-ref inner-projs i) p))))))) - - ;; Handle external field contracts - (unless (null? (class/c-fields ctc)) - (vector-copy! ext-field-ref-projs 0 (class-ext-field-ref-projs cls)) - (vector-copy! ext-field-set-projs 0 (class-ext-field-set-projs cls)) - (let ([bset (blame-swap blame)]) + (compose (vector-ref inner-projs i) p)))))) + + ;; Handle both internal and external field contracts + (unless no-field-ctcs? (for ([f (in-list (class/c-fields ctc))] [c (in-list (class/c-field-contracts ctc))]) (when c - (let* ([i (cddr (hash-ref field-ht f))] + (let* ([fi (hash-ref field-ht f)] [p-pos ((contract-projection c) blame)] - [p-neg ((contract-projection c) bset)] - [old-ref-proj (vector-ref ext-field-ref-projs i)] - [old-set-proj (vector-ref ext-field-set-projs i)]) - (vector-set! ext-field-ref-projs i (compose p-pos old-ref-proj)) - (vector-set! ext-field-set-projs i (compose old-set-proj p-neg))))))) - - ;; Handle internal field contracts - (unless (null? (class/c-inherit-fields ctc)) - (vector-copy! int-field-ref-projs 0 (class-int-field-ref-projs cls)) - (vector-copy! int-field-set-projs 0 (class-int-field-set-projs cls)) - (let ([bset (blame-swap blame)]) + [p-neg ((contract-projection c) bswap)]) + (field-info-extend-external! fi p-pos p-neg)))) (for ([f (in-list (class/c-inherit-fields ctc))] [c (in-list (class/c-inherit-field-contracts ctc))]) (when c - (let* ([i (cddr (hash-ref field-ht f))] + (let* ([fi (hash-ref field-ht f)] [p-pos ((contract-projection c) blame)] - [p-neg ((contract-projection c) bset)] - [old-ref-proj (vector-ref int-field-ref-projs i)] - [old-set-proj (vector-ref int-field-set-projs i)]) - (vector-set! int-field-ref-projs i (compose p-pos old-ref-proj)) - (vector-set! int-field-set-projs i (compose old-set-proj p-neg))))))) - - ;; Now the trickiest of them all, internal dynamic dispatch. - ;; First we update any dynamic indexes, as applicable. - (let ([old-idxs (class-dynamic-idxs (class-orig-cls cls))]) - (unless (null? dynamic-features) - ;; Go ahead and do all the copies here. - (vector-copy! dynamic-projs 0 (class-dynamic-projs cls)) - (vector-copy! int-methods 0 (class-int-methods cls)) - (vector-copy! dynamic-idxs 0 (class-dynamic-idxs cls)) - (for ([m (in-list dynamic-features)] - [c (in-list dynamic-contracts)]) - (when c - (let* ([i (hash-ref method-ht m)] - [old-idx (vector-ref old-idxs i)] - [new-idx (vector-ref dynamic-idxs i)]) - ;; We need to extend all the vectors, so let's do that here. - (when (= old-idx new-idx) - (let* ([new-idx (add1 old-idx)] - [new-proj-vec (make-vector (add1 new-idx))] - [old-proj-vec (vector-ref dynamic-projs i)] - [new-int-vec (make-vector (add1 new-idx))] - [old-int-vec (vector-ref int-methods i)]) - (vector-set! dynamic-idxs i new-idx) - (vector-copy! new-proj-vec 0 old-proj-vec) - (vector-set! new-proj-vec new-idx identity) - (vector-set! dynamic-projs i new-proj-vec) - (vector-copy! new-int-vec 0 old-int-vec) - ;; Just copy over the last entry here. We'll - ;; update it appropriately later. - (vector-set! new-int-vec new-idx - (vector-ref old-int-vec old-idx)) - (vector-set! int-methods i new-int-vec))))))) + [p-neg ((contract-projection c) bswap)]) + (field-info-extend-internal! fi p-pos p-neg))))) - ;; Now we handle updating override contracts... here we just - ;; update the projections, and not the methods (which we must - ;; do during class composition). - (unless (null? (class/c-overrides ctc)) - (for ([m (in-list (class/c-overrides ctc))] - [c (in-list (class/c-override-contracts ctc))]) - (when c - (let* ([i (hash-ref method-ht m)] - [p ((contract-projection c) (blame-swap blame))] - [old-idx (vector-ref old-idxs i)] - [proj-vec (vector-ref dynamic-projs i)]) - (vector-set! proj-vec old-idx - (compose (vector-ref proj-vec old-idx) p)))))) + ;; Now the trickiest of them all, internal dynamic dispatch. + ;; First we update any dynamic indexes, as applicable. + (let ([old-idxs (class-dynamic-idxs (class-orig-cls cls))]) + (unless (null? dynamic-features) + ;; Go ahead and do all the copies here. + (vector-copy! dynamic-projs 0 (class-dynamic-projs cls)) + (vector-copy! int-methods 0 (class-int-methods cls)) + (vector-copy! dynamic-idxs 0 (class-dynamic-idxs cls)) + (for ([m (in-list dynamic-features)] + [c (in-list dynamic-contracts)]) + (when c + (let* ([i (hash-ref method-ht m)] + [old-idx (vector-ref old-idxs i)] + [new-idx (vector-ref dynamic-idxs i)]) + ;; We need to extend all the vectors, so let's do that here. + (when (= old-idx new-idx) + (let* ([new-idx (add1 old-idx)] + [new-proj-vec (make-vector (add1 new-idx))] + [old-proj-vec (vector-ref dynamic-projs i)] + [new-int-vec (make-vector (add1 new-idx))] + [old-int-vec (vector-ref int-methods i)]) + (vector-set! dynamic-idxs i new-idx) + (vector-copy! new-proj-vec 0 old-proj-vec) + (vector-set! new-proj-vec new-idx identity) + (vector-set! dynamic-projs i new-proj-vec) + (vector-copy! new-int-vec 0 old-int-vec) + ;; Just copy over the last entry here. We'll + ;; update it appropriately later. + (vector-set! new-int-vec new-idx + (vector-ref old-int-vec old-idx)) + (vector-set! int-methods i new-int-vec))))))) + + ;; Now we handle updating override contracts... here we just + ;; update the projections, and not the methods (which we must + ;; do during class composition). + (unless (null? (class/c-overrides ctc)) + (for ([m (in-list (class/c-overrides ctc))] + [c (in-list (class/c-override-contracts ctc))]) + (when c + (let* ([i (hash-ref method-ht m)] + [p ((contract-projection c) bswap)] + [old-idx (vector-ref old-idxs i)] + [proj-vec (vector-ref dynamic-projs i)]) + (vector-set! proj-vec old-idx + (compose (vector-ref proj-vec old-idx) p)))))) + + ;; For augment and augride contracts, we both update the projection + ;; and go ahead and apply the projection to the last slot (which will + ;; only be used by later classes). + (unless (and (null? (class/c-augments ctc)) + (null? (class/c-augrides ctc))) + (for ([m (in-list (append (class/c-augments ctc) + (class/c-augrides ctc)))] + [c (in-list (append (class/c-augment-contracts ctc) + (class/c-augride-contracts ctc)))]) + (when c + (let* ([i (hash-ref method-ht m)] + [p ((contract-projection c) blame)] + [old-idx (vector-ref old-idxs i)] + [new-idx (vector-ref dynamic-idxs i)] + [proj-vec (vector-ref dynamic-projs i)] + [int-vec (vector-ref int-methods i)]) + (vector-set! proj-vec old-idx + (compose p (vector-ref proj-vec old-idx))) + (vector-set! int-vec new-idx + (make-method (p (vector-ref int-vec new-idx)) m)))))) + + ;; Now (that things have been extended appropriately) we handle + ;; inherits. + (unless (null? (class/c-inherits ctc)) + (for ([m (in-list (class/c-inherits ctc))] + [c (in-list (class/c-inherit-contracts ctc))]) + (when c + (let* ([i (hash-ref method-ht m)] + [p ((contract-projection c) blame)] + [new-idx (vector-ref dynamic-idxs i)] + [int-vec (vector-ref int-methods i)]) + (vector-set! int-vec new-idx + (make-method (p (vector-ref int-vec new-idx)) m))))))) - ;; For augment and augride contracts, we both update the projection - ;; and go ahead and apply the projection to the last slot (which will - ;; only be used by later classes). - (unless (and (null? (class/c-augments ctc)) - (null? (class/c-augrides ctc))) - (for ([m (in-list (append (class/c-augments ctc) - (class/c-augrides ctc)))] - [c (in-list (append (class/c-augment-contracts ctc) - (class/c-augride-contracts ctc)))]) - (when c - (let* ([i (hash-ref method-ht m)] - [p ((contract-projection c) blame)] - [old-idx (vector-ref old-idxs i)] - [new-idx (vector-ref dynamic-idxs i)] - [proj-vec (vector-ref dynamic-projs i)] - [int-vec (vector-ref int-methods i)]) - (vector-set! proj-vec old-idx - (compose p (vector-ref proj-vec old-idx))) - (vector-set! int-vec new-idx - (make-method (p (vector-ref int-vec new-idx)) m)))))) + ;; Unlike the others, we always want to do this, even if there are no init contracts, + ;; since we still need to handle either calling the previous class/c's init or + ;; calling continue-make-super appropriately. + (let () + ;; zip the inits and contracts together for ordered selection + (define inits+contracts (map cons (class/c-inits ctc) (class/c-init-contracts ctc))) + ;; grab all the inits+contracts that involve the same init arg + ;; (assumes that inits and contracts were sorted in class/c creation) + (define (grab-same-inits lst) + (if (null? lst) + (values null null) + (let loop ([inits/c (cdr lst)] + [prefix (list (car lst))]) + (cond + [(null? inits/c) + (values (reverse prefix) inits/c)] + [(eq? (car (car inits/c)) (car (car prefix))) + (loop (cdr inits/c) + (cons (car inits/c) prefix))] + [else (values (reverse prefix) inits/c)])))) + ;; run through the list of init-args and apply contracts for same-named + ;; init args + (define (apply-contracts inits/c init-args) + (let loop ([init-args init-args] + [inits/c inits/c] + [handled-args null]) + (cond + [(null? init-args) + (reverse handled-args)] + [(null? inits/c) + (append (reverse handled-args) init-args)] + [(eq? (car (car inits/c)) (car (car init-args))) + (let ([init-arg (car init-args)] + [p ((contract-projection (cdr (car inits/c))) bswap)]) + (loop (cdr init-args) + (cdr inits/c) + (cons (cons (car init-arg) (p (cdr init-arg))) + handled-args)))] + [else (loop (cdr init-args) + inits/c + (cons (car init-args) handled-args))]))) + (set-class-init! + c + (lambda (the-obj super-go si_c si_inited? si_leftovers init-args) + (let ([init-args + (let loop ([inits/c inits+contracts] + [handled-args init-args]) + (if (null? inits/c) + handled-args + (let-values ([(prefix suffix) (grab-same-inits inits/c)]) + (loop suffix + (apply-contracts prefix init-args)))))]) + ;; Since we never consume init args, we can ignore si_leftovers + ;; since init-args is the same. + (if never-wrapped? + (super-go the-obj si_c si_inited? init-args null null) + (init the-obj super-go si_c si_inited? init-args init-args)))))) - ;; Now (that things have been extended appropriately) we handle - ;; inherits. - (unless (null? (class/c-inherits ctc)) - (for ([m (in-list (class/c-inherits ctc))] - [c (in-list (class/c-inherit-contracts ctc))]) - (when c - (let* ([i (hash-ref method-ht m)] - [p ((contract-projection c) blame)] - [new-idx (vector-ref dynamic-idxs i)] - [int-vec (vector-ref int-methods i)]) - (vector-set! int-vec new-idx - (make-method (p (vector-ref int-vec new-idx)) m))))))) - - ;; Unlike the others, we always want to do this, even if there are no init contracts, - ;; since we still need to handle either calling the previous class/c's init or - ;; calling continue-make-super appropriately. - (let () - ;; zip the inits and contracts together for ordered selection - (define inits+contracts (map cons (class/c-inits ctc) (class/c-init-contracts ctc))) - ;; grab all the inits+contracts that involve the same init arg - ;; (assumes that inits and contracts were sorted in class/c creation) - (define (grab-same-inits lst) - (if (null? lst) - (values null null) - (let loop ([inits/c (cdr lst)] - [prefix (list (car lst))]) - (cond - [(null? inits/c) - (values (reverse prefix) inits/c)] - [(eq? (car (car inits/c)) (car (car prefix))) - (loop (cdr inits/c) - (cons (car inits/c) prefix))] - [else (values (reverse prefix) inits/c)])))) - ;; run through the list of init-args and apply contracts for same-named - ;; init args - (define (apply-contracts inits/c init-args) - (let loop ([init-args init-args] - [inits/c inits/c] - [handled-args null]) - (cond - [(null? init-args) - (reverse handled-args)] - [(null? inits/c) - (append (reverse handled-args) init-args)] - [(eq? (car (car inits/c)) (car (car init-args))) - (let ([init-arg (car init-args)] - [p ((contract-projection (cdr (car inits/c))) - (blame-swap blame))]) - (loop (cdr init-args) - (cdr inits/c) - (cons (cons (car init-arg) (p (cdr init-arg))) - handled-args)))] - [else (loop (cdr init-args) - inits/c - (cons (car init-args) handled-args))]))) - (set-class-init! - c - (lambda (the-obj super-go si_c si_inited? si_leftovers init-args) - (let ([init-args - (let loop ([inits/c inits+contracts] - [handled-args init-args]) - (if (null? inits/c) - handled-args - (let-values ([(prefix suffix) (grab-same-inits inits/c)]) - (loop suffix - (apply-contracts prefix init-args)))))]) - ;; Since we never consume init args, we can ignore si_leftovers - ;; since init-args is the same. - (if never-wrapped? - (super-go the-obj si_c si_inited? init-args null null) - (init the-obj super-go si_c si_inited? init-args init-args)))))) - - c)))) + c))))) (define-struct class/c (methods method-contracts fields field-contracts inits init-contracts @@ -3380,7 +3353,6 @@ (vector) (vector) (vector) 0 0 (make-hasheq) null - (vector) (vector) (vector) (vector) 'struct:object object? 'make-object 'field-ref-not-needed 'field-set!-not-needed @@ -3783,18 +3755,16 @@ name (for-class (class-name class))))))]) (values (λ (class name) - (let* ([cls/index (check-and-get-index 'class-field-accessor class name)] - [field-pos (cadr cls/index)] - [proj (vector-ref (class-ext-field-ref-projs class) (cddr cls/index))]) + (let* ([fi (check-and-get-index 'class-field-accessor class name)] + [ref (field-info-external-ref fi)]) (λ (o) (if (object? o) - (proj (unsafe-struct-ref o field-pos)) + (ref o) (raise-type-error 'class-field-accessor "object" o))))) (λ (class name) - (let* ([cls/index (check-and-get-index 'class-field-mutator class name)] - [field-pos (cadr cls/index)] - [proj (vector-ref (class-ext-field-set-projs class) (cddr cls/index))]) + (let* ([fi (check-and-get-index 'class-field-mutator class name)] + [setter! (field-info-external-set! fi)]) (λ (o v) (if (object? o) - (unsafe-struct-set! o field-pos (proj v)) + (setter! o v) (raise-type-error 'class-field-mutator "object" o)))))))) (define-struct generic (name applicable)) @@ -3946,11 +3916,9 @@ (trace (set-event obj id val)) (let* ([cls (object-ref obj)] [field-ht (class-field-ht cls)] - [cls/index (hash-ref field-ht id #f)]) - (if cls/index - (let ([field-pos (cadr cls/index)] - [proj (vector-ref (class-ext-field-set-projs cls) (cddr cls/index))]) - (unsafe-struct-set! obj field-pos (proj val))) + [fi (hash-ref field-ht id #f)]) + (if fi + ((field-info-external-set! fi) obj val) (raise-mismatch-error 'get-field (format "expected an object that has a field named ~s, got " id) @@ -3984,11 +3952,9 @@ (trace (get-event obj id)) (let* ([cls (object-ref obj)] [field-ht (class-field-ht cls)] - [cls/index (hash-ref field-ht id #f)]) - (if cls/index - (let ([field-pos (cadr cls/index)] - [proj (vector-ref (class-ext-field-ref-projs cls) (cddr cls/index))]) - (proj (unsafe-struct-ref obj field-pos))) + [fi (hash-ref field-ht id #f)]) + (if fi + ((field-info-external-ref fi) obj) (raise-mismatch-error 'get-field (format "expected an object that has a field named ~s, got " id) @@ -4380,13 +4346,9 @@ (class-methods cls) (make-vector method-width))] [field-pub-width (class-field-pub-width cls)] - [field-ht (class-field-ht cls)] - [ext-field-ref-projs (if (null? fields) - (class-ext-field-ref-projs cls) - (make-vector field-pub-width))] - [ext-field-set-projs (if (null? fields) - (class-ext-field-set-projs cls) - (make-vector field-pub-width))] + [field-ht (if (null? fields) + (class-field-ht cls) + (hash-copy (class-field-ht cls)))] [class-make (if name (make-naming-constructor struct:class @@ -4417,11 +4379,6 @@ field-ht (class-field-ids cls) - (class-int-field-ref-projs cls) - (class-int-field-set-projs cls) - ext-field-ref-projs - ext-field-set-projs - 'struct:object 'object? 'make-object 'field-ref 'field-set! @@ -4475,21 +4432,14 @@ ;; Handle external field contracts (unless (null? fields) - (let ([old-ext-ref-projs (class-ext-field-ref-projs cls)] - [old-ext-set-projs (class-ext-field-set-projs cls)]) - (vector-copy! ext-field-ref-projs 0 old-ext-ref-projs) - (vector-copy! ext-field-set-projs 0 old-ext-set-projs)) (let ([bset (blame-swap blame)]) (for ([f (in-list fields)] [c (in-list field-contracts)]) (when c - (let* ([i (cddr (hash-ref field-ht f))] + (let* ([fi (hash-ref field-ht f)] [p-pos ((contract-projection c) blame)] - [p-neg ((contract-projection c) bset)] - [old-ref (vector-ref ext-field-ref-projs i)] - [old-set (vector-ref ext-field-set-projs i)]) - (vector-set! ext-field-ref-projs i (compose p-pos old-ref)) - (vector-set! ext-field-set-projs i (compose old-set p-neg))))))) + [p-neg ((contract-projection c) bset)]) + (field-info-extend-external! fi p-pos p-neg)))))) c)) From c2539c0bb40ebb1ffc791cde4c2f4fef14465725 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 16 Nov 2010 15:28:52 -0500 Subject: [PATCH 217/255] Switch from using arbitrary compose to inlined unary composition. --- collects/racket/private/class-internal.rkt | 32 ++++++++++++---------- 1 file changed, 18 insertions(+), 14 deletions(-) diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index 8c3520072b..8c35c9479e 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -214,12 +214,16 @@ (vector apos identity identity identity identity)) (define (field-info-extend-internal! fi ppos pneg) - (unsafe-vector-set! fi 1 (compose ppos (unsafe-vector-ref fi 1))) - (unsafe-vector-set! fi 2 (compose (unsafe-vector-ref fi 2) pneg))) + (let ([old-ref-proj (unsafe-vector-ref fi 1)] + [old-set-proj (unsafe-vector-ref fi 2)]) + (unsafe-vector-set! fi 1 (λ (v) (ppos (old-ref-proj v)))) + (unsafe-vector-set! fi 2 (λ (v) (old-set-proj (pneg v)))))) (define (field-info-extend-external! fi ppos pneg) - (unsafe-vector-set! fi 3 (compose ppos (unsafe-vector-ref fi 3))) - (unsafe-vector-set! fi 4 (compose (unsafe-vector-ref fi 4) pneg))) + (let ([old-ref-proj (unsafe-vector-ref fi 3)] + [old-set-proj (unsafe-vector-ref fi 4)]) + (unsafe-vector-set! fi 3 (λ (v) (ppos (old-ref-proj v)))) + (unsafe-vector-set! fi 4 (λ (v) (old-set-proj (pneg v)))))) (define (field-info-internal-ref fi) (let ([apos (unsafe-vector-ref fi 0)] @@ -2722,10 +2726,10 @@ (for ([m (in-list (class/c-inners ctc))] [c (in-list (class/c-inner-contracts ctc))]) (when c - (let ([i (hash-ref method-ht m)] - [p ((contract-projection c) bswap)]) - (vector-set! inner-projs i - (compose (vector-ref inner-projs i) p)))))) + (let* ([i (hash-ref method-ht m)] + [p ((contract-projection c) bswap)] + [old-proj (vector-ref inner-projs i)]) + (vector-set! inner-projs i (λ (v) (old-proj (p v)))))))) ;; Handle both internal and external field contracts (unless no-field-ctcs? @@ -2786,9 +2790,9 @@ (let* ([i (hash-ref method-ht m)] [p ((contract-projection c) bswap)] [old-idx (vector-ref old-idxs i)] - [proj-vec (vector-ref dynamic-projs i)]) - (vector-set! proj-vec old-idx - (compose (vector-ref proj-vec old-idx) p)))))) + [proj-vec (vector-ref dynamic-projs i)] + [old-proj (vector-ref proj-vec old-idx)]) + (vector-set! proj-vec old-idx (λ (v) (old-proj (p v)))))))) ;; For augment and augride contracts, we both update the projection ;; and go ahead and apply the projection to the last slot (which will @@ -2805,9 +2809,9 @@ [old-idx (vector-ref old-idxs i)] [new-idx (vector-ref dynamic-idxs i)] [proj-vec (vector-ref dynamic-projs i)] - [int-vec (vector-ref int-methods i)]) - (vector-set! proj-vec old-idx - (compose p (vector-ref proj-vec old-idx))) + [int-vec (vector-ref int-methods i)] + [old-proj (vector-ref proj-vec old-idx)]) + (vector-set! proj-vec old-idx (λ (v) (p (old-proj v)))) (vector-set! int-vec new-idx (make-method (p (vector-ref int-vec new-idx)) m)))))) From f54f04edeed4830adc0b0b352e7902e2f9d941c0 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 16 Nov 2010 15:42:06 -0500 Subject: [PATCH 218/255] Try the old way, but with unsafe-struct-ref/set! --- collects/racket/private/class-internal.rkt | 43 ++++++++-------------- 1 file changed, 15 insertions(+), 28 deletions(-) diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index 8c35c9479e..91e3866c4c 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -211,39 +211,26 @@ ;; The caller gives the absolute position, and this function fills ;; in the projections. (define (make-field-info apos) - (vector apos identity identity identity identity)) + (let ([field-ref (λ (o) (unsafe-struct-ref o apos))] + [field-set! (λ (o v) (unsafe-struct-set! o apos v))]) + (vector field-ref field-set! field-ref field-set!))) (define (field-info-extend-internal! fi ppos pneg) - (let ([old-ref-proj (unsafe-vector-ref fi 1)] - [old-set-proj (unsafe-vector-ref fi 2)]) - (unsafe-vector-set! fi 1 (λ (v) (ppos (old-ref-proj v)))) - (unsafe-vector-set! fi 2 (λ (v) (old-set-proj (pneg v)))))) + (let ([old-ref (unsafe-vector-ref fi 0)] + [old-set! (unsafe-vector-ref fi 1)]) + (unsafe-vector-set! fi 0 (λ (o) (ppos (old-ref o)))) + (unsafe-vector-set! fi 1 (λ (o v) (old-set! o (pneg v)))))) (define (field-info-extend-external! fi ppos pneg) - (let ([old-ref-proj (unsafe-vector-ref fi 3)] - [old-set-proj (unsafe-vector-ref fi 4)]) - (unsafe-vector-set! fi 3 (λ (v) (ppos (old-ref-proj v)))) - (unsafe-vector-set! fi 4 (λ (v) (old-set-proj (pneg v)))))) + (let ([old-ref (unsafe-vector-ref fi 2)] + [old-set! (unsafe-vector-ref fi 3)]) + (unsafe-vector-set! fi 2 (λ (o) (ppos (old-ref o)))) + (unsafe-vector-set! fi 3 (λ (o v) (old-set! o (pneg v)))))) -(define (field-info-internal-ref fi) - (let ([apos (unsafe-vector-ref fi 0)] - [proj (unsafe-vector-ref fi 1)]) - (λ (o) (proj (unsafe-struct-ref o apos))))) - -(define (field-info-internal-set! fi) - (let ([apos (unsafe-vector-ref fi 0)] - [proj (unsafe-vector-ref fi 2)]) - (λ (o v) (unsafe-struct-set! o apos (proj v))))) - -(define (field-info-external-ref fi) - (let ([apos (unsafe-vector-ref fi 0)] - [proj (unsafe-vector-ref fi 3)]) - (λ (o) (proj (unsafe-struct-ref o apos))))) - -(define (field-info-external-set! fi) - (let ([apos (unsafe-vector-ref fi 0)] - [proj (unsafe-vector-ref fi 4)]) - (λ (o v) (unsafe-struct-set! o apos (proj v))))) +(define (field-info-internal-ref fi) (unsafe-vector-ref fi 0)) +(define (field-info-internal-set! fi) (unsafe-vector-ref fi 1)) +(define (field-info-external-ref fi) (unsafe-vector-ref fi 2)) +(define (field-info-external-set! fi) (unsafe-vector-ref fi 3)) ;;-------------------------------------------------------------------- ;; class macros From db66e3e95d65f08d79ff9eb123ebc95a8283bf77 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 16 Nov 2010 15:52:29 -0500 Subject: [PATCH 219/255] Now trying it with struct-field-accessors/mutators. --- collects/racket/private/class-internal.rkt | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index 91e3866c4c..4bf5b4413d 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -210,9 +210,9 @@ ;; make-field-info creates a new field-info for a field. ;; The caller gives the absolute position, and this function fills ;; in the projections. -(define (make-field-info apos) - (let ([field-ref (λ (o) (unsafe-struct-ref o apos))] - [field-set! (λ (o v) (unsafe-struct-set! o apos v))]) +(define (make-field-info cls rpos) + (let ([field-ref (make-struct-field-accessor (class-field-ref cls) rpos)] + [field-set! (make-struct-field-mutator (class-field-set! cls) rpos)]) (vector field-ref field-set! field-ref field-set!))) (define (field-info-extend-internal! fi ppos pneg) @@ -2181,8 +2181,8 @@ ;; Add class/index pairs for public fields. (unless no-new-fields? (for ([id (in-list public-field-names)] - [i (in-naturals (class-field-width super))]) - (hash-set! field-ht id (make-field-info i)))) + [i (in-naturals)]) + (hash-set! field-ht id (make-field-info c i)))) ;; -- Extract superclass methods and make rename-inners --- (let ([rename-supers (map (lambda (index mname) From 5f7099c9bd5e6a551b89a3d5d4c3049707f57a00 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 16 Nov 2010 17:54:30 -0500 Subject: [PATCH 220/255] Fix mutation of shared vectors by copying on write. --- collects/racket/private/class-internal.rkt | 43 ++++++++++++---------- 1 file changed, 24 insertions(+), 19 deletions(-) diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index 4bf5b4413d..d6e04fde2f 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -215,17 +215,25 @@ [field-set! (make-struct-field-mutator (class-field-set! cls) rpos)]) (vector field-ref field-set! field-ref field-set!))) -(define (field-info-extend-internal! fi ppos pneg) - (let ([old-ref (unsafe-vector-ref fi 0)] - [old-set! (unsafe-vector-ref fi 1)]) - (unsafe-vector-set! fi 0 (λ (o) (ppos (old-ref o)))) - (unsafe-vector-set! fi 1 (λ (o v) (old-set! o (pneg v)))))) +(define (field-info-extend-internal! field-ht f ppos pneg) + (let* ([fi (hash-ref field-ht f)] + [old-ref (unsafe-vector-ref fi 0)] + [old-set! (unsafe-vector-ref fi 1)]) + (hash-set! field-ht f + (vector (λ (o) (ppos (old-ref o))) + (λ (o v) (old-set! o (pneg v))) + (unsafe-vector-ref fi 2) + (unsafe-vector-ref fi 3))))) -(define (field-info-extend-external! fi ppos pneg) - (let ([old-ref (unsafe-vector-ref fi 2)] - [old-set! (unsafe-vector-ref fi 3)]) - (unsafe-vector-set! fi 2 (λ (o) (ppos (old-ref o)))) - (unsafe-vector-set! fi 3 (λ (o v) (old-set! o (pneg v)))))) +(define (field-info-extend-external! field-ht f ppos pneg) + (let* ([fi (hash-ref field-ht f)] + [old-ref (unsafe-vector-ref fi 2)] + [old-set! (unsafe-vector-ref fi 3)]) + (hash-set! field-ht f + (vector (unsafe-vector-ref fi 0) + (unsafe-vector-ref fi 1) + (λ (o) (ppos (old-ref o))) + (λ (o v) (old-set! o (pneg v))))))) (define (field-info-internal-ref fi) (unsafe-vector-ref fi 0)) (define (field-info-internal-set! fi) (unsafe-vector-ref fi 1)) @@ -2723,17 +2731,15 @@ (for ([f (in-list (class/c-fields ctc))] [c (in-list (class/c-field-contracts ctc))]) (when c - (let* ([fi (hash-ref field-ht f)] - [p-pos ((contract-projection c) blame)] + (let* ([p-pos ((contract-projection c) blame)] [p-neg ((contract-projection c) bswap)]) - (field-info-extend-external! fi p-pos p-neg)))) + (field-info-extend-external! field-ht f p-pos p-neg)))) (for ([f (in-list (class/c-inherit-fields ctc))] [c (in-list (class/c-inherit-field-contracts ctc))]) (when c - (let* ([fi (hash-ref field-ht f)] - [p-pos ((contract-projection c) blame)] + (let* ([p-pos ((contract-projection c) blame)] [p-neg ((contract-projection c) bswap)]) - (field-info-extend-internal! fi p-pos p-neg))))) + (field-info-extend-internal! field-ht f p-pos p-neg))))) ;; Now the trickiest of them all, internal dynamic dispatch. ;; First we update any dynamic indexes, as applicable. @@ -4427,10 +4433,9 @@ (for ([f (in-list fields)] [c (in-list field-contracts)]) (when c - (let* ([fi (hash-ref field-ht f)] - [p-pos ((contract-projection c) blame)] + (let* ([p-pos ((contract-projection c) blame)] [p-neg ((contract-projection c) bset)]) - (field-info-extend-external! fi p-pos p-neg)))))) + (field-info-extend-external! field-ht f p-pos p-neg)))))) c)) From 96db670d8c5453173b9bf92375512fc57cafbfcd Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 16 Nov 2010 19:12:22 -0500 Subject: [PATCH 221/255] Clean up first-order checking in object/c and object-contract. Use let/ec only when needed (i.e. when raise-blame-error is not used). Also remove some of the old checking functions from mzlib's object-contract code that are no longer needed now that we have unified the first-order checking. --- collects/mzlib/private/contract-object.rkt | 17 +- collects/racket/contract/private/object.rkt | 4 +- collects/racket/private/class-internal.rkt | 180 ++++++++++---------- 3 files changed, 93 insertions(+), 108 deletions(-) diff --git a/collects/mzlib/private/contract-object.rkt b/collects/mzlib/private/contract-object.rkt index 8daded940a..0188cb4069 100644 --- a/collects/mzlib/private/contract-object.rkt +++ b/collects/mzlib/private/contract-object.rkt @@ -295,21 +295,12 @@ (list 'field-name ...) (list field-ctc-var ...)))) #:first-order (lambda (val) - (check-object-contract val #f (list 'method-name ...) (list 'field-name ...)))) - ctc)))))])))) + (let/ec ret + (check-object-contract val (list 'method-name ...) (list 'field-name ...) + (λ args (ret #f))))))) + ctc))))])))) -(define (check-object val blame) - (unless (object? val) - (raise-blame-error blame val "expected an object, got ~e" val))) - -(define (check-method val method-name val-mtd-names blame) - (unless (memq method-name val-mtd-names) - (raise-blame-error blame val "expected an object with method ~s" method-name))) - -(define (field-error val field-name blame) - (raise-blame-error blame val "expected an object with field ~s" field-name)) - (define (make-mixin-contract . %/<%>s) ((and/c (flat-contract class?) (apply and/c (map sub/impl?/c %/<%>s))) diff --git a/collects/racket/contract/private/object.rkt b/collects/racket/contract/private/object.rkt index 653109102d..23132838d8 100644 --- a/collects/racket/contract/private/object.rkt +++ b/collects/racket/contract/private/object.rkt @@ -53,7 +53,9 @@ #:first-order (λ (ctc) (λ (val) - (check-object-contract val #f (object-contract-methods ctc) (object-contract-fields ctc)))))) + (let/ec ret + (check-object-contract val (object-contract-methods ctc) (object-contract-fields ctc) + (λ args (ret #f)))))))) (define-syntax (object-contract stx) (syntax-case stx () diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index d6e04fde2f..135ec7abe5 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -2496,84 +2496,79 @@ (define-syntax-rule (->dm . stx) (syntax-parameterize ([making-a-method #'this-param]) (->d . stx))) -(define (class/c-check-first-order ctc cls blame) - (let/ec return - (define (failed str . args) - (if blame - (apply raise-blame-error blame cls str args) - (return #f))) - (unless (class? cls) - (failed "not a class")) - (let ([method-ht (class-method-ht cls)] - [beta-methods (class-beta-methods cls)] - [meth-flags (class-meth-flags cls)]) - (for ([m (class/c-methods ctc)]) - (unless (hash-ref method-ht m #f) - (failed "no public method ~a" m))) - (for ([m (class/c-inherits ctc)]) - (unless (hash-ref method-ht m #f) - (failed "no public method ~a" m))) - (for ([m (class/c-overrides ctc)]) - (let ([index (hash-ref method-ht m #f)]) - (unless index - (failed "no public method ~a" m)) - (let ([vec (vector-ref beta-methods index)]) - (unless (zero? (vector-length vec)) - (failed "method ~a was previously augmentable" m))) - (let ([flag (vector-ref meth-flags index)]) - (when (eq? flag 'final) - (failed "method ~a is final" m))))) - (for ([m (class/c-augments ctc)]) - (let ([index (hash-ref method-ht m #f)]) - (unless index - (failed "no public method ~a" m)) - (let* ([vec (vector-ref beta-methods index)]) - (when (zero? (vector-length vec)) - (failed "method ~a has never been augmentable" m)) - (when (vector-ref vec (sub1 (vector-length vec))) - (failed "method ~a is currently overrideable, not augmentable" m))))) - (for ([m (class/c-augrides ctc)]) - (let ([index (hash-ref method-ht m #f)]) - (unless index - (failed "no public method ~a" m)) - (let ([vec (vector-ref beta-methods index)]) - (when (zero? (vector-length vec)) - (failed "method ~a has never been augmentable" m)) - (unless (vector-ref vec (sub1 (vector-length vec))) - (failed "method ~a is currently augmentable, not overrideable" m))))) - (for ([s (class/c-supers ctc)]) - (let ([index (hash-ref method-ht s #f)]) - (unless index - (failed "no public method ~a" s)) - (let ([flag (vector-ref meth-flags index)]) - (when (eq? flag 'final) - (failed "method ~a is final" s)) - (when (eq? flag 'augmentable) - (failed "method ~a is augmentable, not overrideable" s))))) - (for ([i (class/c-inners ctc)]) - (let ([index (hash-ref method-ht i #f)]) - (unless index - (failed "no public method ~a" i)) - (let ([vec (vector-ref beta-methods index)]) - (when (zero? (vector-length vec)) - (failed "method ~a has never been augmentable" i))) - (let ([flag (vector-ref meth-flags index)]) - (when (eq? flag 'final) - (failed "method ~a is final" i))))) - (let ([field-ht (class-field-ht cls)]) - (for ([f (class/c-fields ctc)]) - (unless (hash-ref field-ht f #f) - (failed "no public field ~a" f))) - (for ([f (class/c-inherit-fields ctc)]) - (unless (hash-ref field-ht f #f) - (failed "no public field ~a" f))))) - #t)) +(define (class/c-check-first-order ctc cls fail) + (unless (class? cls) + (fail "not a class")) + (let ([method-ht (class-method-ht cls)] + [beta-methods (class-beta-methods cls)] + [meth-flags (class-meth-flags cls)]) + (for ([m (class/c-methods ctc)]) + (unless (hash-ref method-ht m #f) + (fail "no public method ~a" m))) + (for ([m (class/c-inherits ctc)]) + (unless (hash-ref method-ht m #f) + (fail "no public method ~a" m))) + (for ([m (class/c-overrides ctc)]) + (let ([index (hash-ref method-ht m #f)]) + (unless index + (fail "no public method ~a" m)) + (let ([vec (vector-ref beta-methods index)]) + (unless (zero? (vector-length vec)) + (fail "method ~a was previously augmentable" m))) + (let ([flag (vector-ref meth-flags index)]) + (when (eq? flag 'final) + (fail "method ~a is final" m))))) + (for ([m (class/c-augments ctc)]) + (let ([index (hash-ref method-ht m #f)]) + (unless index + (fail "no public method ~a" m)) + (let* ([vec (vector-ref beta-methods index)]) + (when (zero? (vector-length vec)) + (fail "method ~a has never been augmentable" m)) + (when (vector-ref vec (sub1 (vector-length vec))) + (fail "method ~a is currently overrideable, not augmentable" m))))) + (for ([m (class/c-augrides ctc)]) + (let ([index (hash-ref method-ht m #f)]) + (unless index + (fail "no public method ~a" m)) + (let ([vec (vector-ref beta-methods index)]) + (when (zero? (vector-length vec)) + (fail "method ~a has never been augmentable" m)) + (unless (vector-ref vec (sub1 (vector-length vec))) + (fail "method ~a is currently augmentable, not overrideable" m))))) + (for ([s (class/c-supers ctc)]) + (let ([index (hash-ref method-ht s #f)]) + (unless index + (fail "no public method ~a" s)) + (let ([flag (vector-ref meth-flags index)]) + (when (eq? flag 'final) + (fail "method ~a is final" s)) + (when (eq? flag 'augmentable) + (fail "method ~a is augmentable, not overrideable" s))))) + (for ([i (class/c-inners ctc)]) + (let ([index (hash-ref method-ht i #f)]) + (unless index + (fail "no public method ~a" i)) + (let ([vec (vector-ref beta-methods index)]) + (when (zero? (vector-length vec)) + (fail "method ~a has never been augmentable" i))) + (let ([flag (vector-ref meth-flags index)]) + (when (eq? flag 'final) + (fail "method ~a is final" i))))) + (let ([field-ht (class-field-ht cls)]) + (for ([f (class/c-fields ctc)]) + (unless (hash-ref field-ht f #f) + (fail "no public field ~a" f))) + (for ([f (class/c-inherit-fields ctc)]) + (unless (hash-ref field-ht f #f) + (fail "no public field ~a" f))))) + #t) (define (class/c-proj ctc) (λ (blame) (let ([bswap (blame-swap blame)]) (λ (cls) - (class/c-check-first-order ctc cls blame) + (class/c-check-first-order ctc cls (λ args (apply raise-blame-error blame cls args))) (let* ([name (class-name cls)] [never-wrapped? (eq? (class-orig-cls cls) cls)] ;; Only add a new slot if we're not projecting an already contracted class. @@ -2927,7 +2922,8 @@ #:first-order (λ (ctc) (λ (cls) - (class/c-check-first-order ctc cls #f))))) + (let/ec ret + (class/c-check-first-order ctc cls (λ args (ret #f)))))))) (define-for-syntax (parse-class/c-specs forms object/c?) (define parsed-forms (make-hasheq)) @@ -3088,28 +3084,23 @@ augments augment-ctcs augrides augride-ctcs)))))])) -(define (check-object-contract obj blame methods fields) - (let/ec return - (define (failed str . args) - (if blame - (apply raise-blame-error blame obj str args) - (return #f))) - (unless (object? obj) - (failed "not a object")) - (let ([cls (object-ref obj)]) - (let ([method-ht (class-method-ht cls)]) - (for ([m methods]) - (unless (hash-ref method-ht m #f) - (failed "no public method ~a" m)))) - (let ([field-ht (class-field-ht cls)]) - (for ([m fields]) - (unless (hash-ref field-ht m #f) - (failed "no public field ~a" m))))))) +(define (check-object-contract obj methods fields fail) + (unless (object? obj) + (fail "not a object")) + (let ([cls (object-ref obj)]) + (let ([method-ht (class-method-ht cls)]) + (for ([m methods]) + (unless (hash-ref method-ht m #f) + (fail "no public method ~a" m)))) + (let ([field-ht (class-field-ht cls)]) + (for ([m fields]) + (unless (hash-ref field-ht m #f) + (fail "no public field ~a" m))))) + #t) (define (object/c-proj ctc) (λ (blame) (λ (obj) - (check-object-contract obj blame (object/c-methods ctc) (object/c-fields ctc)) (make-wrapper-object ctc obj blame (object/c-methods ctc) (object/c-method-contracts ctc) (object/c-fields ctc) (object/c-field-contracts ctc))))) @@ -3139,7 +3130,8 @@ #:first-order (λ (ctc) (λ (obj) - (check-object-contract obj #f (object/c-methods ctc) (object/c-fields ctc)))))) + (let/ec ret + (check-object-contract obj (object/c-methods ctc) (object/c-fields ctc) (λ args (ret #f)))))))) (define-syntax (object/c stx) (syntax-case stx () @@ -4441,7 +4433,7 @@ ;; make-wrapper-object: contract object blame (listof symbol) (listof contract?) (listof symbol) (listof contract?) (define (make-wrapper-object ctc obj blame methods method-contracts fields field-contracts) - (check-object-contract obj blame methods fields) + (check-object-contract obj methods fields (λ args (apply raise-blame-error blame obj args))) (let* ([new-cls (make-wrapper-class (object-ref obj) blame methods method-contracts fields field-contracts)]) (impersonate-struct obj object-ref (λ (o c) new-cls) impersonator-prop:contracted ctc))) From 500c2f608479bfda1f5985da9d02a07ba3ffdd64 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Wed, 17 Nov 2010 11:43:35 -0500 Subject: [PATCH 222/255] Fix comments and make field-info-* functions only deal with field-infos. --- collects/racket/private/class-internal.rkt | 58 +++++++++++----------- 1 file changed, 28 insertions(+), 30 deletions(-) diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index 135ec7abe5..d80e03c66a 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -200,40 +200,35 @@ ;; field info creation/access ;;-------------------------------------------------------------------- -;; A field-info is a (vector apos iref iset eref eset) +;; A field-info is a (vector iref iset eref eset) ;; where -;; apos is the absolute position of the field in the object struct -;; used for calls to unsafe-struct-ref/-set! ;; iref, iset, eref, and eset are projections to be applied -;; on internal and external reference and setting. +;; on internal and external access and mutation. ;; make-field-info creates a new field-info for a field. -;; The caller gives the absolute position, and this function fills +;; The caller gives the class and relative position (in the +;; new object struct layer), and this function fills ;; in the projections. (define (make-field-info cls rpos) (let ([field-ref (make-struct-field-accessor (class-field-ref cls) rpos)] [field-set! (make-struct-field-mutator (class-field-set! cls) rpos)]) (vector field-ref field-set! field-ref field-set!))) -(define (field-info-extend-internal! field-ht f ppos pneg) - (let* ([fi (hash-ref field-ht f)] - [old-ref (unsafe-vector-ref fi 0)] +(define (field-info-extend-internal fi ppos pneg) + (let* ([old-ref (unsafe-vector-ref fi 0)] [old-set! (unsafe-vector-ref fi 1)]) - (hash-set! field-ht f - (vector (λ (o) (ppos (old-ref o))) - (λ (o v) (old-set! o (pneg v))) - (unsafe-vector-ref fi 2) - (unsafe-vector-ref fi 3))))) + (vector (λ (o) (ppos (old-ref o))) + (λ (o v) (old-set! o (pneg v))) + (unsafe-vector-ref fi 2) + (unsafe-vector-ref fi 3)))) -(define (field-info-extend-external! field-ht f ppos pneg) - (let* ([fi (hash-ref field-ht f)] - [old-ref (unsafe-vector-ref fi 2)] +(define (field-info-extend-external fi ppos pneg) + (let* ([old-ref (unsafe-vector-ref fi 2)] [old-set! (unsafe-vector-ref fi 3)]) - (hash-set! field-ht f - (vector (unsafe-vector-ref fi 0) - (unsafe-vector-ref fi 1) - (λ (o) (ppos (old-ref o))) - (λ (o v) (old-set! o (pneg v))))))) + (vector (unsafe-vector-ref fi 0) + (unsafe-vector-ref fi 1) + (λ (o) (ppos (old-ref o))) + (λ (o v) (old-set! o (pneg v)))))) (define (field-info-internal-ref fi) (unsafe-vector-ref fi 0)) (define (field-info-internal-set! fi) (unsafe-vector-ref fi 1)) @@ -2726,15 +2721,17 @@ (for ([f (in-list (class/c-fields ctc))] [c (in-list (class/c-field-contracts ctc))]) (when c - (let* ([p-pos ((contract-projection c) blame)] - [p-neg ((contract-projection c) bswap)]) - (field-info-extend-external! field-ht f p-pos p-neg)))) + (let ([fi (hash-ref field-ht f)] + [p-pos ((contract-projection c) blame)] + [p-neg ((contract-projection c) bswap)]) + (hash-set! field-ht f (field-info-extend-external fi p-pos p-neg))))) (for ([f (in-list (class/c-inherit-fields ctc))] [c (in-list (class/c-inherit-field-contracts ctc))]) (when c - (let* ([p-pos ((contract-projection c) blame)] - [p-neg ((contract-projection c) bswap)]) - (field-info-extend-internal! field-ht f p-pos p-neg))))) + (let ([fi (hash-ref field-ht f)] + [p-pos ((contract-projection c) blame)] + [p-neg ((contract-projection c) bswap)]) + (hash-set! field-ht f (field-info-extend-internal fi p-pos p-neg)))))) ;; Now the trickiest of them all, internal dynamic dispatch. ;; First we update any dynamic indexes, as applicable. @@ -4425,9 +4422,10 @@ (for ([f (in-list fields)] [c (in-list field-contracts)]) (when c - (let* ([p-pos ((contract-projection c) blame)] - [p-neg ((contract-projection c) bset)]) - (field-info-extend-external! field-ht f p-pos p-neg)))))) + (let ([fi (hash-ref field-ht f)] + [p-pos ((contract-projection c) blame)] + [p-neg ((contract-projection c) bset)]) + (hash-set! field-ht f (field-info-extend-external fi p-pos p-neg))))))) c)) From 30afcd3bf5cc272f1642449989628024bedc41eb Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 16 Nov 2010 22:01:38 -0500 Subject: [PATCH 223/255] =?UTF-8?q?Fix=20object=3D=3F.?= Also commented out some tests of reflective operations on contracted objects. I've added a note that describes how we might be able to fix this, if we decide it's worth doing. --- collects/racket/private/class-internal.rkt | 14 +++++++++++--- collects/tests/racket/contract-mzlib-test.rktl | 5 +++++ collects/tests/racket/contract-test.rktl | 12 ++++++++++++ 3 files changed, 28 insertions(+), 3 deletions(-) diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index d80e03c66a..5a456e9c46 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -4223,7 +4223,9 @@ (raise-type-error 'object=? "object" o1)) (unless (object? o2) (raise-type-error 'object=? "object" o2)) - (or (impersonator-of? o1 o2) (impersonator-of? o2 o1))) + (let ([orig-o1 (if (has-original-object? o1) (original-object o1) o1)] + [orig-o2 (if (has-original-object? o2) (original-object o2) o2)]) + (eq? orig-o1 orig-o2))) ;;-------------------------------------------------------------------- ;; primitive classes @@ -4429,11 +4431,17 @@ c)) +(define-values (impersonator-prop:original-object has-original-object? original-object) + (make-impersonator-property 'impersonator-prop:original-object)) + ;; make-wrapper-object: contract object blame (listof symbol) (listof contract?) (listof symbol) (listof contract?) (define (make-wrapper-object ctc obj blame methods method-contracts fields field-contracts) (check-object-contract obj methods fields (λ args (apply raise-blame-error blame obj args))) - (let* ([new-cls (make-wrapper-class (object-ref obj) blame methods method-contracts fields field-contracts)]) - (impersonate-struct obj object-ref (λ (o c) new-cls) impersonator-prop:contracted ctc))) + (let ([original-obj (if (has-original-object? obj) (original-object obj) obj)] + [new-cls (make-wrapper-class (object-ref obj) blame methods method-contracts fields field-contracts)]) + (impersonate-struct obj object-ref (λ (o c) new-cls) + impersonator-prop:contracted ctc + impersonator-prop:original-object original-obj))) ;;-------------------------------------------------------------------- ;; misc utils diff --git a/collects/tests/racket/contract-mzlib-test.rktl b/collects/tests/racket/contract-mzlib-test.rktl index 28df566071..b18aa0dc37 100644 --- a/collects/tests/racket/contract-mzlib-test.rktl +++ b/collects/tests/racket/contract-mzlib-test.rktl @@ -2760,6 +2760,10 @@ of the contract library does not change over time. (test #t (contract-eval 'is-a?) (contract-eval `(contract (object-contract) ,o 'pos 'neg)) i<%>) (test #t (contract-eval 'is-a?) (contract-eval `(contract (object-contract) ,o 'pos 'neg)) c%)) + ;; Currently the new object contracts using impersonators don't even attempt to ensure that + ;; these reflective operations still work, and I'm not even sure they should. For now, I'll + ;; just comment them out so that we can revive them if we decide that they should work. + #| (let ([c% (parameterize ([current-inspector (make-inspector)]) (contract-eval '(class object% (super-new))))]) (test (list c% #f) @@ -2781,6 +2785,7 @@ of the contract library does not change over time. ,obj 'pos 'neg)))) +|# ; ; diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index aeadc3bc23..36aedd6fac 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -6044,6 +6044,17 @@ (test #t (contract-eval 'is-a?) (contract-eval `(contract (object-contract) ,o 'pos 'neg)) i<%>) (test #t (contract-eval 'is-a?) (contract-eval `(contract (object-contract) ,o 'pos 'neg)) c%)) + ;; Currently the new object contracts using impersonators don't even attempt to ensure that + ;; these reflective operations still work, and I'm not even sure they should. For now, I'll + ;; just comment them out so that we can revive them if we decide that they should work. + ;; + ;; Just as a note, if we move the class-insp-mk values forward in class/c-proj and make-wrapper-class, + ;; we get a failure in object->vector for the second testcase because the field-ref/field-set! in the + ;; contracted version of the class (for a struct subtype of the original class's struct type) doesn't + ;; know how to get the fields out of the object struct. We can always force it with unsafe-struct-ref, + ;; but if we had impersonate-struct-type, with the same ability to replace the prop:object as + ;; impersonate-struct has, then we might be able to handle this better. + #| (let ([c% (parameterize ([current-inspector (make-inspector)]) (contract-eval '(class object% (super-new))))]) (test (list c% #f) @@ -6065,6 +6076,7 @@ ,obj 'pos 'neg)))) +|# ; From 4e451a1b79011e5aeb667222cd2edda94e10bc11 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Wed, 1 Dec 2010 14:48:19 -0500 Subject: [PATCH 224/255] Add back in old object-info hack. --- collects/racket/private/class-internal.rkt | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index 5a456e9c46..a0e648029f 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -4156,14 +4156,15 @@ (raise-type-error 'object-info "object" o)) (trace-begin (trace (inspect-event o)) - (let loop ([c (object-ref o)] - [skipped? #f]) - (if (struct? ((class-insp-mk c))) - ;; current objec can inspect this object - (values c skipped?) - (if (zero? (class-pos c)) - (values #f #t) - (loop (vector-ref (class-supers c) (sub1 (class-pos c))) #t)))))) + (let ([o* (if (has-original-object? o) (original-object o) o)]) + (let loop ([c (object-ref o)] + [skipped? #f]) + (if (struct? ((class-insp-mk c))) + ;; current objec can inspect this object + (values c skipped?) + (if (zero? (class-pos c)) + (values #f #t) + (loop (vector-ref (class-supers c) (sub1 (class-pos c))) #t))))))) (define (to-sym s) (if (string? s) From 7d8c520480abf389ebe88cfcbe6bc97e31714c53 Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Wed, 1 Dec 2010 15:18:13 -0700 Subject: [PATCH 225/255] Remove unused variable --- src/racket/src/sema.c | 1 - 1 file changed, 1 deletion(-) diff --git a/src/racket/src/sema.c b/src/racket/src/sema.c index 4ed250633a..c4dedc33c0 100644 --- a/src/racket/src/sema.c +++ b/src/racket/src/sema.c @@ -226,7 +226,6 @@ Scheme_Object *scheme_make_sema(long v) static Scheme_Object *make_sema(int n, Scheme_Object **p) { long v; - Scheme_Object *s; if (n) { if (!SCHEME_INTP(p[0])) { From e9710d08f5385c9251ba6dd88d4e70f96f247ca6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 1 Dec 2010 13:37:07 -0700 Subject: [PATCH 226/255] fix autowrap bitmap drawing so it isn't covered up by a selection --- collects/mred/private/wxme/text.rkt | 29 +++++++++++++++-------------- 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index b8a4982e65..050bfa9c83 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -5265,20 +5265,6 @@ (-startpos . > . (+ pcounter (mline-len line))))] [(hilite-some? hsxs hsxe hsys hsye old-style) (process-snips draw-first? #f old-style)]) - (when (and (positive? wrap-bitmap-width) - (not (has-flag? (snip->flags (mline-last-snip line)) HARD-NEWLINE)) - last - (rightx . >= . max-width) - (send auto-wrap-bitmap ok?)) - (let ([h (min (->long (send auto-wrap-bitmap get-height)) - (mline-bottombase line))] - [osfg (send old-style get-foreground)]) - (send dc draw-bitmap-section - auto-wrap-bitmap - (sub1 (+ max-width dx)) (+ (- bottombase h) dy) - 0 0 wrap-bitmap-width h - 'solid osfg))) - (let ([prevwasfirst (if hilite-some? (if (not (= hsxs hsxe)) @@ -5337,6 +5323,21 @@ (send dc set-pen save-pen)))) prevwasfirst)) prevwasfirst)]) + + (when (and (positive? wrap-bitmap-width) + (not (has-flag? (snip->flags (mline-last-snip line)) HARD-NEWLINE)) + last + (rightx . >= . max-width) + (send auto-wrap-bitmap ok?)) + (let ([h (min (->long (send auto-wrap-bitmap get-height)) + (mline-bottombase line))] + [osfg (send old-style get-foreground)]) + (send dc draw-bitmap-section + auto-wrap-bitmap + (sub1 (+ max-width dx)) (+ (- bottombase h) dy) + 0 0 wrap-bitmap-width h + 'solid osfg))) + (let ([old-style (if draw-first? old-style From ed8aa132de184d5c3db98cc80b0382b3d0de32b7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 1 Dec 2010 13:54:51 -0700 Subject: [PATCH 227/255] improve editor highlighting of selected image-snip% --- collects/mred/private/wxme/snip.rkt | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wxme/snip.rkt b/collects/mred/private/wxme/snip.rkt index 13e3d58fbc..faeac4d89d 100644 --- a/collects/mred/private/wxme/snip.rkt +++ b/collects/mred/private/wxme/snip.rkt @@ -964,9 +964,14 @@ (send mask ok?) (= w (send mask get-width)) (= w (send mask get-height)) - mask)))]) + mask)))] + [alpha (send dc get-alpha)]) + (when (pair? caret) + (send dc set-alpha (* 0.5 alpha))) (send dc draw-bitmap-section bm x y 0 0 w h - 'solid black-color msk)))) + 'solid black-color msk) + (when (pair? caret) + (send dc set-alpha alpha))))) (def/override (copy) (let ([s (new image-snip%)]) From dedb207a8683a17026d51a9185d5fefbcfbecbc9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 1 Dec 2010 14:20:54 -0700 Subject: [PATCH 228/255] fix draw-bitmap result to match docs --- collects/racket/draw/private/bitmap-dc.rkt | 5 +- collects/racket/draw/private/dc.rkt | 3 +- collects/scribblings/gui/dc-intf.scrbl | 1125 -------------------- 3 files changed, 5 insertions(+), 1128 deletions(-) delete mode 100644 collects/scribblings/gui/dc-intf.scrbl diff --git a/collects/racket/draw/private/bitmap-dc.rkt b/collects/racket/draw/private/bitmap-dc.rkt index 6364a69387..b5b1159ccc 100644 --- a/collects/racket/draw/private/bitmap-dc.rkt +++ b/collects/racket/draw/private/bitmap-dc.rkt @@ -147,7 +147,8 @@ [sy (if (zero? src-h) 1.0 (/ dest-h src-h))]) (let ([t (get-transformation)]) (scale sx sy) - (draw-bitmap-section src (/ dest-x sx) (/ dest-y sy) src-x src-y src-w src-h style color mask) - (set-transformation t)))))) + (begin0 + (draw-bitmap-section src (/ dest-x sx) (/ dest-y sy) src-x src-y src-w src-h style color mask) + (set-transformation t))))))) (install-bitmap-dc-class! bitmap-dc%) diff --git a/collects/racket/draw/private/dc.rkt b/collects/racket/draw/private/dc.rkt index e11fe0c369..d1a515f062 100644 --- a/collects/racket/draw/private/dc.rkt +++ b/collects/racket/draw/private/dc.rkt @@ -1594,7 +1594,8 @@ (stamp-pattern src a-src-x a-src-y)]) (when clip-mask (cairo_restore cr)) - (flush-cr)))) + (flush-cr))) + #t) (define/private (bitmap-to-b&w-bitmap src src-x src-y src-w src-h style color mask) (let* ([bm-w (inexact->exact (ceiling src-w))] diff --git a/collects/scribblings/gui/dc-intf.scrbl b/collects/scribblings/gui/dc-intf.scrbl deleted file mode 100644 index ec0de7440d..0000000000 --- a/collects/scribblings/gui/dc-intf.scrbl +++ /dev/null @@ -1,1125 +0,0 @@ -#lang scribble/doc -@(require "common.ss") - -@definterface/title[dc<%> ()]{ - -A @scheme[dc<%>] object is a drawing context for drawing graphics and - text. It represents output devices in a generic way; e.g., a canvas - has a drawing context, as does a printer. - - -@defmethod[(cache-font-metrics-key) - exact-integer?]{ - -Returns an integer that, if not @scheme[0], corresponds to a -particular kind of device and scaling factor, such that text-extent -information (from @method[dc<%> get-text-extent], @method[dc<%> -get-char-height], etc.) is the same. The key is valid across all -@scheme[dc<%>] instances, even among different classes. - -A @scheme[0] result indicates that the current configuration of -@this-obj[] does not fit into a common category, and so no key is -available for caching text-extent information.} - - -@defmethod[(clear) - void?]{ - -Clears the drawing region (fills it with the current background color, -as determined by @method[dc<%> get-background]). - -} - -@defmethod[(copy [x real?] - [y real?] - [width (and/c real? (not/c negative?))] - [height (and/c real? (not/c negative?))] - [x2 real?] - [y2 real?]) - void?]{ - -Copies the rectangle defined by @racket[x], @racket[y], -@racket[width], and @racket[height] of the drawing context to the same -drawing context at the position specified by @racket[x2] and -@racket[y2]. - -The result is undefined if the source and destination rectangles -overlap.} - - -@defmethod[(draw-arc [x real?] - [y real?] - [width (and/c real? (not/c negative?))] - [height (and/c real? (not/c negative?))] - [start-radians real?] - [end-radians real?]) - void?]{ - -Draws a counter-clockwise circular arc, a part of the ellipse - inscribed in the rectangle specified by @scheme[x] (left), @scheme[y] - (top), @scheme[width], and @scheme[height]. The arc starts at the angle - specified by @scheme[start-radians] (@scheme[0] is three o'clock and - half-pi is twelve o'clock) and continues counter-clockwise to - @scheme[end-radians]. If @scheme[start-radians] and @scheme[end-radians] are - the same, a full ellipse is drawn. - -The current pen is used for the arc. If the current brush is not - transparent, it is used to fill the wedge bounded by the arc plus - lines (not drawn) extending to the center of the inscribed ellipse. - -If both the pen and brush are non-transparent, the wedge is filled - with the brush before the arc is drawn with the pen. The wedge and - arc meet so that no space is left between them, but the precise - overlap between the wedge and arc is platform- and size-specific. - Typically, the regions drawn by the brush and pen overlap. More - generally, the pen is centered over the outline of the arc, rounding - toward the center in unsmoothed mode. - -@|DrawSizeNote| - -} - - -@defmethod[(draw-bitmap [source (is-a?/c bitmap%)] - [dest-x real?] - [dest-y real?] - [style (one-of/c 'solid 'opaque 'xor) 'solid] - [color (is-a?/c color%) (send the-color-database find-color "black")] - [mask (or/c (is-a?/c bitmap%) false/c) #f]) - boolean?]{ - -Displays a bitmap. The @scheme[dest-x] and @scheme[dest-y] arguments - are in DC coordinates. - -For color bitmaps, the drawing style and color arguments are - ignored. For monochrome bitmaps, @method[dc<%> draw-bitmap] uses the - style and color arguments in the same way that a brush uses its style - and color settings to draw a monochrome stipple (see @scheme[brush%] - for more information). - -If a mask bitmap is supplied, it must have the same width and height - as the bitmap to display, and its @method[bitmap% ok?] must return - true, otherwise @|MismatchExn|. The bitmap to draw and the mask - bitmap can be the same object, but if the drawing context is a - @scheme[bitmap-dc%] object, both bitmaps must be distinct from the - destination bitmap, otherwise @|MismatchExn|. - -If the mask bitmap is monochrome, drawing occurs in the target - @scheme[dc<%>] only where the mask bitmap contains black pixels. - -If the mask bitmap is grayscale and the bitmap to draw is not - monochrome, then the blackness of each mask pixel controls the - opacity of the drawn pixel (i.e., the mask acts as an inverted alpha - channel). If a mask bitmap is color, the component values of a given - pixel are averaged to arrive at a gray value for the pixel. - -The current brush, current pen, current text, and current alpha - settings for the DC have no effect on how the bitmap is drawn, but - the bitmap is scaled if the DC has a scale. - -For @scheme[post-script-dc%] output, the mask bitmap is currently - ignored, and the @scheme['solid] style is treated the same as - @scheme['opaque]. (However, mask bitmaps and @scheme['solid] drawing - may become supported for @scheme[post-script-dc%] in the future.) - -The result is @scheme[#t] if the bitmap is successfully drawn, - @scheme[#f] otherwise (possibly because the bitmap's @method[bitmap% - ok?] method returns @scheme[#f]). - -See also @method[dc<%> draw-bitmap-section]. - -@|DrawSizeNote| - -} - -@defmethod[(draw-bitmap-section [source (is-a?/c bitmap%)] - [dest-x real?] - [dest-y real?] - [src-x real?] - [src-y real?] - [src-width (and/c real? (not/c negative?))] - [src-height (and/c real? (not/c negative?))] - [style (one-of/c 'solid 'opaque 'xor) 'solid] - [color (is-a?/c color%) (send the-color-database find-color "black")] - [mask (or/c (is-a?/c bitmap%) false/c) #f]) - boolean?]{ - -Displays part of a bitmap. - -The @scheme[src-x], @scheme[src-y], @scheme[src-width], and - @scheme[src-height] arguments specify a rectangle in the source - bitmap to copy into this drawing context. - -See @method[dc<%> draw-bitmap] for information about @scheme[dest-x], - @scheme[dest-y], @scheme[style], @scheme[color], and @scheme[mask]. - -} - -@defmethod[(draw-ellipse [x real?] - [y real?] - [width (and/c real? (not/c negative?))] - [height (and/c real? (not/c negative?))]) - void?]{ - -Draws an ellipse contained in a rectangle with the given top-left - corner and size. The current pen is used for the outline, and the - current brush is used for filling the shape. - -If both the pen and brush are non-transparent, the ellipse is filled - with the brush before the outline is drawn with the pen. The filling - and outline meet so that no space is left between them, but the - precise overlap between the filling and outline is platform- and - size-specific. Typically, the regions drawn by the brush and pen - overlap. More generally, the pen is centered over the outline of the - ellipse, rounding toward the center in unsmoothed mode. - -@|DrawSizeNote| - -} - -@defmethod[(draw-line [x1 real?] - [y1 real?] - [x2 real?] - [y2 real?]) - void?]{ - -Draws a line from one point to another. The current pen is used for - drawing the line. - -In unsmoothed mode, the points correspond to pixels, and the line - covers both the start and end points. For a pen whose scaled width is - larger than @scheme[1], the line is drawn centered over the start and - end points. - -See also @method[dc<%> set-smoothing] for information on the -@scheme['aligned] smoothing mode. - -@|DrawSizeNote| - -} - -@defmethod[(draw-lines [points (listof (is-a?/c point%))] - [xoffset real? 0] - [yoffset real? 0]) - void?]{ - -Draws lines using a list of @scheme[points], adding @scheme[xoffset] - and @scheme[yoffset] to each point. The current pen is used for - drawing the lines. - -See also @method[dc<%> set-smoothing] for information on the - @scheme['aligned] smoothing mode. - -@|DrawSizeNote| - -} - -@defmethod[(draw-path [path (is-a?/c dc-path%)] - [xoffset real? 0] - [yoffset real? 0] - [fill-style (one-of/c 'odd-even 'winding) 'odd-even]) - void?]{ - -Draws the sub-paths of the given @scheme[dc-path%] object, adding - @scheme[xoffset] and @scheme[yoffset] to each point. (See - @scheme[dc-path%] for general information on paths and sub-paths.) - The current pen is used for drawing the path as a line, and the - current brush is used for filling the area bounded by the path. - -If both the pen and brush are non-transparent, the path is filled with - the brush before the outline is drawn with the pen. The filling and - outline meet so that no space is left between them, but the precise - overlap between the filling and outline is platform- and - size-specific. Thus, the regions drawn by the brush and pen may - overlap. More generally, the pen is centered over the path, rounding - left and down in unsmoothed mode. - -The @scheme[fill-style] argument specifies the fill rule: - @scheme['odd-even] or @scheme['winding]. In @scheme['odd-even] mode, a - point is considered enclosed within the path if it is enclosed by an - odd number of sub-path loops. In @scheme['winding] mode, a point is - considered enclosed within the path if it is enclosed by more or less - clockwise sub-path loops than counter-clockwise sub-path loops. - -See also @method[dc<%> set-smoothing] for information on the - @scheme['aligned] smoothing mode. - -@|DrawSizeNote| - -} - -@defmethod[(draw-point [x real?] - [y real?]) - void?]{ - -Plots a single point using the current pen. - -@|DrawSizeNote| - -} - -@defmethod[(draw-polygon [points (listof (is-a?/c point%))] - [xoffset real? 0] - [yoffset real? 0] - [fill-style (one-of/c 'odd-even 'winding) 'odd-even]) - void?]{ - -Draw a filled polygon using a list of @scheme[points], adding - @scheme[xoffset] and @scheme[yoffset] to each point. The polygon is - automatically closed, so the first and last point can be - different. The current pen is used for drawing the outline, and the - current brush for filling the shape. - -If both the pen and brush are non-transparent, the polygon is filled - with the brush before the outline is drawn with the pen. The filling - and outline meet so that no space is left between them, but the - precise overlap between the filling and outline is platform- and - shape-specific. Thus, the regions drawn by the brush and pen may - overlap. More generally, the pen is centered over the polygon lines, - rounding left and down in unsmoothed mode. - -The @scheme[fill-style] argument specifies the fill rule: - @scheme['odd-even] or @scheme['winding]. In @scheme['odd-even] mode, a - point is considered enclosed within the polygon if it is enclosed by - an odd number of loops. In @scheme['winding] mode, a point is - considered enclosed within the polygon if it is enclosed by more or - less clockwise loops than counter-clockwise loops. - -See also @method[dc<%> set-smoothing] for information on the - @scheme['aligned] smoothing mode. - -@|DrawSizeNote| - -} - - -@defmethod[(draw-rectangle [x real?] - [y real?] - [width (and/c real? (not/c negative?))] - [height (and/c real? (not/c negative?))]) - void?]{ - -Draws a rectangle with the given top-left corner and size. The - current pen is used for the outline and the current brush for filling - the shape. - -If both the pen and brush are non-transparent, the rectangle is filled - with the brush before the outline is drawn with the pen. In - unsmoothed mode, when the pen is size 0 or 1, the filling precisely - overlaps the entire outline. As a result, if a rectangle is drawn - with a size-0 or size-1 @scheme['xor] @scheme[pen%] and an - @scheme['xor] @scheme[brush%], the outline is xored twice (first by - the brush, then by the pen), leaving it unchanged. More generally, - the pen is centered over the outline of the rectangle, rounding - toward the center in unsmoothed mode. - -See also @method[dc<%> set-smoothing] for information on the -@scheme['aligned] smoothing mode. - -@|DrawSizeNote| - -} - - -@defmethod[(draw-rounded-rectangle [x real?] - [y real?] - [width (and/c real? (not/c negative?))] - [height (and/c real? (not/c negative?))] - [radius real? -0.25]) - void?]{ - -Draws a rectangle with the given top-left corner, and with the given - size. The corners are quarter-circles using the given radius. The - current pen is used for the outline and the current brush for filling - the shape. - -If @scheme[radius] is positive, the value is used as the radius of the - rounded corner. If @scheme[radius] is negative, the absolute value is - used as the @italic{proportion} of the smallest dimension of the - rectangle. - -If @scheme[radius] is less than @scheme[-0.5] or more than half of - @scheme[width] or @scheme[height], @|MismatchExn|. - -If both the pen and brush are non-transparent, the rectangle is filled - with the brush before the outline is drawn with the pen. The filling - and outline meet so that no space is left between them, but the - precise overlap between the filling and outline is platform- and - size-specific. Thus, the regions drawn by the brush and pen may - partially overlap. More generally, the pen is centered over the - outline of the rounded rectangle, rounding toward the center in - unsmoothed mode. - -See also @method[dc<%> set-smoothing] for information on the -@scheme['aligned] smoothing mode. - -@|DrawSizeNote| - -} - -@defmethod[(draw-spline [x1 real?] - [y1 real?] - [x2 real?] - [y2 real?] - [x3 real?] - [y3 real?]) - void?]{ - -@index['("drawing curves")]{Draws} a spline from (@scheme[x1], - @scheme[y1]) to (@scheme[x3], @scheme[y3]) using (@scheme[x2], - @scheme[y2]) as the control point. - -See also @method[dc<%> set-smoothing] for information on the - @scheme['aligned] smoothing mode. See also @scheme[dc-path%] and - @method[dc<%> draw-path] for drawing more complex curves. - -@|DrawSizeNote| - -} - -@defmethod[(draw-text [text string?] - [x real?] - [y real?] - [combine? any/c #f] - [offset exact-nonnegative-integer? 0] - [angle real? 0]) - void?]{ - -Draws a text string at a specified point, using the current text font, - and the current text foreground and background colors. For unrotated - text, the specified point is used as the starting top-left point for - drawing characters (e.g, if ``W'' is drawn, the point is roughly the - location of the top-left pixel in the ``W''). Rotated text is rotated - around this point. - -The @scheme[text] string is drawn starting from the @scheme[offset] - character, and continuing until the end of @scheme[text] or the first - null character. - -If @scheme[combine?] is @scheme[#t], then @scheme[text] may be - measured with adjacent characters combined to ligature glyphs, with - Unicode combining characters as a single glyph, with kerning, with - right-to-left rendering of characters, etc. If @scheme[combine?] is - @scheme[#f], then the result is the same as if each character is - measured separately, and Unicode control characters are ignored. - -The string is rotated by @scheme[angle] radians counter-clockwise. If - @scheme[angle] is not zero, then the text is always drawn in - transparent mode (see @method[dc<%> set-text-mode]). - -The current brush and current pen settings for the DC have no effect - on how the text is drawn. - -See @method[dc<%> get-text-extent] for information on the size of the - drawn text. - -See also @method[dc<%> set-text-foreground], @method[dc<%> - set-text-background], and @method[dc<%> set-text-mode]. - -@|DrawSizeNote| - -} - -@defmethod[(end-doc) - void?]{ - -Ends a document, relevant only when drawing to a printer or PostScript - device (including to a PostScript file). - -For printer or PostScript output, an exception is raised if -@scheme[end-doc] is called when the document is not started with -@method[dc<%> start-doc], when a page is currently started by -@method[dc<%> start-page] and not ended with @method[dc<%> end-page], -or when the document has been ended already. - -} - -@defmethod[(end-page) - void?]{ - -Ends a single page, relevant only when drawing to a printer or - PostScript device (including to a PostScript file). - -For printer or PostScript output, an exception is raised if -@scheme[end-page] is called when a page is not currently started by -@method[dc<%> start-page]. - -} - - -@defmethod[(flush) void?]{ - -Calls the @xmethod[canvas<%> flush] method for -@racket[canvas<%>] output, and has no effect for other kinds of -drawing contexts.} - - - -@defmethod[(get-alpha) - (real-in 0 1)]{ - -Gets the current opacity for drawing; see -@method[dc<%> set-alpha]. - -} - -@defmethod[(get-background) - (is-a?/c color%)]{ - -Gets the color used for painting the background. See also -@method[dc<%> set-background]. - -} - -@defmethod[(get-brush) - (is-a?/c brush%)]{ - -Gets the current brush. See also @method[dc<%> set-brush]. - -} - -@defmethod[(get-char-height) - (and/c real? (not/c negative?))]{ - -Gets the height of a character using the current font. - -Unlike most methods, this method can be called for a - @scheme[bitmap-dc%] object without a bitmap installed. - -} - -@defmethod[(get-char-width) - (and/c real? (not/c negative?))]{ - -Gets the average width of a character using the current font. - -Unlike most methods, this method can be called for a - @scheme[bitmap-dc%] object without a bitmap installed. - -} - -@defmethod[(get-clipping-region) - (or/c (is-a?/c region%) false/c)]{ - -Gets the current clipping region, returning @scheme[#f] if the drawing - context is not clipped (i.e., the clipping region is the entire - drawing region). - -} - -@defmethod[(get-font) - (is-a?/c font%)]{ - -Gets the current font. See also @method[dc<%> set-font]. - -} - -@defmethod[(get-gl-context) - (or/c (is-a?/c gl-context<%>) false/c)]{ - -Returns a @scheme[gl-context<%>] object for this drawing context - if it supports OpenGL, @scheme[#f] otherwise. - -See @scheme[gl-context<%>] for more information. - -} - -@defmethod[(get-initial-matrix) - (vector/c real? real? real? real? real? real?)]{ - -Returns a transformation matrix that converts logical coordinates to - device coordinates. The matrix applies before additional origin - offset, scaling, and rotation. - -The vector content corresponds to a transformation matrix in the -following order: - -@itemlist[ - - @item{@racket[_xx]: a scale from the logical @racket[_x] to the device @racket[_x]} - - @item{@racket[_xy]: a scale from the logical @racket[_x] added to the device @racket[_y]} - - @item{@racket[_yx]: a scale from the logical @racket[_y] added to the device @racket[_x]} - - @item{@racket[_yy]: a scale from the logical @racket[_y] to the device @racket[_y]} - - @item{@racket[_x0]: an additional amount added to the device @racket[_x]} - - @item{@racket[_y0]: an additional amount added to the device @racket[_y]} - -] - -See also @method[dc<%> set-initial-matrix] and @method[dc<%> get-transformation]. - -} - - -@defmethod[(get-origin) - (values real? real?)]{ - -Returns the device origin, i.e., the location in device coordinates of - @math{(0,0)} in logical coordinates. The origin offset applies after - the initial transformation matrix, but before scaling and rotation. - -See also @method[dc<%> set-origin] and @method[dc<%> get-transformation]. - -} - - -@defmethod[(get-pen) - (is-a?/c pen%)]{ - -Gets the current pen. See also @method[dc<%> set-pen]. - -} - -@defmethod[(get-rotation) real?]{ - -Returns the rotation of logical coordinates in radians to device -coordinates. Rotation applies after the initial transformation matrix, -origin offset, and scaling. - -See also @method[dc<%> set-rotation] and @method[dc<%> get-transformation]. - -} - -@defmethod[(get-scale) - (values real? real?)]{ - -Returns the scaling factor that maps logical coordinates to device -coordinates. Scaling applies after the initial transformation matrix -and origin offset, but before rotation. - -See also @method[dc<%> set-scale] and @method[dc<%> get-transformation]. - -} - -@defmethod[(get-size) - (values nonnegative-real? nonnegative-real?)]{ - -Gets the size of the destination drawing area. For a @scheme[dc<%>] - object obtained from a @scheme[canvas<%>], this is the (virtual - client) size of the destination window; for a @scheme[bitmap-dc%] - object, this is the size of the selected bitmap (or 0 if no bitmap is - selected); for a @scheme[post-script-dc%] or @scheme[printer-dc%] - drawing context, this gets the horizontal and vertical size of the - drawing area. - -} - -@defmethod[(get-smoothing) - (one-of/c 'unsmoothed 'smoothed 'aligned)]{ - -Returns the current smoothing mode. See @method[dc<%> set-smoothing]. - -} - -@defmethod[(get-text-background) - (is-a?/c color%)]{ - -Gets the current text background color. See also @method[dc<%> -set-text-background]. - -} - -@defmethod[(get-text-extent [string string?] - [font (or/c (is-a?/c font%) false/c) #f] - [combine? any/c #f] - [offset exact-nonnegative-integer? 0]) - (values nonnegative-real? - nonnegative-real? - nonnegative-real? - nonnegative-real?)]{ - - -Returns the size of @scheme[str] at it would be drawn in the drawing - context, starting from the @scheme[offset] character of @scheme[str], - and continuing until the end of @scheme[str] or the first null - character. The @scheme[font] argument specifies the font to use in - measuring the text; if it is @scheme[#f], the current font of the - drawing area is used. (See also @method[dc<%> set-font].) - -The result is four real numbers: - -@itemize[ - - @item{the total width of the text (depends on both the font and the - text);} - - @item{the total height of the font (depends only on the font);} - - @item{the distance from the baseline of the font to the bottom of the - descender (included in the height, depends only on the font); and} - - @item{extra vertical space added to the font by the font designer - (included in the height, and often zero; depends only on the font).} - -] - -The returned width and height define a rectangle is that guaranteed to - contain the text string when it is drawn, but the fit is not - necessarily tight. Some undefined number of pixels on the left, - right, top, and bottom of the drawn string may be ``whitespace,'' - depending on the whims of the font designer and the platform-specific - font-scaling mechanism. - -If @scheme[combine?] is @scheme[#t], then @scheme[text] may be drawn - with adjacent characters combined to ligature glyphs, with Unicode - combining characters as a single glyph, with kerning, with - right-to-left ordering of characters, etc. If @scheme[combine?] is - @scheme[#f], then the result is the same as if each character is - drawn separately, and Unicode control characters are ignored. - -Unlike most methods, this method can be called for a - @scheme[bitmap-dc%] object without a bitmap installed. - -} - - -@defmethod[(get-text-foreground) - (is-a?/c color%)]{ - -Gets the current text foreground color. See also @method[dc<%> -set-text-foreground]. - -} - - -@defmethod[(get-text-mode) - (one-of/c 'solid 'transparent)]{ -Reports how text is drawn; see -@method[dc<%> set-text-mode].} - - -@defmethod[(get-transformation) - (vector/c (vector/c real? real? real? real? real? real?) - real? real? real? real? real?)]{ - -Returns the current transformation setting of the drawing context in a -form that is suitable for restoration via @method[dc<%> -set-transformation]. - -The vector content is as follows: - -@itemlist[ - - @item{the initial transformation matrix; see @method[dc<%> - get-initial-matrix];} - - @item{the X and Y origin; see @method[dc<%> get-origin];} - - @item{the X and Y scale; see @method[dc<%> get-origin];} - - @item{a rotation; see @method[dc<%> get-rotation].} - -]} - - -@defmethod[(glyph-exists? [c char] - [font (or/c (is-a?/c font%) false/c) #f]) - boolean?]{ - -Returns @scheme[#t] if the given character has a corresponding glyph - for this drawing context, @scheme[#f] otherwise. - -Due to automatic font substitution when drawing or measuring text, the - result of this method does not depend on the given font, which merely - provides a hint for the glyph search. If the font is @scheme[#f], the - drawing context's current font is used. The result depends on the - type of the drawing context, but the result for @scheme[canvas%] - @scheme[dc<%>] instances and @scheme[bitmap-dc%] instances is always - the same for a given platform and a given set of installed fonts. - -See also @method[font% screen-glyph-exists?] . - -} - -@defmethod[(ok?) - boolean?]{ - -Returns @scheme[#t] if the drawing context is usable. - -} - - -@defmethod[(resume-flush) void?]{ - -Calls the @xmethod[canvas<%> resume-flush] method for -@racket[canvas<%>] output, and has no effect for other kinds of -drawing contexts.} - - -@defmethod[(rotate [angle real?]) void?]{ - -Adds a rotation of @racket[angle] radians to the drawing context's -current transformation. - -Afterward, the drawing context's transformation is represented in the -initial transformation matrix, and the separate origin, scale, and -rotation settings have their identity values. - -} - -@defmethod[(scale [x-scale real?] - [y-scale real?]) - void?]{ - -Adds a scaling of @racket[x-scale] in the X-direction and -@racket[y-scale] in the Y-direction to the drawing context's current -transformation. - -Afterward, the drawing context's transformation is represented in the -initial transformation matrix, and the separate origin, scale, and -rotation settings have their identity values. - -} - -@defmethod[(set-alpha [opacity (real-in 0 1)]) - void?]{ - -Determines the opacity of drawing. A value of @scheme[0.0] corresponds -to completely transparent (i.e., invisible) drawing, and @scheme[1.0] -corresponds to completely opaque drawing. For intermediate values, -drawing is blended with the existing content of the drawing context.} - - -@defmethod[(set-background [color (or/c (is-a?/c color%) string?)]) - void?]{ - -Sets the background color for drawing in this object (e.g., using -@method[dc<%> clear] or using a stippled @scheme[brush%] with the mode -@scheme['opaque]). For monochrome drawing, all non-black colors are -treated as white. - -} - -@defmethod*[([(set-brush [brush (is-a?/c brush%)]) - void?] - [(set-brush [color (is-a?/c color%)] - [style (one-of/c 'transparent 'solid 'opaque - 'xor 'hilite 'panel - 'bdiagonal-hatch 'crossdiag-hatch - 'fdiagonal-hatch 'cross-hatch - 'horizontal-hatch 'vertical-hatch)]) - void?] - [(set-brush [color-name string?] - [style (one-of/c 'transparent 'solid 'opaque - 'xor 'hilite 'panel - 'bdiagonal-hatch 'crossdiag-hatch - 'fdiagonal-hatch 'cross-hatch - 'horizontal-hatch 'vertical-hatch)]) - void?])]{ - -Sets the current brush for drawing in this object. While a brush is - selected into a drawing context, it cannot be modified. When a color - and style are given, the arguments are as for @xmethod[brush-list% - find-or-create-brush]. - -} - - -@defmethod[(set-clipping-rect [x real?] - [y real?] - [width (and/c real? (not/c negative?))] - [height (and/c real? (not/c negative?))]) - void?]{ - -Sets the clipping region to a rectangular region. - -See also @method[dc<%> set-clipping-region] and @method[dc<%> -get-clipping-region]. - -@|DrawSizeNote| - -} - -@defmethod[(set-clipping-region [rgn (or/c (is-a?/c region%) false/c)]) - void?]{ - -Sets the clipping region for the drawing area, turning off all - clipping within the drawing region if @scheme[#f] is provided. - -The clipping region must be reset after changing a @scheme[dc<%>] - object's origin or scale (unless it is @scheme[#f]); see - @scheme[region%] for more information. - -See also @method[dc<%> set-clipping-rect] and @method[dc<%> - get-clipping-region]. - -} - -@defmethod[(set-font [font (is-a?/c font%)]) - void?]{ - -Sets the current font for drawing text in this object. - -} - -@defmethod[(set-initial-matrix [m (vector/c real? real? real? real? real? real?)]) - void?]{ - -Set a transformation matrix that converts logical coordinates to - device coordinates. The matrix applies before additional origin - offset, scaling, and rotation. - -See @method[dc<%> get-initial-matrix] for information on the matrix as - represented by a vector @racket[m]. - -See also @method[dc<%> transform], which adds a transformation to the - current transformation, instead of changing the transformation - composition in the middle. - -@|DrawSizeNote| - -} - -@defmethod[(set-origin [x real?] - [y real?]) - void?]{ - -Sets the device origin, i.e., the location in device coordinates of - @math{(0,0)} in logical coordinates. The origin offset applies after - the initial transformation matrix, but before scaling and rotation. - -See also @method[dc<%> translate], which adds a translation to the - current transformation, instead of changing the transformation - composition in the middle. - -@|DrawSizeNote| - -} - -@defmethod*[([(set-pen [pen (is-a?/c pen%)]) - void?] - [(set-pen [color (is-a?/c color%)] - [width (real-in 0 255)] - [style (one-of/c 'transparent 'solid 'xor 'hilite - 'dot 'long-dash 'short-dash 'dot-dash - 'xor-dot 'xor-long-dash 'xor-short-dash - 'xor-dot-dash)]) - void?] - [(set-pen [color-name string?] - [width (real-in 0 255)] - [style (one-of/c 'transparent 'solid 'xor 'hilite - 'dot 'long-dash 'short-dash 'dot-dash - 'xor-dot 'xor-long-dash 'xor-short-dash - 'xor-dot-dash)]) - void?])]{ - -Sets the current pen for this object. When a color, width, and style - are given, the arguments are as for @xmethod[pen-list% - find-or-create-pen]. - -The current pen does not affect text drawing; see also @method[dc<%> - set-text-foreground]. - -While a pen is selected into a drawing context, it cannot be modified. - -} - -@defmethod[(set-rotation [angle real?]) void?]{ - -Set the rotation of logical coordinates in radians to device -coordinates. Rotation applies after the initial transformation matrix, -origin offset, and scaling. - -See also @method[dc<%> rotate], which adds a rotation to the current - transformation, instead of changing the transformation composition. - -@|DrawSizeNote| - -} - -@defmethod[(set-scale [x-scale real?] - [y-scale real?]) - void?]{ - -Sets a scaling factor that maps logical coordinates to device - coordinates. Scaling applies after the initial transformation matrix - and origin offset, but before rotation. Negative scaling factors have - the effect of flipping. - -See also @method[dc<%> scale], which adds a scale to the current - transformation, instead of changing the transformation composition in - the middle. - -@|DrawSizeNote| - -} - -@defmethod[(set-smoothing [mode (one-of/c 'unsmoothed 'smoothed 'aligned)]) - void?]{ - -Enables or disables anti-aliased smoothing for drawing. (Text - smoothing is not affected by this method, and is instead controlled - through the @scheme[font%] object.) - -The smoothing mode is either @scheme['unsmoothed], @scheme['smoothed], - or @scheme['aligned]. Both @scheme['aligned] and @scheme['smoothed] - are smoothing modes. - -In @scheme['smoothed] mode for a canvas or bitmap drawing context, - integer drawing coordinates correspond to the boundary between - pixels, and pen-based drawing is centered over a given line or - curve. Thus, drawing with pen width @scheme[1] from @math{(0, 10)} to - @math{(10, 10)} draws a 2-pixel wide line with @math{50%} opacity. - -The @scheme['aligned] smoothing mode is like @scheme['smoothed], but - it paints pixels more like @scheme['unsmoothed] mode. Since it aligns - shapes to pixel boundaries, @scheme['aligned] mode often produces - better results than @scheme['smoothed], but the results depend on the - application. The @scheme['aligned] mode is defined in terms of - @scheme['smoothed] mode, except that drawing coordinates are rounded - down (via @scheme[floor], after scaling and origin translation). For - line drawing, coordinates are then shifted right and down by the - @scheme[floor] of half a pen width. In addition, for pen drawing - through @method[dc<%> draw-rectangle], @method[dc<%> draw-ellipse], - @method[dc<%> draw-rounded-rectangle], and @method[dc<%> draw-arc], - the given width and height are each decreased by @math{1.0}. - -In either smoothing mode, brush and pen stipples are ignored (except - for PostScript drawing), and @scheme['hilite] and @scheme['xor] - drawing modes are treated as @scheme['solid]. If smoothing is not - supported, then attempting to set the smoothing mode to - @scheme['smoothed] or @scheme['aligned] will have no effect, and - @method[dc<%> get-smoothing] will always return - @scheme['unsmoothed]. Similarly, @method[dc<%> get-smoothing] for a - @scheme[post-script-dc%] always returns @scheme['smoothed]. - -} - -@defmethod[(set-text-background [color (or/c (is-a?/c color%) string?)]) - void?]{ - -Sets the current text background color for this object. The text - background color is painted behind text that is drawn with - @method[dc<%> draw-text], but only for the @scheme['solid] text mode - (see @method[dc<%> set-text-mode]). - -For monochrome drawing, all non-white colors are treated as black. - -} - -@defmethod[(set-text-foreground [color (or/c (is-a?/c color%) string?)]) - void?]{ - -Sets the current text foreground color for this object, used for - drawing text with -@method[dc<%> draw-text]. - -For monochrome drawing, all non-black colors are treated as - white. - -} - -@defmethod[(set-text-mode [mode (one-of/c 'solid 'transparent)]) - void?]{ - -Determines how text is drawn: - -@itemize[ - - @item{@scheme['solid] --- Before text is drawn, the destination area - is filled with the text background color (see @method[dc<%> - set-text-background]).} - - @item{@scheme['transparent] --- Text is drawn directly over any - existing image in the destination, as if overlaying text - written on transparent film.} - -] - -} - - -@defmethod[(set-transformation - [t (vector/c (vector/c real? real? real? real? real? real?) - real? real? real? real? real?)]) - void?]{ - -Sets the draw context's transformation. See @method[dc<%> -get-transformation] for information about @racket[t].} - - -@defmethod[(start-doc [message string?]) - boolean?]{ - -Starts a document, relevant only when drawing to a printer or - PostScript device (including to a PostScript file). For some - platforms, the @scheme[message] string is displayed in a dialog until - @method[dc<%> end-doc] is called. - -For printer or PostScript output, an exception is raised if - @scheme[start-doc] has been called already (even if @method[dc<%> - end-doc] has been called as well). Furthermore, drawing methods raise - an exception if not called while a page is active as determined by - @method[dc<%> start-doc] and @method[dc<%> start-page]. - -} - -@defmethod[(start-page) - void?]{ - -Starts a page, relevant only when drawing to a printer or PostScript - device (including to a PostScript file). - -For printer or PostScript output, an exception is raised if - @scheme[start-page] is called when a page is already started, or when - @method[dc<%> start-doc] has not been called, or when @method[dc<%> - end-doc] has been called already. In addition, in the case of - PostScript output, Encapsulated PostScript (EPS) cannot contain - multiple pages, so calling @scheme[start-page] a second time for a - @scheme[post-script-dc%] instance raises an exception; to create - PostScript output with multiple pages, supply @scheme[#f] as the - @scheme[as-eps] initialization argument for @scheme[post-script-dc%]. - -} - - -@defmethod[(suspend-flush) void?]{ - -Calls the @xmethod[canvas<%> suspend-flush] method for -@racket[canvas<%>] output, and has no effect for other kinds of -drawing contexts.} - - -@defmethod[(transform [m (vector/c real? real? real? real? real? real?)]) - void?]{ - -Adds a transformation by @racket[m] to the drawing context's current -transformation. - -See @method[dc<%> get-initial-matrix] for information on the matrix as - represented by a vector @racket[m]. - -Afterward, the drawing context's transformation is represented in the -initial transformation matrix, and the separate origin, scale, and -rotation settings have their identity values. - -} - -@defmethod[(translate [dx real?] - [dy real?]) - void?]{ - -Adds a scaling of @racket[dx] in the X-direction and @racket[dy] in -the Y-direction to the drawing context's current transformation. - -Afterward, the drawing context's transformation is represented in the -initial transformation matrix, and the separate origin, scale, and -rotation settings have their identity values. - -} - - -@defmethod[(try-color [try (is-a?/c color%)] - [result (is-a?/c color%)]) - void?]{ - -Determines the actual color used for drawing requests with the given - color. The @scheme[result] color is set to the RGB values that are - actually produced for this drawing context to draw the color - @scheme[try]. - -}} From 93126d154692109f5ea35398aa086ca2560a68ff Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 1 Dec 2010 14:21:13 -0700 Subject: [PATCH 229/255] dc, pen, and brush doc corrections related to v5.1 changes --- collects/scribblings/draw/brush-class.scrbl | 54 +++++---------- collects/scribblings/draw/dc-intf.scrbl | 48 ++++++------- collects/scribblings/draw/pen-class.scrbl | 75 +++++---------------- 3 files changed, 53 insertions(+), 124 deletions(-) diff --git a/collects/scribblings/draw/brush-class.scrbl b/collects/scribblings/draw/brush-class.scrbl index fcc7463411..b41f60e65f 100644 --- a/collects/scribblings/draw/brush-class.scrbl +++ b/collects/scribblings/draw/brush-class.scrbl @@ -4,15 +4,13 @@ @defclass/title[brush% object% ()]{ A brush is a drawing tool with a color and a style that is used for - filling in areas, such as the interior of a rectangle or ellipse. On - a monochrome display, all non-white brushes are drawn as black. + filling in areas, such as the interior of a rectangle or ellipse. In + a monochrome destination, all non-white brushes are drawn as black. In addition to its color and style, a brush can have a stipple bitmap. - This stipple is used only in unsmoothed mode (see @method[dc<%> - set-smoothing]) or in a PostScript drawing context. Painting with a + Painting with a stipple brush is similar to calling @method[dc<%> draw-bitmap] with - the stipple bitmap in the filled region, except that the bitmap may - not be scaled in the same way (depending on the platform and device). + the stipple bitmap in the filled region. A brush's style is one of the following: @@ -27,34 +25,19 @@ A brush's style is one of the following: brush's color, and white pixels from the stipple are not transferred.} - @item{@indexed-scheme['opaque] --- Same as @scheme['solid], except when a - monochrome stipple is installed for unsmoothed or PostScript - drawing; in that case, white pixels from the stipple are + @item{@indexed-scheme['opaque] --- The same as @scheme['solid] for a color + stipple. For a monochrome stipple, white pixels from + the stipple are transferred to the destination using the destination's background color.} - @item{@indexed-scheme['xor] --- In a smoothing mode or if a color - stipple is installed, @scheme['xor] is treated as - @scheme['solid]. Otherwise, the brush's color or colored - (monochrome) stipple is xor-ed with existing destination pixel - values. The @scheme['xor] mapping is unspecified for arbitrary - color combinations, but the mapping provides two guarantees: + @item{@indexed-scheme['xor] --- The same as @racket['solid], accepted + only for partial backward compatibility.} - @itemize[ + @item{@indexed-scheme['hilite] --- Draws with black and a @racket[0.3] alpha.} - @item{Black-and-white drawing to a color or monochrome - destination always works as expected: black xor white = black, - white xor black = black, black xor black = white, and white xor - white = white.} - - @item{Performing the same drawing operation twice in a row with - @scheme['xor] is equivalent to a no-op.} - - ]} - - @item{@indexed-scheme['hilite] --- Draws with black and a 30% alpha.} - - @item{@indexed-scheme['panel] --- the same as @scheme['solid].} + @item{@indexed-scheme['panel] --- The same as @scheme['solid], accepted + only for partial backward compatibility.} @item{The following modes correspond to built-in stipples drawn in @scheme['solid] mode: @@ -68,9 +51,8 @@ A brush's style is one of the following: @item{@indexed-scheme['vertical-hatch] --- vertical lines} ] - However, when a specific stipple is installed into the brush - for when drawing with a smoothing mode into a non-PostScript - context, the above modes are ignored and @scheme['solid] is + However, when a specific stipple is installed into the brush, + the above modes are ignored and @scheme['solid] is used, instead.} ] @@ -96,8 +78,7 @@ To avoid creating multiple brushes with the same characteristics, use [stipple (or/c #f (is-a?/c bitmap%)) #f])]{ -When no argument are provided, the result is a solid black brush. - Otherwise, the result is a brush with the given color, style, and stipple. For +Creates a brush with the given color, style, and stipple. For the case that the color is specified using a name, see @scheme[color-database<%>] for information about color names; if the name is not known, the brush's color is black. @@ -148,7 +129,7 @@ For the case that the color is specified using a string, see } -@defmethod[(set-stipple [bitmap (or/c (is-a?/c bitmap%) false/c)]) +@defmethod[(set-stipple [bitmap (or/c (is-a?/c bitmap%) #f)]) void?]{ Sets or removes the stipple bitmap, where @scheme[#f] removes the @@ -161,9 +142,6 @@ A bitmap cannot be used as a stipple if it is selected into a modified if it was obtained from a @scheme[brush-list%] or while it is selected into a drawing context. -A pen's stipple is not used in a smoothing mode, except for a - @scheme[post-script-dc%] (which is always in a smoothing mode). - } @defmethod[(set-style [style (one-of/c 'transparent 'solid 'opaque diff --git a/collects/scribblings/draw/dc-intf.scrbl b/collects/scribblings/draw/dc-intf.scrbl index 4668ba8295..c870723184 100644 --- a/collects/scribblings/draw/dc-intf.scrbl +++ b/collects/scribblings/draw/dc-intf.scrbl @@ -88,7 +88,7 @@ If both the pen and brush are non-transparent, the wedge is filled [mask (or/c (is-a?/c bitmap%) false/c) #f]) boolean?]{ -Displays a bitmap. The @scheme[dest-x] and @scheme[dest-y] arguments +Displays the @racket[source] bitmap. The @scheme[dest-x] and @scheme[dest-y] arguments are in DC coordinates. For color bitmaps, the drawing style and color arguments are @@ -97,30 +97,33 @@ For color bitmaps, the drawing style and color arguments are and color settings to draw a monochrome stipple (see @scheme[brush%] for more information). -If a mask bitmap is supplied, it must have the same width and height - as the bitmap to display, and its @method[bitmap% ok?] must return - true, otherwise @|MismatchExn|. The bitmap to draw and the mask +If a @racket[mask] bitmap is supplied, it must have the same width and height + as @racket[source], and its @method[bitmap% ok?] must return + true, otherwise @|MismatchExn|. The @racket[source] bitmap and @racket[mask] bitmap can be the same object, but if the drawing context is a @scheme[bitmap-dc%] object, both bitmaps must be distinct from the destination bitmap, otherwise @|MismatchExn|. -If the mask bitmap is monochrome, drawing occurs in the target - @scheme[dc<%>] only where the mask bitmap contains black pixels. +If the @racket[mask] bitmap is monochrome, drawing occurs in the + target @scheme[dc<%>] only where the mask bitmap contains black + pixels (independent of @racket[style], which controls how the white + pixels of a monochrome @racket[source] are handled). -If the mask bitmap is grayscale and the bitmap to draw is not - monochrome, then the blackness of each mask pixel controls the - opacity of the drawn pixel (i.e., the mask acts as an inverted alpha - channel). If a mask bitmap is color, the component values of a given - pixel are averaged to arrive at a gray value for the pixel. +If the @racket[mask] bitmap is grayscale, then the blackness of each + mask pixel controls the opacity of the drawn pixel (i.e., the mask + acts as an inverted alpha channel). If the @racket[mask] bitmap is + color, the component values of a given pixel are averaged to arrive + at an @racket[alpha] value for the pixel. -The current brush, current pen, current text, and current alpha - settings for the DC have no effect on how the bitmap is drawn, but - the bitmap is scaled if the DC has a scale. +The current brush, current pen, and current text for the DC have no + effect on how the bitmap is drawn, but the bitmap is scaled if the DC + has a scale, and the DC's alpha setting determines the opacity of the + drawn pixels (in combination with an alpha channel of @racket[bitmap] + and any given @racket[mask]). -For @scheme[post-script-dc%] output, the mask bitmap is currently - ignored, and the @scheme['solid] style is treated the same as - @scheme['opaque]. (However, mask bitmaps and @scheme['solid] drawing - may become supported for @scheme[post-script-dc%] in the future.) +For @scheme[post-script-dc%] and @racket[pdf-dc%] output, opacity from + an alpha channel in @racket[bitmap] or from @racket[mask] is + rounded to full transparency or opacity. The result is @scheme[#t] if the bitmap is successfully drawn, @scheme[#f] otherwise (possibly because the bitmap's @method[bitmap% @@ -987,15 +990,6 @@ The @scheme['aligned] smoothing mode is like @scheme['smoothed], but @method[dc<%> draw-rounded-rectangle], and @method[dc<%> draw-arc], the given width and height are each decreased by @math{1.0}. -In either smoothing mode, brush and pen stipples are ignored (except - for PostScript drawing), and @scheme['hilite] and @scheme['xor] - drawing modes are treated as @scheme['solid]. If smoothing is not - supported, then attempting to set the smoothing mode to - @scheme['smoothed] or @scheme['aligned] will have no effect, and - @method[dc<%> get-smoothing] will always return - @scheme['unsmoothed]. Similarly, @method[dc<%> get-smoothing] for a - @scheme[post-script-dc%] always returns @scheme['smoothed]. - } @defmethod[(set-text-background [color (is-a?/c color%)]) diff --git a/collects/scribblings/draw/pen-class.scrbl b/collects/scribblings/draw/pen-class.scrbl index 4e0b063f53..60e15f5720 100644 --- a/collects/scribblings/draw/pen-class.scrbl +++ b/collects/scribblings/draw/pen-class.scrbl @@ -4,13 +4,11 @@ @defclass/title[pen% object% ()]{ A pen is a drawing tool with a color, width, and style. A pen draws - lines and outlines, such as the outline of a rectangle. On a - monochrome display, all non-white pens are drawn as black. + lines and outlines, such as the outline of a rectangle. In a + monochrome destination, all non-white pens are drawn as black. In addition to its color, width, and style, a pen can have a stipple - bitmap that is a 8 x 8 monochrome bitmap. This stipple is used only - in unsmoothed mode (see @method[dc<%> set-smoothing]) or in a - PostScript drawing context. Painting with a stipple pen is similar to + bitmap. Painting with a stipple pen is similar to calling @method[dc<%> draw-bitmap] with the stipple bitmap in region painted by the pen. @@ -27,36 +25,10 @@ A pen's style is one of the following: brush's color, and white pixels from the stipple are not transferred.} - @item{@indexed-scheme['xor] --- In unsmoothed mode, the pen's color - or colored stipple is xor-ed with existing destination pixel - values. The @scheme['xor] mapping is unspecified for arbitrary - color combinations, but the mapping provides two guarantees: - @itemize[ + @item{@indexed-scheme['xor] --- The same as @racket['solid], accepted + only for partial backward compatibility.} - @item{Black-and-white drawing to a color or monochrome - destination always works as expected: black xor white = black, - white xor black = black, black xor black = white, and white xor - white = white.} - - @item{Performing the same drawing operation twice in a row with - @scheme['xor] is equivalent to a no-op.} - - ] - In a smoothing mode, @scheme['xor] is equivalent to @scheme['solid].} - - @item{@indexed-scheme['hilite] --- In unsmoothed mode, existing - destination pixels are ``highlighted'' in a platform-specific - way when the pen color is black. Under Windows for a color - drawing context, the inverted RGB components of destination - pixel are combined with the RGB components of the system-wide - highlight color using a bitwise ``or'', and the combination is - used. Under Mac OS X for a color drawing context, the - inverted RGB components of the system-wide highlight color are - subtracted from the RGB components of each destination pixel, - and the difference (or 0 for a negative result) is used. Under - X or for any monochrome drawing context, @scheme['hilite] is the - same as @scheme['xor]. In a smoothing mode, @scheme['hilite] is - treated like @scheme['solid].} + @item{@indexed-scheme['hilite] --- Draws with black and a @racket[0.3] alpha.} @item{The following special pen modes use the pen's color, and they only apply when a stipple is not used: @@ -78,15 +50,9 @@ To avoid creating multiple pens with the same characteristics, use the provide a color, width, and style to @xmethod[dc<%> set-pen]. A pen of size @scheme[0] uses the minimum line size for the - destination drawing context. In (unscaled) canvases and bitmaps in - unsmoothed mode, a zero-width pen behaves the nearly same as a pen of - size @scheme[1]. In a smoothing mode (including all - @scheme[post-script-dc%] drawing), a pen of size @scheme[0] draws a - line thinner than a pen of size @scheme[1]. If the pen's width is not - an integer, then the width is truncated to an integer (even before - scaling) in unsmoothed mode. - - + destination drawing context. In (unscaled) canvases and bitmaps, + a zero-width pen behaves the nearly same as a pen of + size @scheme[1]. @defconstructor[([color (or/c string? (is-a?/c color%)) "black"] @@ -103,8 +69,7 @@ A pen of size @scheme[0] uses the minimum line size for the [stipple (or/c #f (is-a?/c bitmap%)) #f])]{ -When no argument are provided, the result is a solid black pen of - width @scheme[0]. Otherwise, the result is a pen with the given +Creates a pen with the given color, width, style, cap style, join style, and stipple. For the case that the color is specified using a name, see @scheme[color-database<%>] for information about @@ -115,8 +80,7 @@ When no argument are provided, the result is a solid black pen of @defmethod[(get-cap) (one-of/c 'round 'projecting 'butt)]{ -Returns the pen cap style (Windows unsmoothed, X unsmoothed, all - smoothing). The default is @scheme['round]. +Returns the pen cap style. The default is @scheme['round]. } @@ -130,8 +94,7 @@ Returns the pen's color object. @defmethod[(get-join) (one-of/c 'round 'bevel 'miter)]{ -Returns the pen join style (Windows unsmoothed, X unsmoothed, all - smoothing). The default is @scheme['round]. +Returns the pen join style. The default is @scheme['round]. } @@ -164,8 +127,7 @@ Returns the pen width. @defmethod[(set-cap [cap-style (one-of/c 'round 'projecting 'butt)]) void?]{ -Sets the pen cap style (Windows unsmoothed, X unsmoothed, all - smoothing). See @method[pen% get-cap] for information about cap +Sets the pen cap style. See @method[pen% get-cap] for information about cap styles. A pen cannot be modified if it was obtained from a @scheme[pen-list%] @@ -192,8 +154,7 @@ A pen cannot be modified if it was obtained from a @defmethod[(set-join [join-style (one-of/c 'round 'bevel 'miter)]) void?]{ -Sets the pen join style (Windows unsmoothed, X unsmoothed, all - smoothing). See @method[pen% get-join] for information about join +Sets the pen join style. See @method[pen% get-join] for information about join styles. A pen cannot be modified if it was obtained from a @@ -201,11 +162,10 @@ A pen cannot be modified if it was obtained from a } -@defmethod[(set-stipple [stipple (or/c (is-a?/c bitmap%) false/c)]) +@defmethod[(set-stipple [stipple (or/c (is-a?/c bitmap%) #f)]) void?]{ -Sets the pen stipple bitmap, which must be an 8 x 8 monochrome bitmap - or @scheme[#f], which turns off the stipple bitmap. +Sets the pen stipple bitmap, where @scheme[#f] turns off the stipple bitmap. A bitmap cannot be used as a stipple if it is selected into a @scheme[bitmap-dc%] object; if the given bitmap is selected into a @@ -213,9 +173,6 @@ A bitmap cannot be used as a stipple if it is selected into a if it was obtained from a @scheme[pen-list%] or while it is selected into a drawing context. -A pen's stipple is not used in a smoothing mode, except for a - @scheme[post-script-dc%] (which is always in smoothed mode). - } @defmethod[(set-style [style (one-of/c 'transparent 'solid 'xor 'hilite From ec122a785ad01920eb851c4a2fdad9240b7f3ef0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 1 Dec 2010 15:48:43 -0700 Subject: [PATCH 230/255] use dots for 'password style text-field% --- collects/mred/private/wxtextfield.rkt | 83 +++++++++++++++++++++------ 1 file changed, 66 insertions(+), 17 deletions(-) diff --git a/collects/mred/private/wxtextfield.rkt b/collects/mred/private/wxtextfield.rkt index e87ae2c890..6f4c7f391f 100644 --- a/collects/mred/private/wxtextfield.rkt +++ b/collects/mred/private/wxtextfield.rkt @@ -1,9 +1,10 @@ -(module wxtextfield mzscheme +(module wxtextfield racket/base (require mzlib/class mzlib/class100 - (prefix wx: "kernel.ss") - (prefix wx: "wxme/text.ss") - (prefix wx: "wxme/editor-canvas.ss") + (prefix-in wx: "kernel.ss") + (prefix-in wx: "wxme/text.ss") + (prefix-in wx: "wxme/snip.ss") + (prefix-in wx: "wxme/editor-canvas.ss") "lock.ss" "const.ss" "check.ss" @@ -17,14 +18,63 @@ "editor.ss" "mrpopup.ss") - (provide (protect wx-text-field%)) + (provide (protect-out wx-text-field%)) + + (define no-pen (send wx:the-pen-list find-or-create-pen "white" 1 'transparent)) + (define black-brush (send wx:the-brush-list find-or-create-brush "black" 'solid)) + + (define password-string-snip% + (class wx:string-snip% + (inherit get-count + get-style + get-text) + (super-new) + + (define delta 2) + (define (get-size) + (max 4 (send (send (get-style) get-font) get-point-size))) + + (define/override (get-extent dc x y [w #f] [h #f] [descent #f] [space #f] [lspace #f] [rspace #f]) + (let ([s (get-size)]) + (when w (set-box! w (* s (get-count)))) + (when h (set-box! h (+ s 2.0))) + (when descent (set-box! descent 1.0)) + (when space (set-box! space 1.0)) + (when lspace (set-box! lspace 0.0)) + (when rspace (set-box! rspace 0.0)))) + (define/override (partial-offset dc x y pos) + (let ([s (get-size)]) + (* s pos))) + (define/override (draw dc x y left top right bottom dx dy draw-caret) + (let ([s (get-size)] + [b (send dc get-brush)] + [p (send dc get-pen)] + [m (send dc get-smoothing)]) + (send dc set-pen no-pen) + (send dc set-brush black-brush) + (send dc set-smoothing 'aligned) + (for/fold ([x x]) ([i (in-range (get-count))]) + (send dc draw-ellipse (+ x delta) (+ y delta 1) (- s delta delta) (- s delta delta)) + (+ x s)) + (send dc set-pen p) + (send dc set-brush b) + (send dc set-smoothing m))) + (define/override (split pos first second) + (let ([a (new password-string-snip%)] + [b (new password-string-snip%)] + [c (get-count)]) + (send a insert (get-text 0 pos) pos) + (send b insert (get-text pos c) (- c pos)) + (set-box! first a) + (set-box! second b))))) (define text-field-text% - (class100 text% (cb ret-cb control set-cb-mgrs! record-text) + (class100 text% (cb ret-cb control set-cb-mgrs! record-text pw?) (rename [super-on-char on-char]) (inherit get-text last-position set-max-undo-history get-flattened-text) (private-field - [return-cb ret-cb]) + [return-cb ret-cb] + [password? pw?]) (private-field [block-callback 1] [callback @@ -42,7 +92,12 @@ (unless (and (or (eq? c #\return) (eq? c #\newline)) return-cb (return-cb (lambda () (callback 'text-field-enter) #t))) - (as-exit (lambda () (super-on-char e)))))))]) + (as-exit (lambda () (super-on-char e)))))))] + [on-new-string-snip + (lambda () + (if password? + (new password-string-snip%) + (super on-new-string-snip)))]) (augment [after-insert (lambda args @@ -91,7 +146,8 @@ (set! without-callback wc) (set! callback-ready cr)) (lambda (t) - (send c set-combo-text t)))]) + (send c set-combo-text t)) + (memq 'password style))]) (sequence (as-exit (lambda () @@ -202,14 +258,7 @@ (send e auto-wrap (and multi? (not (memq 'hscroll style)))) (let ([f font] [s (send (send e get-style-list) find-named-style "Standard")]) - (send s set-delta (let ([d (font->delta f)]) - (if (memq 'password style) - (begin - (send d set-face #f) - (send d set-family 'modern) - (send d set-delta-foreground "darkgray") - (send d set-delta-background "darkgray")) - d)))) + (send s set-delta (font->delta f))) (send c set-editor e) (send c set-line-count (if multi? 3 1)) (unless multi? (send c set-single-line)) From 42dc83bbcd11ecc2e80af0cf18ac60d4a4e3db27 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 1 Dec 2010 15:56:02 -0700 Subject: [PATCH 231/255] fix docs for `get-panel-background' --- collects/scribblings/gui/miscwin-funcs.scrbl | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/collects/scribblings/gui/miscwin-funcs.scrbl b/collects/scribblings/gui/miscwin-funcs.scrbl index fa69a6520a..dcc9cdb021 100644 --- a/collects/scribblings/gui/miscwin-funcs.scrbl +++ b/collects/scribblings/gui/miscwin-funcs.scrbl @@ -107,20 +107,24 @@ default is @racket['(cmd)]. Under X, the default is normally @defproc[(get-panel-background) (is-a?/c color%)]{ -Returns the background color of a panel (usually some shade of gray) - for the current platform. +Returns a shade of gray. +Historically, the result matched the color of +a @racket[panel%] background, but @racket[panel%] backgrounds can vary +on some platforms (e.g., when nested in a @racket[group-box-panel%]), +so the result is no longer guaranteed to be related to a +@racket[panel%]'s color. } @defproc[(get-highlight-background-color) (is-a?/c color%)]{ -Returns the color drawn behind selected text.} +Returns the color that is drawn behind selected text.} @defproc[(get-highlight-text-color) (or/c (is-a?/c color%) #f)]{ -Returns the color used to draw selected text or @racket[#f] if +Returns the color that is used to draw selected text or @racket[#f] if selected text is drawn with its usual color.} From 82ab45b11d3f890d4830248feb95f38dcfe98c56 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 1 Dec 2010 20:48:23 -0700 Subject: [PATCH 232/255] gtk: fix clipboard; implement ye olde X selection --- collects/mred/private/wx/gtk/clipboard.rkt | 122 ++++++++++++--------- collects/mred/private/wx/gtk/queue.rkt | 13 ++- collects/mred/private/wx/gtk/types.rkt | 15 +++ collects/mred/private/wxme/text.rkt | 14 +-- 4 files changed, 104 insertions(+), 60 deletions(-) diff --git a/collects/mred/private/wx/gtk/clipboard.rkt b/collects/mred/private/wx/gtk/clipboard.rkt index 06f013402c..142e2402eb 100644 --- a/collects/mred/private/wx/gtk/clipboard.rkt +++ b/collects/mred/private/wx/gtk/clipboard.rkt @@ -7,6 +7,7 @@ "../../lock.rkt" "../common/queue.rkt" "../common/local.rkt" + "../common/freeze.rkt" "utils.rkt" "types.rkt" "pixbuf.rkt") @@ -16,11 +17,12 @@ has-x-selection? _GtkSelectionData gtk_selection_data_get_length - gtk_selection_data_get_data)) + gtk_selection_data_get_data + primary-atom + get-selection-eventspace)) (define (has-x-selection?) #t) -(define _GdkAtom _int) (define _GtkClipboard (_cpointer 'GtkClipboard)) (define _GtkDisplay _pointer) (define _GtkSelectionData (_cpointer 'GtkSelectionData)) @@ -81,63 +83,71 @@ (define clear_owner (function-ptr clear-owner (_fun #:atomic? #t _GtkClipboard _pointer -> _void))) +(define primary-atom (gdk_atom_intern "PRIMARY" #t)) +(define clipboard-atom (gdk_atom_intern "CLIPBOARD" #t)) + +(define the-x-selection-driver #f) (defclass clipboard-driver% object% (init-field [x-selection? #f]) + (when x-selection? + (set! the-x-selection-driver this)) + (define client #f) (define client-data #f) + (define client-types #f) + (define client-orig-types #f) (define cb (gtk_clipboard_get (if x-selection? - (gdk_atom_intern "CLIPBOARD" #t) - (gdk_atom_intern "PRIMARY" #t)))) + primary-atom + clipboard-atom))) (define self-box #f) (define/public (get-client) client) - (define/public (set-client c types) - (if x-selection? - ;; For now, we can't call it on demand, so we don't call at all: - (queue-event (send c get-client-eventspace) - (lambda () - (send c on-replaced))) - ;; In clipboard mode (as opposed to X selection), we can get the data - ;; now, so it's ready if anyone asks: - (let ([all-data (for/list ([t (in-list types)]) - (send c get-data t))] - [types (for/list ([t (in-list types)]) - (if (equal? t "TEXT") - "UTF8_STRING" - t))]) - (let ([target-strings (malloc 'raw _byte (+ (length types) - (apply + (map string-utf-8-length types))))] - [targets (malloc _GtkTargetEntry (length types))]) - (for/fold ([offset 0]) ([str (in-list types)] - [i (in-naturals)]) - (let ([t (cast (ptr-add targets i _GtkTargetEntry) _pointer _GtkTargetEntry-pointer)]) - (set-GtkTargetEntry-target! t (ptr-add target-strings offset)) - (set-GtkTargetEntry-flags! t 0) - (set-GtkTargetEntry-info! t i)) - (let ([bstr (string->bytes/utf-8 str)]) - (memcpy target-strings offset bstr 0 (bytes-length bstr)) - (let ([offset (+ offset (bytes-length bstr))]) - (ptr-set! (ptr-add target-strings offset) _byte 0) - (+ offset 1)))) - (set! client c) - (set! client-data all-data) - - (atomically - (let ([this-box (malloc-immobile-cell this)]) - (set! self-box this-box) - (gtk_clipboard_set_with_data cb - targets - (length types) - get_data - clear_owner - this-box))) + (define/public (set-client c orig-types) + ;; In clipboard mode (as opposed to X selection), we can get the data + ;; now, so it's ready if anyone asks: + (let ([all-data (if x-selection? + #f + (for/list ([t (in-list orig-types)]) + (send c get-data t)))] + [types (for/list ([t (in-list orig-types)]) + (if (equal? t "TEXT") + "UTF8_STRING" + t))]) + (let ([target-strings (malloc 'raw _byte (+ (length types) + (apply + (map string-utf-8-length types))))] + [targets (malloc _GtkTargetEntry (length types))]) + (for/fold ([offset 0]) ([str (in-list types)] + [i (in-naturals)]) + (let ([t (cast (ptr-add targets i _GtkTargetEntry) _pointer _GtkTargetEntry-pointer)]) + (set-GtkTargetEntry-target! t (ptr-add target-strings offset)) + (set-GtkTargetEntry-flags! t 0) + (set-GtkTargetEntry-info! t i)) + (let ([bstr (string->bytes/utf-8 str)]) + (memcpy target-strings offset bstr 0 (bytes-length bstr)) + (let ([offset (+ offset (bytes-length bstr))]) + (ptr-set! (ptr-add target-strings offset) _byte 0) + (+ offset 1)))) + (set! client c) + (set! client-data all-data) + (set! client-types types) + (set! client-orig-types orig-types) + + (atomically + (let ([this-box (malloc-immobile-cell this)]) + (set! self-box this-box) + (gtk_clipboard_set_with_data cb + targets + (length types) + get_data + clear_owner + this-box))) - (free target-strings))))) + (free target-strings)))) (define/public (replaced s-box) ;; Called in Gtk event-dispatch thread --- atomically with respect @@ -148,19 +158,27 @@ (when c (set! client #f) (set! client-data #f) + (set! client-types #f) + (set! client-orig-types #f) (queue-event (send c get-client-eventspace) (lambda () (send c on-replaced)))))) (free-immobile-cell s-box)) (define/public (provide-data i sel-data) - ;; Called in Gtk event-dispatch thread --- atomically with respect - ;; to any other thread + ;; In atomic mode; if it's the selection (not clipboard), + ;; then hopefully we're in the right eventspace (let ([bstr (if client - (list-ref client-data i) + (if client-data + (list-ref client-data i) + (constrained-reply (send client get-client-eventspace) + (lambda () + (send client get-data + (list-ref client-orig-types i))) + #"")) #"")]) (gtk_selection_data_set sel-data - (gdk_atom_intern "UTF8_STRING" #t) + (gdk_atom_intern (list-ref client-types i) #t) 8 bstr (bytes-length bstr)))) @@ -190,3 +208,9 @@ (gobject-unref pixbuf))))) (super-new)) + +(define (get-selection-eventspace) + (and the-x-selection-driver + (let ([c (send the-x-selection-driver get-client)]) + (and c + (send c get-client-eventspace))))) diff --git a/collects/mred/private/wx/gtk/queue.rkt b/collects/mred/private/wx/gtk/queue.rkt index 80855f657e..fb371bf31e 100644 --- a/collects/mred/private/wx/gtk/queue.rkt +++ b/collects/mred/private/wx/gtk/queue.rkt @@ -6,6 +6,7 @@ "../../lock.rkt" "../common/queue.rkt" "../common/freeze.rkt" + "clipboard.rkt" "const.rkt" "w32.rkt" "unique.rkt") @@ -163,11 +164,19 @@ (let* ([gtk (gtk_get_event_widget evt)] [wx (and gtk (widget-hook gtk))]) (cond - [(and (= (ptr-ref evt _int) GDK_EXPOSE) + [(and (= (ptr-ref evt _GdkEventType) GDK_EXPOSE) wx (send wx direct-update?)) (gtk_main_do_event evt)] - [(and wx (send wx get-eventspace)) + [(or + ;; event for a window that we control? + (and wx (send wx get-eventspace)) + ;; event to get X selection data? + (and (= (ptr-ref evt _GdkEventType) GDK_SELECTION_REQUEST) + (let ([s (cast evt _pointer _GdkEventSelection-pointer)]) + (= (GdkEventSelection-selection s) + primary-atom)) + (get-selection-eventspace))) => (lambda (e) (let ([evt (gdk_event_copy evt)]) (queue-event e (lambda () diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt index 0274dc503e..0fb0221287 100644 --- a/collects/mred/private/wx/gtk/types.rkt +++ b/collects/mred/private/wx/gtk/types.rkt @@ -8,6 +8,8 @@ _GdkScreen _gpointer _GType + _GdkEventType + _GdkAtom _fnpointer _gboolean @@ -27,6 +29,8 @@ (struct-out GdkEventConfigure) _GdkEventExpose _GdkEventExpose-pointer (struct-out GdkEventExpose) + _GdkEventSelection _GdkEventSelection-pointer + (struct-out GdkEventSelection) (struct-out GdkRectangle) _GdkColor _GdkColor-pointer (struct-out GdkColor))) @@ -50,6 +54,8 @@ (define _gfloat _float) (define _GdkEventType _int) +(define _GdkAtom _int) + (define-cstruct _GdkEventButton ([type _GdkEventType] [window _GdkWindow] [send_event _byte] @@ -123,6 +129,15 @@ [width _int] [height _int])) +(define-cstruct _GdkEventSelection ([type _GdkEventType] + [window _GdkWindow] + [send_event _byte] + [selection _GdkAtom] + [target _GdkAtom] + [property _GdkAtom] + [time _uint32] + [requestor _pointer])) + (define-cstruct _GdkRectangle ([x _int] [y _int] [width _int] diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index 050bfa9c83..be32c886a3 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -49,12 +49,7 @@ (define outline-pen (send the-pen-list find-or-create-pen "BLACK" 0 'transparent)) (define outline-inactive-pen (send the-pen-list find-or-create-pen (get-highlight-background-color) 1 'solid)) (define outline-brush (send the-brush-list find-or-create-brush (get-highlight-background-color) 'solid)) -(define xpattern #"\x88\x88\0\0\x22\x22\0\0\x88\x88\0\0\x22\x22\0\0\x88\x88\0\0\x22\x22\0\0\x88\x88\0\0\x22\x22\0\0") -(define outline-nonowner-brush (let ([b (new brush%)]) - (send b set-color "BLACK") - (send b set-stipple (make-object bitmap% xpattern 16 16)) - (send b set-style 'xor) - b)) +(define outline-nonowner-brush outline-brush) (define clear-brush (send the-brush-list find-or-create-brush "WHITE" 'solid)) (define (showcaret>= a b) @@ -5257,9 +5252,10 @@ hilite-some? hsxs hsxe hsys hsye old-style)))))))))) (let*-values ([(draw-first?) - (or (not (showcaret>= show-caret 'show-caret)) - (and s-caret-snip (not (pair? show-caret))) - (not hilite-on?) + (or (and (or (not (showcaret>= show-caret 'show-caret)) + (and s-caret-snip (not (pair? show-caret))) + (not hilite-on?)) + (not show-xsel?)) (= -startpos -endpos) (-endpos . < . pcounter) (-startpos . > . (+ pcounter (mline-len line))))] From 170905d3328fcd77ce2ce917fd7eaca0ac4dd835 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 2 Dec 2010 03:50:10 -0500 Subject: [PATCH 233/255] New Racket version 5.0.99.4. --- src/worksp/racket/racket.manifest | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/worksp/racket/racket.manifest b/src/worksp/racket/racket.manifest index 52262cb7a4..6a3fa4ae95 100644 --- a/src/worksp/racket/racket.manifest +++ b/src/worksp/racket/racket.manifest @@ -1,7 +1,7 @@ Date: Tue, 30 Nov 2010 05:21:53 -0500 Subject: [PATCH 234/255] Indent manifest files. --- collects/meta/build/versionpatch | 4 +-- src/worksp/gracket/gracket.manifest | 40 +++++++++++++---------------- src/worksp/racket/racket.manifest | 40 +++++++++++++---------------- 3 files changed, 38 insertions(+), 46 deletions(-) diff --git a/collects/meta/build/versionpatch b/collects/meta/build/versionpatch index d9e56341b2..8e62e6113d 100755 --- a/collects/meta/build/versionpatch +++ b/collects/meta/build/versionpatch @@ -22,8 +22,8 @@ exec racket -um "$0" "$@" "(?:\\\\0)?\"") (concat "\r\n *VALUE \"ProductVersion\", *\""commas "(?:\\\\0)?\""))] - [manifest-patch (list (concat "assemblyIdentity *\r\n *version *" - "= *\""periods"\" *\r\n"))]) + [manifest-patch (list (concat "assemblyIdentity[ \r\n]+" + "version=\""periods"\"[ \r\n]"))]) `([#t ; only verify that it has the right contents "src/racket/src/schvers.h" ,(concat "\n#define MZSCHEME_VERSION \"<1>.<2>" diff --git a/src/worksp/gracket/gracket.manifest b/src/worksp/gracket/gracket.manifest index 75b654dae1..a183a2bd02 100644 --- a/src/worksp/gracket/gracket.manifest +++ b/src/worksp/gracket/gracket.manifest @@ -1,22 +1,18 @@ - - - -GRacket - Graphical Racket. - - - - - - + + + + GRacket: Graphical Racket. + + + + + + diff --git a/src/worksp/racket/racket.manifest b/src/worksp/racket/racket.manifest index 6a3fa4ae95..fa09e236d9 100644 --- a/src/worksp/racket/racket.manifest +++ b/src/worksp/racket/racket.manifest @@ -1,22 +1,18 @@ - - - -Racket. - - - - - - + + + + Racket. + + + + + + From 3419b747b650bf08d8abf724d74f8fb80ab1e978 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 30 Nov 2010 05:28:36 -0500 Subject: [PATCH 235/255] Add trustInfo to avoid UAC, commented out for now. --- src/worksp/gracket/gracket.manifest | 10 ++++++++++ src/worksp/racket/racket.manifest | 10 ++++++++++ 2 files changed, 20 insertions(+) diff --git a/src/worksp/gracket/gracket.manifest b/src/worksp/gracket/gracket.manifest index a183a2bd02..23b39027c9 100644 --- a/src/worksp/gracket/gracket.manifest +++ b/src/worksp/gracket/gracket.manifest @@ -5,6 +5,16 @@ name="Org.PLT-Scheme.GRacket" type="win32" /> GRacket: Graphical Racket. + + Racket. + + Date: Wed, 1 Dec 2010 20:58:21 -0700 Subject: [PATCH 236/255] fix `screen-glyph-exists?' in font% --- collects/racket/draw/private/dc.rkt | 40 ---------------- collects/racket/draw/private/font.rkt | 67 +++++++++++++++++++++++++-- 2 files changed, 64 insertions(+), 43 deletions(-) diff --git a/collects/racket/draw/private/dc.rkt b/collects/racket/draw/private/dc.rkt index d1a515f062..b93569de81 100644 --- a/collects/racket/draw/private/dc.rkt +++ b/collects/racket/draw/private/dc.rkt @@ -64,9 +64,6 @@ (real? (vector-ref v 4)) (real? (vector-ref v 5)))) -(define substitute-fonts? (memq (system-type) '(macosx))) -(define substitute-mapping (make-hasheq)) - ;; dc-backend : interface ;; ;; This is the interface that the backend specific code must implement @@ -1385,43 +1382,6 @@ (vector-set! vec 3 #f) (vector-set! vec 4 #f))))) - (define/private (install-alternate-face ch layout font desc attrs context) - (or - (for/or ([face (in-list - (let ([v (hash-ref substitute-mapping (char->integer ch) #f)]) - (cond - [(string? v) - ;; found previously - (list v)] - [v - ;; failed to find previously - null] - [else - ;; Hack: prefer Lucida Grande - (cons "Lucida Grande" (get-face-list))])))]) - (let ([desc (get-pango (make-object font% - (send font get-point-size) - face - (send font get-family) - (send font get-style) - (send font get-weight) - (send font get-underlined) - (send font get-smoothing) - (send font get-size-in-pixels)))]) - (and desc - (let ([attrs (send font get-pango-attrs)]) - (pango_layout_set_font_description layout desc) - (when attrs (pango_layout_set_attributes layout attrs)) - (and (zero? (pango_layout_get_unknown_glyphs_count layout)) - (begin - (hash-set! substitute-mapping (char->integer ch) face) - #t)))))) - (begin - (hash-set! substitute-mapping (char->integer ch) #t) - ;; put old desc & attrs back - (pango_layout_set_font_description layout desc) - (when attrs (pango_layout_set_attributes layout attrs))))) - (def/public (get-char-width) 10.0) diff --git a/collects/racket/draw/private/font.rkt b/collects/racket/draw/private/font.rkt index 0a5264486d..c295b0f7f0 100644 --- a/collects/racket/draw/private/font.rkt +++ b/collects/racket/draw/private/font.rkt @@ -4,6 +4,7 @@ ffi/unsafe/atomic "syntax.ss" "../unsafe/pango.ss" + "../unsafe/cairo.ss" "font-syms.ss" "font-dir.ss" "local.ss") @@ -12,7 +13,9 @@ font-list% the-font-list family-symbol? style-symbol? weight-symbol? smoothing-symbol? get-pango-attrs - get-face-list) + get-face-list + (protect-out substitute-fonts? + install-alternate-face)) (define-local-member-name get-pango-attrs) @@ -37,6 +40,65 @@ (define-syntax-rule (atomically e) (begin (start-atomic) (begin0 e (end-atomic)))) +(define substitute-fonts? (memq (system-type) '(macosx))) +(define substitute-mapping (make-hasheq)) + +(define (install-alternate-face ch layout font desc attrs context) + (or + (for/or ([face (in-list + (let ([v (hash-ref substitute-mapping (char->integer ch) #f)]) + (cond + [(string? v) + ;; found previously + (list v)] + [v + ;; failed to find previously + null] + [else + ;; Hack: prefer Lucida Grande + (cons "Lucida Grande" (get-face-list))])))]) + (let ([desc (send (make-object font% + (send font get-point-size) + face + (send font get-family) + (send font get-style) + (send font get-weight) + (send font get-underlined) + (send font get-smoothing) + (send font get-size-in-pixels)) + get-pango)]) + (and desc + (let ([attrs (send font get-pango-attrs)]) + (pango_layout_set_font_description layout desc) + (when attrs (pango_layout_set_attributes layout attrs)) + (and (zero? (pango_layout_get_unknown_glyphs_count layout)) + (begin + (hash-set! substitute-mapping (char->integer ch) face) + #t)))))) + (begin + (hash-set! substitute-mapping (char->integer ch) #t) + ;; put old desc & attrs back + (pango_layout_set_font_description layout desc) + (when attrs (pango_layout_set_attributes layout attrs))))) + +(define (has-screen-glyph? c font desc for-label?) + (let* ([s (cairo_image_surface_create CAIRO_FORMAT_ARGB32 1 1)] + [cr (cairo_create s)] + [context (pango_cairo_create_context cr)] + [layout (pango_layout_new context)]) + (pango_layout_set_font_description layout desc) + (pango_layout_set_text layout (string c)) + (pango_cairo_update_layout cr layout) + (begin0 + (or (zero? (pango_layout_get_unknown_glyphs_count layout)) + (and substitute-fonts? + (install-alternate-face c layout font desc #f context) + (zero? (pango_layout_get_unknown_glyphs_count layout)))) + (g_object_unref layout) + (g_object_unref context) + (cairo_destroy cr) + (cairo_surface_destroy s)))) + (defclass font% object% (define table-key #f) @@ -125,8 +187,7 @@ (def/public (screen-glyph-exists? [char? c] [any? [for-label? #f]]) - ;; FIXME: - #t) + (has-screen-glyph? c this (get-pango) for-label?)) (init-rest args) (super-new) From 7a37b07e263a72ba40b7aed9c759a2ed84b4bb08 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 2 Dec 2010 06:16:51 -0700 Subject: [PATCH 237/255] gtk: fix clipboard problems on 64-bit mode; provide more text formats --- collects/mred/private/wx/common/freeze.rkt | 4 +- collects/mred/private/wx/gtk/clipboard.rkt | 88 ++++++++++++---------- collects/mred/private/wx/gtk/queue.rkt | 8 +- collects/mred/private/wx/gtk/types.rkt | 2 +- 4 files changed, 56 insertions(+), 46 deletions(-) diff --git a/collects/mred/private/wx/common/freeze.rkt b/collects/mred/private/wx/common/freeze.rkt index 92c1566583..7ee55836a3 100644 --- a/collects/mred/private/wx/common/freeze.rkt +++ b/collects/mred/private/wx/common/freeze.rkt @@ -40,9 +40,7 @@ ;; Ideally, this would count as an error that we can fix. It seems that we ;; don't always have enough control to use the right eventspace with a ;; retry point, though, so just bail out with the default. - #; - (internal-error (format "constrained-reply not within an unfreeze point for ~s" - thunk)) + #;(internal-error (format "constrained-reply not within an unfreeze point for ~s" thunk)) fail-result] [(not (eq? (current-thread) (eventspace-handler-thread es))) (internal-error "wrong eventspace for constrained event handling\n") diff --git a/collects/mred/private/wx/gtk/clipboard.rkt b/collects/mred/private/wx/gtk/clipboard.rkt index 142e2402eb..82bee0c632 100644 --- a/collects/mred/private/wx/gtk/clipboard.rkt +++ b/collects/mred/private/wx/gtk/clipboard.rkt @@ -108,50 +108,62 @@ (define/public (get-client) client) (define/public (set-client c orig-types) - ;; In clipboard mode (as opposed to X selection), we can get the data - ;; now, so it's ready if anyone asks: (let ([all-data (if x-selection? + ;; In X selection mode, get the data on demand: #f + ;; In clipboard mode, we can get the data + ;; now, so it's ready if anyone asks: (for/list ([t (in-list orig-types)]) (send c get-data t)))] [types (for/list ([t (in-list orig-types)]) (if (equal? t "TEXT") "UTF8_STRING" t))]) - (let ([target-strings (malloc 'raw _byte (+ (length types) - (apply + (map string-utf-8-length types))))] - [targets (malloc _GtkTargetEntry (length types))]) - (for/fold ([offset 0]) ([str (in-list types)] - [i (in-naturals)]) - (let ([t (cast (ptr-add targets i _GtkTargetEntry) _pointer _GtkTargetEntry-pointer)]) - (set-GtkTargetEntry-target! t (ptr-add target-strings offset)) - (set-GtkTargetEntry-flags! t 0) - (set-GtkTargetEntry-info! t i)) - (let ([bstr (string->bytes/utf-8 str)]) - (memcpy target-strings offset bstr 0 (bytes-length bstr)) - (let ([offset (+ offset (bytes-length bstr))]) - (ptr-set! (ptr-add target-strings offset) _byte 0) - (+ offset 1)))) - (set! client c) - (set! client-data all-data) - (set! client-types types) - (set! client-orig-types orig-types) - - (atomically - (let ([this-box (malloc-immobile-cell this)]) - (set! self-box this-box) - (gtk_clipboard_set_with_data cb - targets - (length types) - get_data - clear_owner - this-box))) + (let-values ([(orig-types types all-data) + ;; For "TEXT", provide "UTF8_STRING", "STRING", and "TEXT": + (if (member "TEXT" orig-types) + (values (append orig-types (list "TEXT" "TEXT")) + (append types (list "STRING" "TEXT")) + (and all-data (append all-data + (let loop ([all-data all-data] + [orig-types orig-types]) + (if (equal? "TEXT" (car orig-types)) + (list (car all-data) (car all-data)) + (loop (cdr all-data) (cdr orig-types))))))) + (values orig-types types all-data))]) + (let ([target-strings (malloc 'raw _byte (+ (length types) + (apply + (map string-utf-8-length types))))] + [targets (malloc _GtkTargetEntry (length types))]) + (for/fold ([offset 0]) ([str (in-list types)] + [i (in-naturals)]) + (let ([t (cast (ptr-add targets i _GtkTargetEntry) _pointer _GtkTargetEntry-pointer)]) + (set-GtkTargetEntry-target! t (ptr-add target-strings offset)) + (set-GtkTargetEntry-flags! t 0) + (set-GtkTargetEntry-info! t i)) + (let ([bstr (string->bytes/utf-8 str)]) + (memcpy target-strings offset bstr 0 (bytes-length bstr)) + (let ([offset (+ offset (bytes-length bstr))]) + (ptr-set! (ptr-add target-strings offset) _byte 0) + (+ offset 1)))) + (set! client c) + (set! client-data all-data) + (set! client-types types) + (set! client-orig-types orig-types) + + (atomically + (let ([this-box (malloc-immobile-cell this)]) + (set! self-box this-box) + (gtk_clipboard_set_with_data cb + targets + (length types) + get_data + clear_owner + this-box))) - (free target-strings)))) + (free target-strings))))) (define/public (replaced s-box) - ;; Called in Gtk event-dispatch thread --- atomically with respect - ;; to any other thread + ;; In atomic mode (when (ptr-equal? s-box self-box) (set! self-box #f) (let ([c client]) @@ -177,11 +189,11 @@ (list-ref client-orig-types i))) #"")) #"")]) - (gtk_selection_data_set sel-data - (gdk_atom_intern (list-ref client-types i) #t) - 8 - bstr - (bytes-length bstr)))) + (gtk_selection_data_set sel-data + (gdk_atom_intern (list-ref client-types i) #t) + 8 + bstr + (bytes-length bstr)))) (define/public (get-data format) (let ([process (lambda (v) diff --git a/collects/mred/private/wx/gtk/queue.rkt b/collects/mred/private/wx/gtk/queue.rkt index fb371bf31e..110e8932d6 100644 --- a/collects/mred/private/wx/gtk/queue.rkt +++ b/collects/mred/private/wx/gtk/queue.rkt @@ -173,10 +173,10 @@ (and wx (send wx get-eventspace)) ;; event to get X selection data? (and (= (ptr-ref evt _GdkEventType) GDK_SELECTION_REQUEST) - (let ([s (cast evt _pointer _GdkEventSelection-pointer)]) - (= (GdkEventSelection-selection s) - primary-atom)) - (get-selection-eventspace))) + (let ([s (cast evt _pointer _GdkEventSelection-pointer)]) + (= (GdkEventSelection-selection s) + primary-atom)) + (get-selection-eventspace))) => (lambda (e) (let ([evt (gdk_event_copy evt)]) (queue-event e (lambda () diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt index 0fb0221287..0dc4d8c1fe 100644 --- a/collects/mred/private/wx/gtk/types.rkt +++ b/collects/mred/private/wx/gtk/types.rkt @@ -54,7 +54,7 @@ (define _gfloat _float) (define _GdkEventType _int) -(define _GdkAtom _int) +(define _GdkAtom _long) (define-cstruct _GdkEventButton ([type _GdkEventType] [window _GdkWindow] From 74d858ceedf93c1eb95be2f4cadbdab79f5bdfd8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 2 Dec 2010 06:20:07 -0700 Subject: [PATCH 238/255] gtk: fix GdkAtom type --- collects/mred/private/wx/gtk/types.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt index 0dc4d8c1fe..20bb567ccd 100644 --- a/collects/mred/private/wx/gtk/types.rkt +++ b/collects/mred/private/wx/gtk/types.rkt @@ -54,7 +54,7 @@ (define _gfloat _float) (define _GdkEventType _int) -(define _GdkAtom _long) +(define _GdkAtom _intptr) (define-cstruct _GdkEventButton ([type _GdkEventType] [window _GdkWindow] From 1032eb4a59d0987e2628c633059545b338751f9a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 2 Dec 2010 06:31:36 -0700 Subject: [PATCH 239/255] restore fix of 470ed7c996dca2f0801f43efc768f1082c7bea92 that got lost --- collects/racket/draw/unsafe/pango.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/racket/draw/unsafe/pango.rkt b/collects/racket/draw/unsafe/pango.rkt index 7779deadb9..3101f1290e 100644 --- a/collects/racket/draw/unsafe/pango.rkt +++ b/collects/racket/draw/unsafe/pango.rkt @@ -211,7 +211,7 @@ -> (begin0 (for/list ([i (in-range len)]) (ptr-ref fams PangoFontFamily i)) - (free fams)))) + (g_free fams)))) (define-pango pango_font_description_free (_fun PangoFontDescription -> _void) #:wrap (deallocator)) From b0a746c701d2bc2b9380d66f98eedbd3f94736e0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 2 Dec 2010 07:04:38 -0700 Subject: [PATCH 240/255] win32: fix font used to size controls --- collects/mred/private/wx/win32/window.rkt | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index caca412bcd..3ca1072ca2 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -322,7 +322,7 @@ [dc (make-object bitmap-dc% bm)]) (set! measure-dc dc))) (send measure-dc set-font (or font - (make-object font% 8 'system))) + (get-default-control-font))) (let-values ([(w h d a) (let loop ([label label]) (cond [(null? label) (values 0 0 0 0)] @@ -689,6 +689,18 @@ ;; ---------------------------------------- +(define default-control-font #f) +(define (get-default-control-font) + (unless default-control-font + (set! default-control-font + (make-object font% + (get-theme-font-size) + (get-theme-font-face) + 'system + 'normal 'normal #f 'default + #t))) + default-control-font) + (define (queue-window-event win thunk) (queue-event (send win get-eventspace) thunk)) From d4857c4420fb5f81d2af460e581e0da141422347 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 30 Nov 2010 17:35:08 -0600 Subject: [PATCH 241/255] adjusted check syntax so that it does renaming better. Specifically, it finds all variables that match the one being renamed in the fully expanded program, as well as all variables that have the same source locations of any of those (etc). --- .../drracket/private/syncheck/traversals.rkt | 153 +++++++++--------- 1 file changed, 75 insertions(+), 78 deletions(-) diff --git a/collects/drracket/private/syncheck/traversals.rkt b/collects/drracket/private/syncheck/traversals.rkt index fff9e42173..69f3ae9557 100644 --- a/collects/drracket/private/syncheck/traversals.rkt +++ b/collects/drracket/private/syncheck/traversals.rkt @@ -627,18 +627,7 @@ (color-unused require-for-syntaxes unused-require-for-syntaxes) (color-unused requires unused-requires) - (define src-loc-id-table (make-hash)) - (for ([id-set (in-list id-sets)]) - (for-each-ids - id-set - (λ (ids) - (for ([id (in-list ids)]) - (define key (list (syntax-source id) - (syntax-position id) - (syntax-span id))) - (hash-set! src-loc-id-table key (hash-ref src-loc-id-table key '())))))) - - (hash-for-each rename-ht (lambda (k stxs) (make-rename-menu stxs id-sets src-loc-id-table))))) + (hash-for-each rename-ht (lambda (k stxs) (make-rename-menu k rename-ht id-sets))))) ;; record-renamable-var : rename-ht syntax -> void @@ -1321,25 +1310,29 @@ ; ;;; - ;; make-rename-menu : (cons stx[original,id] (listof stx[original,id])) - ;; (listof id-set) - ;; hash[(list source number number) -o> (listof syntax)] - ;; -> void - (define (make-rename-menu stxs id-sets src-loc-id-table) - (let ([defs-text (currently-processing-definitions-text)]) + ;; make-rename-menu : (list source number number) rename-ht (listof id-set) -> void + (define (make-rename-menu key rename-ht id-sets) + (let* ([source (list-ref key 0)] + [pos (list-ref key 1)] + [span (list-ref key 2)] + [defs-text (currently-processing-definitions-text)] + [example-id + ;; we know that there is at least one there b/c that's how make-rename-menu is called + (car (hash-ref rename-ht key))] + [id-as-sym (syntax-e example-id)]) + (when defs-text - (let* ([source (syntax-source (car stxs))] ;; all stxs in the list must have the same source - [source-editor (find-source-editor (car stxs))]) + (let ([source-editor (find-source-editor example-id)]) (when (is-a? source-editor text%) - (let* ([start (- (syntax-position (car stxs)) 1)] - [fin (+ start (syntax-span (car stxs)))]) + (let* ([start (- pos 1)] + [fin (+ start span)]) (send defs-text syncheck:add-menu source-editor start fin - (syntax-e (car stxs)) + id-as-sym (λ (menu) - (let ([name-to-offer (format "~a" (syntax->datum (car stxs)))]) + (let ([name-to-offer (format "~a" id-as-sym)]) (instantiate menu-item% () (parent menu) (label (fw:gui-utils:format-literal-label (string-constant cs-rename-var) name-to-offer)) @@ -1348,9 +1341,9 @@ (let ([frame-parent (find-menu-parent menu)]) (rename-callback name-to-offer defs-text - stxs + key id-sets - src-loc-id-table + rename-ht frame-parent)))))))))))))) ;; find-parent : menu-item-container<%> -> (union #f (is-a?/c top-level-window<%>) @@ -1373,13 +1366,13 @@ ;; rename-callback : string ;; (and/c syncheck-text<%> definitions-text<%>) - ;; (listof syntax[original]) + ;; (list source number number) ;; (listof id-set) - ;; hash[(list source number number) -o> (listof syntax)] + ;; rename-ht ;; (union #f (is-a?/c top-level-window<%>)) ;; -> void ;; callback for the rename popup menu item - (define (rename-callback name-to-offer defs-text stxs id-sets src-loc-id-table parent) + (define (rename-callback name-to-offer defs-text key id-sets rename-ht parent) (let ([new-str (fw:keymap:call/text-keymap-initializer (λ () @@ -1389,61 +1382,65 @@ parent name-to-offer)))]) (when new-str - (let* ([new-sym (format "~s" (string->symbol new-str))] - [raw-to-be-renamed - (let ([raw '()]) - (for ([id-set (in-list id-sets)]) - (for ([stx (in-list stxs)]) - (for ([id (in-list (or (get-ids id-set stx) '()))]) - (set! raw (cons id raw))))) - raw)] - [to-be-renamed - (remove-duplicates-stx - (sort raw-to-be-renamed - >= - #:key syntax-position))] - [do-renaming? - (or (not (name-duplication? to-be-renamed id-sets new-sym)) - (equal? - (message-box/custom - (string-constant check-syntax) - (fw:gui-utils:format-literal-label (string-constant cs-name-duplication-error) - new-sym) - (string-constant cs-rename-anyway) - (string-constant cancel) - #f - parent - '(stop default=2)) - 1))]) - (when do-renaming? - (unless (null? to-be-renamed) - (let ([txts (list defs-text)]) - (send defs-text begin-edit-sequence) - (for-each (λ (stx) - (let ([source-editor (find-source-editor/defs stx defs-text)]) - (when (is-a? source-editor text%) - (unless (memq source-editor txts) - (send source-editor begin-edit-sequence) - (set! txts (cons source-editor txts))) - (let* ([start (- (syntax-position stx) 1)] - [end (+ start (syntax-span stx))]) - (send source-editor delete start end #f) - (send source-editor insert new-sym start start #f))))) - to-be-renamed) - (send defs-text invalidate-bitmap-cache) - (for-each - (λ (txt) (send txt end-edit-sequence)) - txts)))))))) + (define new-sym (format "~s" (string->symbol new-str))) + (define src-locs (make-hash)) + (define all-stxs (make-hash)) + (let loop ([key key]) + (unless (hash-ref src-locs key #f) + (hash-set! src-locs key #t) + (for ([stx (in-list (hash-ref rename-ht key))]) + (for ([id-set (in-list id-sets)]) + (for ([stx (in-list (or (get-ids id-set stx) '()))]) + (hash-set! all-stxs stx #t) + (loop (list (syntax-source stx) + (syntax-position stx) + (syntax-span stx)))))))) + (define locs-to-be-renamed + (sort (hash-map src-locs (λ (k v) k)) + >= + #:key cadr)) + (define to-be-renamed (hash-map all-stxs (λ (k v) k))) + (define do-renaming? + (or (not (name-duplication? to-be-renamed id-sets new-sym)) + (equal? + (message-box/custom + (string-constant check-syntax) + (fw:gui-utils:format-literal-label (string-constant cs-name-duplication-error) + new-sym) + (string-constant cs-rename-anyway) + (string-constant cancel) + #f + parent + '(stop default=2)) + 1))) + (when do-renaming? + (unless (null? to-be-renamed) + (let ([txts (list defs-text)]) + (send defs-text begin-edit-sequence) + (for-each (λ (stx) + (let ([source-editor (find-source-editor/defs stx defs-text)]) + (when (is-a? source-editor text%) + (unless (memq source-editor txts) + (send source-editor begin-edit-sequence) + (set! txts (cons source-editor txts))) + (let* ([start (- (syntax-position stx) 1)] + [end (+ start (syntax-span stx))]) + (send source-editor delete start end #f) + (send source-editor insert new-sym start start #f))))) + to-be-renamed) + (send defs-text invalidate-bitmap-cache) + (for-each + (λ (txt) (send txt end-edit-sequence)) + txts))))))) ;; name-duplication? : (listof syntax) (listof id-set) symbol -> boolean ;; returns #t if the name chosen would be the same as another name in this scope. (define (name-duplication? to-be-renamed id-sets new-str) (let ([new-ids (map (λ (id) (datum->syntax id (string->symbol new-str))) to-be-renamed)]) - (ormap (λ (id-set) - (ormap (λ (new-id) (get-ids id-set new-id)) - new-ids)) - id-sets))) + (for*/or ([id-set (in-list id-sets)] + [new-id (in-list new-ids)]) + (get-ids id-set new-id)))) ;; remove-duplicates-stx : (listof syntax[original]) -> (listof syntax[original]) ;; removes duplicates, based on the source locations of the identifiers From 9501a9d7f8c63e6cd2983d2be7e63b28e1bc8c11 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 2 Dec 2010 09:20:09 -0600 Subject: [PATCH 242/255] adjustments to match gr2 --- collects/tests/drracket/drracket-test-util.rkt | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/collects/tests/drracket/drracket-test-util.rkt b/collects/tests/drracket/drracket-test-util.rkt index b7a6bff21c..d64427d7c9 100644 --- a/collects/tests/drracket/drracket-test-util.rkt +++ b/collects/tests/drracket/drracket-test-util.rkt @@ -177,9 +177,9 @@ (let ([window (send frame get-focus-window)]) (let-values ([(cw ch) (send window get-client-size)] [(w h) (send window get-size)]) - (fw:test:mouse-click 'left - (inexact->exact (+ cw (floor (/ (- w cw) 2)))) - (inexact->exact (+ ch (floor (/ (- h ch) 2))))))) + (fw:test:mouse-click 'left + (inexact->exact (floor (+ cw (/ (- w cw) 2)))) + (inexact->exact (floor (+ ch (/ (- h ch) 2))))))) (fw:test:menu-select "Edit" "Select All") (fw:test:menu-select "Edit" (if (eq? (system-type) 'macos) "Clear" @@ -332,8 +332,8 @@ (let-values ([(gx gy) (send editor editor-location-to-dc-location (unbox b1) (unbox b2))]) - (let ([x (inexact->exact (+ gx between-threshold 1))] - [y (inexact->exact (+ gy between-threshold 1))]) + (let ([x (inexact->exact (floor (+ gx between-threshold 1)))] + [y (inexact->exact (floor (+ gy between-threshold 1)))]) (fw:test:mouse-click 'left x y)))))]) (send language-choice focus) (let loop ([list-item language-choice] @@ -571,7 +571,8 @@ (lambda (name [fail (lambda () #f)]) (hash-ref prefs-table name fail)))) - (dynamic-require 'drscheme #f) + (parameterize ([current-command-line-arguments #()]) + (dynamic-require 'drscheme #f)) ;; set all preferences to their defaults (some pref values may have ;; been read by this point, but hopefully that won't affect much From 60d986b6df2f9e2488d2d8516ed2f51242b42534 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 2 Dec 2010 10:39:31 -0600 Subject: [PATCH 243/255] added a not-quite-right test case (drracket's test suites don't run well in gr2 yet) --- collects/tests/drracket/syncheck-test.rkt | 33 +++++++++++++++++++++++ 1 file changed, 33 insertions(+) diff --git a/collects/tests/drracket/syncheck-test.rkt b/collects/tests/drracket/syncheck-test.rkt index 92cb8eff4b..ff78041194 100644 --- a/collects/tests/drracket/syncheck-test.rkt +++ b/collects/tests/drracket/syncheck-test.rkt @@ -248,6 +248,39 @@ trigger runtime errors in check syntax. ("x" lexically-bound-variable) (")" default-color)) (list '((22 23) (25 26)))) + (build-test "(define-syntax-rule (m x y z) (list (λ x y) (λ x z)))\n(m x x x)" + '(("(" default-color) + ("define-syntax-rule" imported) + (" (" default-color) + ("m" lexically-bound) + (" " default-color) + ("x" lexically-bound) + (" " default-color) + ("y" lexically-bound) + (" " default-color) + ("z" lexically-bound) + (") (list (λ " default-color) + ("x" lexically-bound) + (" " default-color) + ("y" lexically-bound) + (") (λ " default-color) + ("x" lexically-bound) + (" " default-color) + ("z" lexically-bound) + (")))\n(" default-color) + ("m" lexically-bound) + (" " default-color) + ("x" lexically-bound) + (" " default-color) + ("x" lexically-bound) + (" " default-color) + ("x" lexically-bound) + (")" default-color)) + (list '(((21 22) (55 56)) + ((23 24) (39 40) (47 48)) + ((25 26) (41 42)) + ((27 28) (49 50)) + ((57 58) (59 60) (61 62))))) (build-test "(module m mzscheme)" '(("(" default-color) From 778f0c9fc4af1c36c378e3e7bbedeb47b27feeb7 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 2 Dec 2010 13:02:59 -0500 Subject: [PATCH 244/255] Actually turn on old object-info hack mentioned in 4e451a1. --- collects/racket/private/class-internal.rkt | 2 +- collects/tests/racket/contract-mzlib-test.rktl | 5 ----- collects/tests/racket/contract-test.rktl | 6 ++---- 3 files changed, 3 insertions(+), 10 deletions(-) diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index a0e648029f..86c4c3dacd 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -4157,7 +4157,7 @@ (trace-begin (trace (inspect-event o)) (let ([o* (if (has-original-object? o) (original-object o) o)]) - (let loop ([c (object-ref o)] + (let loop ([c (object-ref o*)] [skipped? #f]) (if (struct? ((class-insp-mk c))) ;; current objec can inspect this object diff --git a/collects/tests/racket/contract-mzlib-test.rktl b/collects/tests/racket/contract-mzlib-test.rktl index b18aa0dc37..28df566071 100644 --- a/collects/tests/racket/contract-mzlib-test.rktl +++ b/collects/tests/racket/contract-mzlib-test.rktl @@ -2760,10 +2760,6 @@ of the contract library does not change over time. (test #t (contract-eval 'is-a?) (contract-eval `(contract (object-contract) ,o 'pos 'neg)) i<%>) (test #t (contract-eval 'is-a?) (contract-eval `(contract (object-contract) ,o 'pos 'neg)) c%)) - ;; Currently the new object contracts using impersonators don't even attempt to ensure that - ;; these reflective operations still work, and I'm not even sure they should. For now, I'll - ;; just comment them out so that we can revive them if we decide that they should work. - #| (let ([c% (parameterize ([current-inspector (make-inspector)]) (contract-eval '(class object% (super-new))))]) (test (list c% #f) @@ -2785,7 +2781,6 @@ of the contract library does not change over time. ,obj 'pos 'neg)))) -|# ; ; diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 36aedd6fac..20d4129450 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -6045,8 +6045,8 @@ (test #t (contract-eval 'is-a?) (contract-eval `(contract (object-contract) ,o 'pos 'neg)) c%)) ;; Currently the new object contracts using impersonators don't even attempt to ensure that - ;; these reflective operations still work, and I'm not even sure they should. For now, I'll - ;; just comment them out so that we can revive them if we decide that they should work. + ;; these reflective operations still work, and I'm not even sure they should. For now, I + ;; just get the class info from the original object, which means that all contracts are evaded. ;; ;; Just as a note, if we move the class-insp-mk values forward in class/c-proj and make-wrapper-class, ;; we get a failure in object->vector for the second testcase because the field-ref/field-set! in the @@ -6054,7 +6054,6 @@ ;; know how to get the fields out of the object struct. We can always force it with unsafe-struct-ref, ;; but if we had impersonate-struct-type, with the same ability to replace the prop:object as ;; impersonate-struct has, then we might be able to handle this better. - #| (let ([c% (parameterize ([current-inspector (make-inspector)]) (contract-eval '(class object% (super-new))))]) (test (list c% #f) @@ -6076,7 +6075,6 @@ ,obj 'pos 'neg)))) -|# ; From 3479f5fb92a68b8bcdd18c557ca03c17f43cd9e6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 2 Dec 2010 11:52:42 -0700 Subject: [PATCH 245/255] cocoa: hack around NSApplication's handling of command-line arguments --- collects/ffi/unsafe/objc.rkt | 11 ++++++++++- collects/mred/private/wx/cocoa/queue.rkt | 14 +++++++++++++- 2 files changed, 23 insertions(+), 2 deletions(-) diff --git a/collects/ffi/unsafe/objc.rkt b/collects/ffi/unsafe/objc.rkt index 1166f80248..fa5c754fad 100644 --- a/collects/ffi/unsafe/objc.rkt +++ b/collects/ffi/unsafe/objc.rkt @@ -33,7 +33,9 @@ (define _BOOL (make-ctype _byte (lambda (v) (if v 1 0)) (lambda (v) (not (eq? v 0))))) -(define _IMP (_fun _id _id -> _id)) + +(define _Method (_cpointer/null 'Method)) +(define _IMP (_fun _id _SEL -> _id)) (define-cstruct _objc_super ([receiver _id][class _Class])) @@ -864,3 +866,10 @@ (define (objc-is-a? v c) (ptr-equal? (object-get-class v) c)) + +;; -------------------------------------------------- + +(define-objc class_getInstanceMethod (_fun _Class _SEL -> _Method)) +(define-objc method_setImplementation (_fun _Method _IMP -> _IMP)) + + diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index d6ca67c558..a66bf5d99a 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -29,9 +29,21 @@ queue-event yield) -(import-class NSApplication NSAutoreleasePool NSColor) +(import-class NSApplication NSAutoreleasePool NSColor NSProcessInfo NSArray) (import-protocol NSApplicationDelegate) +;; Extreme hackery to hide original arguments from +;; NSApplication, because NSApplication wants to turn +;; the arguments into `application:openFile:' calls. +;; To hide the arguments, we replace the implementation +;; of `arguments' in the NSProcessInfo object. +(define (hack-argument-replacement self method) + (tell NSArray + arrayWithObjects: #:type (_vector i _NSString) (vector (path->string (find-system-path 'exec-file))) + count: #:type _NSUInteger 1)) +(let ([m (class_getInstanceMethod NSProcessInfo (selector arguments))]) + (void (method_setImplementation m hack-argument-replacement))) + (define app (tell NSApplication sharedApplication)) (define-objc-class MyApplicationDelegate NSObject #:protocols (NSApplicationDelegate) From 341bee96e4f6ad644d324d8238a38af671d77e9f Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Tue, 30 Nov 2010 14:09:31 -0600 Subject: [PATCH 246/255] Further increases timeout for redex/examples/delim-cont/randomized-tests-test --- collects/meta/props | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/meta/props b/collects/meta/props index 5a1bd9abe7..d5ac171001 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1198,7 +1198,7 @@ path/s is either such a string or a list of them. "collects/redex/examples/church.rkt" drdr:command-line (mzc *) "collects/redex/examples/combinators.rkt" drdr:command-line (mzc *) "collects/redex/examples/compatible-closure.rkt" drdr:command-line (mzc *) -"collects/redex/examples/delim-cont/randomized-tests-test.rkt" drdr:timeout 180 drdr:random #t +"collects/redex/examples/delim-cont/randomized-tests-test.rkt" drdr:timeout 240 drdr:random #t "collects/redex/examples/delim-cont/randomized-tests.rkt" drdr:random #t "collects/redex/examples/delim-cont/test.rkt" drdr:command-line (mzc *) "collects/redex/examples/letrec.rkt" drdr:command-line (mzc *) From 2a8fdd9646c8db4902a366dc6f356ed93d20e12d Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Tue, 30 Nov 2010 14:10:44 -0600 Subject: [PATCH 247/255] Adjusts typesetting to account for gr2 rendering of filled rectangles --- collects/redex/private/core-layout.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/redex/private/core-layout.rkt b/collects/redex/private/core-layout.rkt index 4c4767d5cf..86ef5bfd7d 100644 --- a/collects/redex/private/core-layout.rkt +++ b/collects/redex/private/core-layout.rkt @@ -812,7 +812,8 @@ (refocus (cc-superimpose (colorize (filled-rectangle (pict-width p) - (pict-height p)) + (pict-height p) + #:draw-border? #f) "pink") p) p)) From 45ba14cafa5926dde46da10ed4d6796d21a5250b Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Tue, 30 Nov 2010 14:11:50 -0600 Subject: [PATCH 248/255] Updates OS X bitmaps for minor changes in gr2 rendering --- .../tests/bmps-macosx/extended-language.png | Bin 1989 -> 1793 bytes .../extended-reduction-relation.png | Bin 394 -> 394 bytes .../redex/tests/bmps-macosx/language-nox.png | Bin 3006 -> 3158 bytes collects/redex/tests/bmps-macosx/language.png | Bin 6006 -> 5017 bytes collects/redex/tests/bmps-macosx/lw.png | Bin 1232 -> 1211 bytes .../metafunction-Name-vertical.png | Bin 4744 -> 4192 bytes .../tests/bmps-macosx/metafunction-Name.png | Bin 4437 -> 3903 bytes .../tests/bmps-macosx/metafunction-T.png | Bin 4700 -> 4725 bytes .../tests/bmps-macosx/metafunction-TL.png | Bin 4667 -> 4332 bytes .../bmps-macosx/metafunction-multi-arg.png | Bin 8456 -> 7455 bytes .../tests/bmps-macosx/metafunction-subst.png | Bin 4418 -> 4227 bytes .../redex/tests/bmps-macosx/metafunction.png | Bin 1076 -> 1026 bytes .../bmps-macosx/metafunctions-multiple.png | Bin 9314 -> 9150 bytes .../redex/tests/bmps-macosx/mf-hidden.png | Bin 1622 -> 1444 bytes .../tests/bmps-macosx/rdups-delimited.png | Bin 4112 -> 4188 bytes .../tests/bmps-macosx/rdups-undelimited.png | Bin 4093 -> 4188 bytes collects/redex/tests/bmps-macosx/red2.png | Bin 5232 -> 5135 bytes ...lation-with-computed-labels-and-hiding.png | Bin 626 -> 659 bytes ...eduction-relation-with-computed-labels.png | Bin 4439 -> 4596 bytes .../tests/bmps-macosx/reduction-relation.png | Bin 1801 -> 1812 bytes .../redex/tests/bmps-macosx/rr-hidden.png | Bin 394 -> 394 bytes .../redex/tests/bmps-macosx/superscripts.png | Bin 944 -> 954 bytes .../tests/bmps-macosx/var-not-in-rebound.png | Bin 3307 -> 3241 bytes .../redex/tests/bmps-macosx/var-not-in.png | Bin 5086 -> 4606 bytes 24 files changed, 0 insertions(+), 0 deletions(-) diff --git a/collects/redex/tests/bmps-macosx/extended-language.png b/collects/redex/tests/bmps-macosx/extended-language.png index 448f4f9bfb08c89fe4ec8b812451030d4c194ff7..3df1d5862f64375af1e7d909f9ad03866e0c2185 100644 GIT binary patch literal 1793 zcmV+c2mbhpP)&QtunbZKU^6iCA<>yFEVam-S+o9{4+~~bb7Qr& zd{JXeq*b<6Thy98yr6|y(^gt(wI!^jYdwHjZ5X`BOcQI_ie&|Q7>HPc==FbberxW4 z4EsYr{Kx0jbzk?xx$f)YoHOq4AprmiGdCgs+W~mTVzDGACkJ(XjYjj}!GqtPK2vxu zm#en6c5H0ye~4~I-n@CER;zzCL$r9oCNeUzzP`S*voo;EPE1UQL?WS3NTbmLyE0B@ zW~S5Wym8|O-uz38$6zpwMq@!iL133{YHG^J$Y8Np)1952opQN6P?zBI`HhW@4u=Ez zQ@qmB(z9pJdfIaui^XCv7;zDC=`JT(JOYl{ltkAYu2o>TCK;AA5Tn7 z#4zl~j~_>l9LdVc!pDfkVx>}PHk&0937^k5o6RDTC@U)q02B(vvSrJ(S}j6IqtUEg zySBZ(y`rLG{rdF-0|TCUu-ok?Po7-0YE^GD2IwaH{Mg+gJo*;p(VolfWRcnG24;o)o7t{pmbh|Ok`NF*+o`{>c5{rmS9 z78a^hDxpw#^X5&P&4v(q^5h8sa5$XW+S(mEb~H3JoIZV;kOu~X5g#AV<#PM``!8O+ zxOnkm-{B1m48+95kVquF`RUUq{GF=P=`aktb?X+MqQb($>9c$%-)nDlbo7T09}q&w zY&OTl#I&}y%H{IIhY$b!`4d6_48xL=l05zS`T6DL|( zAP`JVP5Bev{rmS9En4)esZ=UC91e%WVKSLiDiycO%F3os@typcdY?UeMyJyO0A0Cq zB`q!O@#DuXm&@kwl0C4WyIk8v_0ORB1G#brf zvGn!z2?T@7=q1WHQ<9b`$(puU^f`$?>{P-^rh;SEW*Mxm*B<7#ka7 zu~36PPuV=AXDJdz_?Yz9a`1p9jJ-&STa)PI>u8z%SZ`-!b zPun-`?d_SFnK?N*`13?6m3DV`+ibS9w6w{|$ycvl4G$0R+qduS+qci3KQAdM;c~fd zx4WaG!_$G+~W@^ zDJc{RWoT$9Ha6DJDZZ0GQ?JQn`X|*UlWED4CFSMi&CSg^ozAoV8#it|aNvNa?GHR2 zZ_l1R{@cIs`qSRKckh`qXK;Jz(xoz)%xbmXyLT@xE>0$sx!vx#xVQ@!E{u+j3Iu}2 z#zp{m@!~~#dOAL(sHjLR77q>%*3{ILm6d5Unq$X~>GgWN*E0_?nXIz1((Arvda74d zRkgLX5u85mJm1NmsdxMK?N6UR1pwrA(J;Tq$jFFLC=BW)1_uXs@7|5u;o=3Do}Qin zzWWJa7$%iUolYm-BtiIKI?#Ok_HF+B`O(qQ0bjYdx0lQ1Mnpv5&2aJNFd=%j8RDu! zh!CR13pPPg75*@PY4L)jD*R!>s=^$G+|$#udi83RN`(;8>-C#9Z6b^as|tRq3V$AQ zMn*K&R93csvZlZr{G`=d{0ERR|Fx5JF5Q^ZWPj&CSgc ziNy2P466#WewzI;0AOfnC^t9P;c$2@Z&+0bS^ha5o0yo0jEwYJU8mDYp-^yjf4cqe zVz=8F3@{=wGh=qQ~|_c4V|r{lqokB>VX4#H<%0ARIR7c5v1d2$tOB{Qh_wV<1GoAZhve>)G?1^SsY<&ilRxzJP)d z0$-xDvy(!h;PLpGE@T>9*Jd;t(P*@1uc+7S0|NsQ+t0J9f1jeFqBn2ecqzF`r4oz9 zO-)VzZ@RPEj7DQgNr}m1`n~F=VQ_FzBoZOE&ux`g2?z)%D=TYnZ}(tMlgX5uo6BOc zuvn}I(;~#j#~TcW+qZ9ne{HMqc)Uy|OG!!bV9u(ls<^l~0)b%lw70i&xm-`>XD}EQ z6%`W`6F=Fi%F4=wgak+XFGZzNNu|=Hq$E!zgb)@N7jNCV)z&#MFi=}t>#0kiP^dL) z)(8ZGA6q4rO1WGvm&+|KF18&P8ymZ0#|}IDC>m9qN0>a<@fL3Pn;^P@@i{q<#IWj&1Ntda=AP=H#Z?60Yb>*@s=)K+Sb+v z01%7Ct5>gXX=%yN&tJQC?aLRC`R?7jE^7Py`Lj$WBa_L$ z)RD8*b{1W>Y?)Xr_6GonM50TVE;TeX+`4t^!-o&H(`YmrjYhMx*=+Xi-Mj5BFmK+x zUnOsMb#-+t7OS$dQlrrT03JPh1R*4o$t5KvnVFg8<>lwkpSNotkH<$uL{O>J zfq{XmSFe&tBp0;}4Go2chN4g?0KohA?~zkbB9SPS$~$-NAj^`Pnrb`6#cDf?1_uYf zeft*3Lg+f7`6bhxVu+U<$T)TE{`SRs5nM|ovVlWu3Rtq7FjEv;*c*sZwgTd$X zr){6bVlkOai^cNO+Uo1;=g*&y*tNB_WHOmdCWnNCU@#cO&dSQN9q)RzokgEKd4j{? z!1e3bqobpno12YBqnoSAhJGoGMV}L`4Gb4;bA{NKdDp-A>6WM%eiysAcWP`)$7)+gAn%j_Y(*Nq<@)A z78Vxv>C-32_NS(%LPA0wJb2(vZLeRy_Ve>Io6WY)8#itwCMHhXo$J+h7OktRqf)8< z-@bh#5C~~$X#jx1!NCO!7GN+K>+>j=%lrEJkdI7OJ2^QyA|k@>$&HDLvGWK70wR&P zZQC}rT7CKQ<-L3NQYaK>wu_fcOG`_9e0*YJBJzGHEG+Eq?$&5D(b3UUQ&XLtoeG5_ zCnu+`ukY#8rx_U;R4UbMHn+C6mX?+R0K{T(Mn*<=cXw-RYkGQmU|^uxY-Y3BWo2cN zk&%w=zk2m5C@2W={FFtD7NODTv9YnRurPPVyIyT)(b3V-n3xzaIy$;|@#5_4Y@tvn zkx1U7cN{t>?KQgz(w3XR)!d$dt6Sw7k5$k&zKTpP!YLB^HZM zojTRg(SbxA+vjjN1qB7ub~NqFxu~e9v9ZzCI5yN7!C=?3BM$RD@Q>>@X&rPtM@B~W z?b`<-1pm9lS*-N*^myv1wnM2@78Vv73x86azt6jVzG|OI*~{$FE0lGh(w|zM~)N} z6yWjr(a}*mWj#GT-AjG_G7!R=nwrg9+S=OM+Pv{q&V77YS)W<_0RSWtX=G$X zrBcacvYk73{&aWweE$9W_wAeq4jkCCXOA~-CY?_A{Q2|Z;^KgS0Fg+vY11YEfWcsp zNF>$O)l#W+U|;~b_usvHH#|Ii=+Ge)3f0`)oSB&!6%|!eQULirB<0DzE?kgs3A3WY*8 zn{5}KRn~n72;tb+SW;5b#KeT-LpQ6e`wl;ZC6md7JpPUt3zT diff --git a/collects/redex/tests/bmps-macosx/extended-reduction-relation.png b/collects/redex/tests/bmps-macosx/extended-reduction-relation.png index 46e14cf70397c41c828ae06d48432c0ef290fe3d..6cb65603c888fd9675aa47cc7177297fbbb29e5d 100644 GIT binary patch delta 368 zcmV-$0gwKQ1BwHXBYyw}VoOIv0RI600RN!9r;`8x0Y6DZK~zYI?bSW5fy@U#h&aHG<78QO zU-x}a051Swzu$AtWm&H4I*w!C_bEyp1i^B-93Le~I-k!3C;t7N$l?YhI4#quFl{OT O0000HEGAB93Dk>nN_ON(d1}5t$VLH~_3xD^*pWdoE*aD&n_D&wuqzAR=Sz4dPi|C?10T zDek4s^Ehuy_I@e(Qt{)LvfMW@rn>L@-=4dK2iKJVpss7zbphabJmz`+6yK>lP2I#uR07v+qS92MN!;tH_NhU#4u#M>pI7A+P0-BFd~lP-EMce zT!!)eekTx10N{C^5JFLu>-8E%k?;EysSbibmgQ;6IWNnSAmabuiHr{nLNnj=4iF9i O00004f168Vq&7QvXY9xXb82LsH&=Z;e{7C9L~(# zQ&Lh+ojNr-Iy$>i(UYk&k(QQr=+GfzdrAPHsHkY`)~z!Rj=^BO`s%A+eDTGMx8Ops z@IPH$UG??#2%+)u@q&T^Yl}^rHZ5Pi+@>v&NGd8SY_^q`mnRmBEsGBxJm~H14G9Uc zws9~J>DtK1$jZvf4?q0yDfiO_0D#8E#^mH=lgV`Q4JlUXL7Q;8mz~UA9FaIq@*N-PB}=@#yfhk3P*4y;$nik-)(#F1u3EKfmUo(#cvMzaN~Kbj zN;Nt<>g(%kbAv?)z5Vvv{r&wLHf*qIPYILBG#ZUwUS9Z3J}fNE!9e!b9y)Yr_wLz)!c3UW=8G3Ea=Bc!T7Bu# zr59g(vA4IEy5U?M3NyiCvC`7gHg4QlTwLt!?X6O&h%fMNEKq)RTDNZ9{rmS{fBki; z2Xb{N&xBU1{r&gfsUGED0JWL8e*O9zZ@l5-!_nPx(-*N=~nKg$ta2+C`**1Fi;yLSf$ z241^%&GFV8NNJ}fmUS^@?W}xn(rUG#p`pZnlgT6y2!@A;@kI>74jw!h9UbjpQ#LL{ z>gwt$Dk_`|Y+A;13$>Y$$z-LarPe(rlgY=&r>(8c-lm8yHeeXGcJ11ckr8JCo0jq1 zLg9S^$aJwcZrm6f8!Im_cizQ@X^CZBNLfo^CP;O$GMOwfF|oS3+GsRR>0+;%8yOiX zm&-{9?ds|(DJdx_DJd!{!h0MT(+UbR(bLlt5D>s%Ff2Vrqp`NO_P~Jy5fKq*&YYRj z#a=ac!GZ;M@7^W4H#Ifw-Mcq8HdOkI(S%u#K5UquIWFyHF@Rdh}>dPfu}iu>)foLSZH>x>!q(OeWjDeLI7} z$jr=CtJO-Sa!MCOR?Q_9%UUaI4<9}}Z{9oy#x#V&OjvZW_+n>gXIonvE@57@Xwmxh z>q|;XFbs3xg6vdtNyV}jWv!>DXLon^#KeRHV;Vy3H#?C?bnDhFd{HKo#l*y{Sg`_M z{PfdLTUuHq5{W$*2i07KLLn3iZHCLr${H9L$jQk$bLNa*ueZpbNsZ|UrO(JS(8W&a zGA*&J3n^>qsEc*rGA*&JYbk4=#rKJUfdL;Mp9KpRJiSXtM+c9`W3gDyY-C!-bB_B< z5nXT%U93*0lgs6oE?uH-h&jhKz7%p&>P zH8P>o>AJeQ;^X7zIuHt>w(hil|Nhw6*hh~Zee%gC&p-dXR;&H{@4xf&^J8LSa2uge zc>etPp`js>NR*P2GBh-_YuB!rm>2+%N~J4Tu54*(K?up^@>gDYMWIma*|TTOnl(K= zJ-EAd<<)339yoB|rI%jn=;%mDNH}-y9Cf=!1r%n2&1U=g`K?~Px~{ISu&~fzFzEGq zUtiz(^XK#Ve1y>O@UToKT-g`qsL$$TF_zXCDy&fUd*w_dF zAt52hjvWgO4E*Y=uMnZ~%4V|{FJ8>!@owL~ee~#2Cx0MIAE>=LH8eCJgtD@-+S}Xx z{r#6NU5XI8a^(vCyX)fO;*gM#@bGZl(rh+oXJH>f*TeciLcn|=-{r20nYu5rm zXJ;pe!@=i|=pOY!WJE;7<;#~%CKEo~E$;n%{ZVe9)CnY7R)$02C`sCzf9*<`>o12@P z1p)y=NG_KrCnu{^s>_!zZ`iP5-n@Bcvsok(m6w+X2L}@?uWfB@zP`Tr+2)E+n28^M z{4qT}9dG~j*Iz&X{Bvk%s9vvs@ZiDm<5n+R1hSATKWuzXW3#CJ+dm$)q#$#R92I$MLm;Op!A(@#Ie#>SpFae}zl zL>D}^?Ck8OrY1{|y*X|jPl$^Epr)oKEiDZIT3T9KT3Sf|^)qAr`t<^Vz+^K0^2;w_ zVPSY@Vq#)VO$`9-+qZAovSoPZvSrJ}VljqcCr+He4=$}%>+S7rG#UXQI5=1;mEx8u zDJf-TWu)`VW@culrlw*TW)lW!CTym&1%UGM^02Tl48uxGOQWKqh`U2{0f4Hisx@oY zSoe_5aXaONxCj7l-n_}@^R-&-*|TR!|Di;rQt3JZHX~Kxt{|!i5X1dunTIc|4wtFEL;nV-`Zl-{1e?!-uC& zpB9Nk#7i6Le6a}$33#2(8XNhkO)XX|7OPY$yeML!xPJZm>eZ`pm!za5p-|Z0-(OZ%mXVPm zm&*$Z3Y1DEzIJeMaOu*e0)gQ4>C^bZTUc0_o104-iM^-Tef##+)z#tc_uqdXe^S6v zDwSL=H!m;Go{L;A=kxh;xf}q*VsUC}YIk=xZj+v#e&xy)8%JWmHpc&binTdqtQj94 zw_JIx+tb2eFyIXg!z`~w_&vaZi)E~_u`%My6oz5ex8<2d^)#|wy;M1&07*qoM6N<$g67XT#Q*>R literal 3006 zcmV;v3qkaWP)000YxNklzWOfb=yYNBqee}BJ_fLJWX+cY#ZELgBWb*Os^jjc5` zHH#K4nsPBF3J{4z4h|0Y@88eP&OUMC#Ms!FLB_pz@1DxvSdkOVq$rD`HL4X)V4!GLBYa> z3yEcYNKQ_!uC9g<>YhSd>y8~e9zT9Oojq&{00<$9qEe|;n}tH5&{&?5;o;%<_;{?W zdkSLf*RNmq?%k{ZTqXw~b@cZ3_Oi0FU+pE4NVr_?`1m*(OQHxgNOD}PzrWwg%F5Q( zR{t(<-@awBSadp_yj2+;!}z_mwbj$plfhv8`=S023=^M8PEP*t;e$bj`a>W$4m^W4 zX8dj(X8dj($nv{Vsl0#xK9k853WX0IJXp1ARc~)ENpqPZWci&=r^m*|Zr;2(D=W*= z(z30s4IdMpf!ym%XlQ6pPtT@Jn@F9-6d~8|5{YEy{!$|(`u*9nXW`-DR#sL*q453t z_vB4vijd-Wfk5Ez?>{jyv0}xFZQHh`rly*i&D=Qs1G3^X!^6XK=gtKHpeU+TDt}40 z^d~@iTxLu*wzkUUa&4^$g2-etg+ig{Xb6I+)#%?>e@o*+Zah+@k34kf zkfWpH)2B~$kE2abslQ^JUK?D=Vv(mKJS;sM)K5qG(7+$jHdZl#9{d z(uk1ty9x>V$mh?WkByBL78dGhuZI4LNt4i4lI3@zK9a}dg@uJxR#s~K1;*QJi)DIy zd-M5xV&Bfr&g|^$?Ck6d7cO8m+AOI9S$^;C?sjl+pwVd9p*9 z#_a5D6h*b!11+&kqGD2|tu!|`@9OFrA0O9dNi|4(-o)W>T3cHI06ZQqARu7bvSnD) z`Sa%+8yioZI;GKGM=Vny5U|;7e6L-*cJ=r7@7uSpqM|}3ld0scL`%v+-YqI#ANfo6 zGMNmknVg(dsr9reCQVdZNiBV(HhcXQlcu7rq?|rdqrLu$NmJ2Q&gdhJg9+#(rBW%M z&wudX0ZHQ<1rvDgVQy|-SXlV{`Ez40#E_VP-x&->Z*MR5j@5623HV(qm3DS^1_cEf zdm)B|#Q01`M#h>oYlen~&YU^p>gpgn z`}S>caPW;AH%K}!LqV3`84QNCwY86rPjz*5dV2cs@UToKn=@yQjg5_;pC15VaBz^v z-#Pc2z-5g*REX)0I098 z-@JKqTU%RGQCb5dgsF^P{4o z+S=M4J$e)w8996QY^74k;cyBI3te1Xh+)Whw-Q8s}*|%@s3JMAm5)%6Q`g(eL+}+)4Yir};;s5|mO-*iYZrB_6pFe-@>+5rH zaG=xa2!aR%f{cuew6wG>TebjAVaVFr+U?u7n~)0gztHK)<#H^903no0rC0{0k&zJ_ z8yg*6Y;0_>$9@WhVsvy=EpHQqaA;`A1g_&+n9)ZX2b0;DzZt*3->IqHGy%W=%XlO; zwVNj3cQWFU_}rG|<>krA$;XZz)6-t9N&jq@|FAUf-v>Qevu2GzAedfXYHByh${%S! z3?7e!6wq#(wYRtX`}3IVqzkKAg^D)_VDn)D#OCUZr!>CAxutA_Vo0`Dm^_txm+%aqJRDM7xoR3 zNF zqB%J^zP`T16H&8=5SEpdZP>5@Uqj4xsXH$wfDpcT@xsr~Pa=_AzkYpccS4w#mlsMv zP4_~bcqGy9@87>SGc!{vmDpimVBqP~ry+#jzki=KYZfu%pPD^{FefKx{`~oPo2sfR z7K??iAubYcNe2Mf+1Y*n{=K}soWtR$?UZTfk5r3Ca=F~LwlTOtk4NHjTVmSH($Z3Z({5H)R^mf!czf`-b~86O zS11(H>Gb8xmjj*JO`tI^CWKHd76%0djgF2Izbwulf1;adB~c zK0hrjt+}}wYbBtfs@#@Gj~>N-$uXLno0&{zN=k}Gdp@7<=jX@g z^C5&>E;lA7rmL$9GazQW)SVae|M%}|djZe1^GB)}9v;RDD2l3H8^f;MI=ZN?)MH~~ z#Fx!;IK AvH$=8 diff --git a/collects/redex/tests/bmps-macosx/language.png b/collects/redex/tests/bmps-macosx/language.png index 1275c7b26c55d8302e3a19fd7a03b2ae2a86e8a8..fce82a76082259d8dd5050db97c42bd453428a47 100644 GIT binary patch literal 5017 zcmYjVc{o(x|G!x>*2cbsLH0G0gk%|8_CZJ?StcZF_N>FlQj9gm^0Ds}VQgc`E=xp6 z)}*l)S&QH4^T+r3-FfED%=65-_ni0pbzaMjF*4AirQ)E1Ac$5+8;Js+>)>q$BLU}r z=ba|-anVj!3kjY7ef`^3k__ciqL&v3J!oIVovg!Z|^fAoGBgsBLm2GKhDK<8ikpb!G_-!OxQBgsmn;reO4uiqa(b2WFwJ|a<#F+AQZU_E3@u8)q zB_}86cp)exBvfqf?d`3pd2#*Ul9Cb}4!659*W{I<_pQIbKSji(mlIsWRnE%L(C{}g zF$mI5B#@GluCK3eOjSkjl;-7ic66wys$O_(bnjkyb+wzleWdH@@!un6d#1l%+uAy3 zz#h~r;pQ0HNl{UeRosH-%v)O-DvrcpVjerA(QM4jX4cm83k!xtDC32ekj)YI=Hf`&JA$m<#C9uOC08Wo4PX6!;Mk!~Ii&NkCwr@AjPk>R{@R zrpEeuatexML&-B2xIi#33>2-rv{c2KF^&>9tn9bD_+zDSb#-+CU?LKuLIl_oLHeWh z)MV)9eNSpg5;Dj#GBOgDlIl|)zrx$8_Rl`XvfkOu%WE(5x{IJ9oS`gCg*asQ zCPz6~Va7O7n-QS4#doLrLCakoowDZUW&+`P?K@s9o#5?YYAUKUam$|o4dm1;u5);g z1wwFbZ8Cy6##F_bTf30WGxrMCu76(uYX{3DaMC&X`T5lr@bD^-p|W^gvW}0A(9X^* zEG)6x`bbOJ7^+;X*?1vS{wAT6!>O#SEG#T6@L-dEfgFRxjP{E@Mo}4$vzo2wX=(}z z3zs%D9DFFyvTL@*mhQ4!3g~n2B2Sj5nJYiVbfUtjNY z?;eNS5@*T~I`g`TiHSn?OGWgPCr^-nkM2D6=*261@jCxdf)Q3Lm5q%zZr!@2q!e`a z`#4?7hI_(6c6b(z8U4ApcepvTvbI)|pFch`Ly6$8DAeJK)VA3?%S=lvE-P!Y>!C6? zH=o;}n3G_yurxuT03g*eq%+NE7iD!sV=1sT{pL~ENr-)_Y*_@HC|2olF{HAr%>QVY_kImh zSJ&m&`XoI)JxQ2KB(-d;BW>eu#_KzoSy}hh)k)Kbm>=q?+5d+FjAp^D=fBy`UcGvS z_a=@vd98IJLXKC{^Yil;7Z*R=N1~^wsHj@o+Kk^lnSEQ<*7jv$V(;hb5GS3M#rdUA zuOi1FyRnIhmE~obH_h^x zm%lsAB4FX*;F*AcfSK83qi8}`tvFVi(u3#jNm8OVSs0TObzK`d+yg7C z7Q3F<0lLVq!7BgkgH1_GO>NcSYU%6itF7H%X<26>J_VLY2tG}dd_eWtFEH@@crBOa zVuWVF%*>258;z7yO_6Ro2?R<3Fl}yXN~Q|WHaOp`8wC{!3JwOh#ARmM`W6!YB11{( zce0@}SjfF5&sDrlsj3VS&KGQEYMPRo$|`x^Z>9Ie*w|Q34mVx2dJ(EbALr=iMyF~7 zU;%*G)YMd5TpS-C9}}ZvU@!u<7aNUcK!C#U2x_`$QdJ{sYi>xz#^$!1++7osy)Fzj zT+^l)%&Vfp#m)|8ZqCZcc;(whf;Q|gw!{C;%Ho8D%RQMjwX`fNE_QTvrBNNLvT9sB zZ2XHc8=Lc$gxgUP$3cXameZ}zjgym;65`^*On3D4hX+%|cwvJ>LtftA0FoG_9tINvXG&Uao`b7>Y1s>?#z1z^xzyj^ArrU5U`N5&xK17IxrR4?4+1dHy zU5qvKGz zR5Xw9?b{)M&;V5eP=P@Rc6R^YM;_+ppPGF($}1{>2!f3b)aNMZ46GS!V;)%k1QARI z3<33*lam8-6r`N1S7phM)-bJW##=^ zdmVr#GS#A@qG{IGPo`gYc6E_V0-c@egflZ^y!r9V@#3AD7W~=^8gVRD4_X>3D`~=c zsHx*D>m2iFT3cK1)>yxAo$@_`4gM~j;?b$|Z+At&j~xaPF@B)-Q^L|AzL z;D7|$-`@wQw$)WsZ2A5jeK8_0FAtlM!A?*A#&^fsVhpg1-P5O1aG24gVoddH5TlRXcbQU=tJqD3vS+ZD7OOx26vseCh9p z%~&^i3W!&#hKmYBp|XxoPt()Wz2rFymtFf_a)GS}43Bot3~{1_H*$INVCypLd_1#dI4wm?Qucs-wZ)tK_IAYKCaX=*o4`Xi*Fe37rwh-&_S55UIgMliM%v!q zcKK9I{Qf;MD(dHP5EoZAFj549a$w*oKrIQhJ>S;izN9wo@TJ*jetsTMeC*4Y&z?Oi zo*DHU(g%)YMdz)C?sR)ofefA==4<9331S zjKyLB)B+Db#OMO=X<;#4@A66Twc!V`y_}3)TR)|oh=_=fI|QpnH;uLf5=wEE)1_!c zB83y6(yLcPCtX`_DRJ-2)Hw+X3MS2tX5CDFw-j{v#g~yS{(GwbB_8ufT@l2M4cv8? zDdfDrySqDlo}kenM9&geR9Pt=v@HrWe*=JsQE>`1^^;AAMC*b$_74y^09cI$M2aN; z16rM%&o-wUo_w~~VpM-9A}M*cKVf)@Qyywem#~VGVQXA=m6fp4)YR0|(+db_e(^%z z(^KY-NLpql2Qza~P0gs?8~3d|V=}avnHi9SI;YX7w%4O z;lL0~EG+D-uBPH}fjjfJ=5o#dX=o2QSFY4qsCP*Z3sVgYRFsqZxc~0mJCG0nPk?;F z$r)+$VB*7vhiJ6Cl2ZJA_KOiqJ3G0FiM9?7 zpPM$C@O}0yszt$lG1Q2LiJO}aQmK9qEE*>#Cj{;4f0r)NEBJ7*Ipakf2L@5$)~z;> zL%?p##Np2W94_Fu@w$;&TrzBPMIBog6vukvSeNF$Z*Qkzu@7Z3&Wok)(qO1_M?Z~^ z1AV;A$*Fhe4#$LbkkP#ca5134M+uLCI|J$J;k6W$D+o}pot>uO@iH`74=)3SrlqksI5=3e2#us@ zpikTjy3DBgoP=l`-xhTogmRS<2-YShbuBHIA@{WruA|Yec48c}`im$W&I;r)V4XWU zLgf#Zg-0OGp>G=-8^9f8wSozB2=|bYgr%k3wX~c;AK*!3E&6+HuR=Ku6`+SV|2xFQ zsN?xC)YQ~<_4Sx77Z;Z@({->C;F`+IMO#-36xb&~R743g`3>Fl{Mrv9tjD8wRI6YU ze3_eDUS5uhiUQWJ>Astq8i})m?MTk8it6f-CHLN}TC_f5ipw`9u}=MBL<A`YOTzfAxM2^+VRsJ$IwtKqM9!=`*<)s*M7Nnxmu}_=;{dpIC z$;ZdXxPBlYAb^RP8DxaXk00It7Q)BZ*F-o4gmIvB@dp9=y!f6^b6>uIiFtZ?jpp2H zdH(0*$>)YncHp*wpKeH&-XeN8@0Q&G)UKg{$;ru)FPbUV$FXp6(Vi#y&(u0BJU^{U zN@8$!*#6S8wzj5KGGShI&%w=2`CE#HIrd%iiX^?~vwmCmbdpAjO%+K=Ne>SXfOOy% z&5exkA?F03Vv%A|qT=F!Zo6ApAQ2G};2-cM^C*v~@!GcMe>h%hb#L((dNY3F7E@t_ zk*OJ9PDI8>?UO*SEyTa}fnoxkrr)-ky%K@A*08kna86F8QqR!vQt|*&vP*v7S6e?9 z=DWm@=NOHe&QAmLmW@%YR|nJx1PVMV*;O`FlOZlD z$=)?GQdyNG17vg^SU!-8-alYiRuLW1E_`)PdPwxSdJy$h6g+E#bTkZ*)oQlk{|8RW Bgb@G$ literal 6006 zcmXw71yEGo0^T1{RzO`z>5!Jt1?iG*5G169C8WEXRT`vSQb4*S{b^Z1K%|joDe01u zX5Znxd3T0gW@qlX=brQBiO^7!zlTqW4}n1LDJsZlg6~c6_X>&wK5y}hQbQo*Vu~^^ zUU_BgWP0mq>7IA1!w_N4lCMdN;C%ENMKe!#2|_sC&F>7ihm;FLyYdNdXUmW2WR8b% z(3cD5R^8Ms??D%J z%Maw*l9w})7gW}d$4eE$ybuVwMuQ#`xEffh-{>b{)_7IAj%56kRMU}2uy1Hsf z6mgVNfXq8Dk~xo!iJ=kodiwOKhKWg_(mf+1qcgt%ef?>Jv`4X#c|;rO@$rjGOJ+7U z=alyTets1uZQ`P$qB}L{m;MD@{-dL#shqDvxYY5He}1BP4Zb?~w>aO$MQ2|h751g_ zv>Cfn*U7n-+_UD>fAfX`64bp+BN1R&JvTMwy*7{uUzwboq!MuGIfBv9&`?mYdryH2 zgK;o7=iPuU|Kc`o7UbgEIUJP8-fUec646pN0W;tEI*(~^UHcwG#bez3p~A)W=1OFj zmyy}Vv=|g5dLOPTw%OU+XNq`o2TOi*3*Wa{`-vJI8G+~1w4*3sByCRPGc!$I`%7bE zV<{kcbBg0d%5%_qAhD~-MU3e zfnzW;Jp7QFy6jX>kT-%oqp?MMb89PG+@IqrUGL#XmDN;}fU|yqc@;(WU|w^LyXeT~6j)&{dD#>WdZi$|6esWa|s1e`ODmm7ee>YbP6EYxx3Gr{b3_V&7Y ziWXH!lNILi9?;rN*DC7je$C0rDK1u=8f||`m6Xv+g1^%7K!Tcz%GJeXy3yTMMJ4+E zdnLbIr!kxrTiQvx`l_mD5J^rlf_GAeexZ4SV2ack6L+u$-(Q+z+|R|m4-g?%9Jg`) ziRxO~_rm|n0)ryz*)Tf$3e?H6+9Xy)aW&Fm_faTRa%!sj?4Vbcb!1c4;8lo ze#bclg`yxOb>E(Rc6-^Pgv3*<<7(Iv!V%v(LTiPK!yqi2CYLAXbEFXO#reM*H)9V* z$<0IuXvO_{R$R0+HA$jVUpPD0?vCXSX2wrd8(dExNQjg1#n&VhV&a%US)T*LbZ2Kae-5C8mu;^QY=T>Rs!@V(?0K*PoP z`Db$b9;^t2Da<36MF7<8quvU8cRMMYH=08=1X5=uyDXKh_nQIRD` z+oM(b#%S>K)o|Za@a*#cPbny{l#%I7WL1Yi0MC?DIGvrGB(+WakF{lGW$o4>q*^uBfb8@OQ{;Du)YHVzj0tCl2_nK8P4FpaqP`gV-+|efbEH+R;GH6ycL>8~m zxpw%{Tl8k7?N@V%HV7EXN=y5Cdb|!#0VaET6cjnsgO=h2Iim3IvJ`GQvj`afcU$c5 z1o>tx7CkG;6-+1lsKSC$;bvp=QodR)qWsZz@HEEy?c4m%pGEynHKvH$z2$!v9X*G` zZ5$otv6aDxZQr7mOjr^X^M--gCW$@F@I)SrdRkkr|L#pxPUWVdrWSQx>I}I}aDH(i zFE4LyX2yi&q#`5x3qbw!QFM4Xl#Y%L2-}~9c4p-iNhmQ95hf6O6&VR^3#D?sOovs- z(Li@}=vEj`O;1OrDHHSq;;Cf{udJ@>n3%Nr9B-DDapvy`4N&D>-b`#{V#3qIqt*As z!O)O8z2CA*&&S6H+_Jm73khm%Z5~3k%gc)sEXhO^6&ZP-PW-3o(}RP9AzpGo zBZ!8kCJsYwRaJxAMgj^oRcAW^k+Zf$AP^Q7vP?u9Za$itBdh)C$<0_n#~=W8h{mf| zxRA*@TU{fg%!r8IT-hiHBtJiYoo99+Tf))Y{1D^2mjmA75jC};j*g{`O{3iuTvfFn zVCGk;?k$LtlG5eX6*-SFA!On3jEs!T<((x7{=1GvTwL6L8yl~$Pug^sVwaoQ_fGkH z8{M~P#eA4rEUc}q|87qK35KC7+pdK`Jb(%!q6ER8P9FUC81PQRH~|~4TjvvFD)%|X!H`84p?VrH#bghZZasY zwP3sg!puxlPw$lbgmR55=Q5Ayos_e?yHSlqlB zzq5S){5jaF^?zgYb^)#S=G)r*FFalaoE@wzcgNY=+rQ@2v9hvqadFYm7%J7R1m*_3 z6Ko(34hS@0A^7?E*Y_+a=W_777mRRmcJ`0AR84MfuKi5? zqM8lwEz%KD2n5V^=n4U4NbHpvByts`mX_|gn+9Am*DB0Q6!YiLm!HHvFm!wSi%Wss zXqmbZay%=gh4~yo8^Wws?1SC50uMk4f9WoY|Nl!B$vYdUnv8n6alubw^)EJ!gV%l| zJu8d*<)lLDJo9LUU?}*}hWFi3d1>jzpN!k%`XE&rMAtKu#DL zr3xb3P5JovKGg&$dLM88QqX%G6J7W*dWjPbPf*IQ*5iEJHFbS;@jo-mC$;MB?Uht= z*3r@74_+dK49(7hnO{@}UMV|wp*q$3(P*5r%KXB@TkP1n?QOfa$8m0=r*YWnt|)Ra z1mE-L^MP3Zr#aX(L_$vo{)tI?20KkD*hDc=(f46tRoYO z;)B5Os3dXCZIxa4*<)tO0R8D^W3K&y}I<~TM4*-M#`G8i`$-_fVRa8u@1C16I z7A7JlzJ-I+gE-h+5sO;fnME ze?)w&HZ;n;_>NxQ|D8e_)^C{?qQ|+rwIywF)Z`Jul3-G0$gMk~gfl*ESE7Xm+#u85 z7u2$F!ah&FO|HU$3y7Guuo0E_y{KjNO-Nj}23uK0MXSe7ng&}E1~WDFT2m8^fX`oV zlbAU_-eMn6+Vv!`~)Tn^vN+W z1b=vLZf9*xUapU=u)YmnZ$0sL! zAWlI*4yUE11x7w9LJ=$}SvX1>=V)Ui6`4~ z&ov3~@wriotT_o1ka21_cA)^p;^GEz|LN-L(z{}ckU_5=QGta5NmP(JHe?^{>BZk2 z>94G8BtJ^DOAD@K`e$Z*L*xzT`QZdh>+9j$<^@p+2?;S&0yfdC(ddIeiyZ*|AVE_m zgWknqbTJ)SvyZepJ3CWURP^@tP8V=gQ&;ci=;C`U_5Qylxvm?Y27aN-;5h%{XGdMA!dp=nIO;A(tmHWx= zTxVxzSy|a*`PeU0+lz~fp?D8~Ctwfycpg7~4BrAe?g7MQc6K(3oQH*l1qV{}YI7h{ zgaIieB(xwwR|qoxN?x3J0-1rOr6mS9;&Plsz|s0kTia5wHW9?E)z#Ht1Jlye0ce+& zmNb4>nRgHU784UwR#p}f76!1bx1V`$({{QP_4DV?7T*(0t3Q=}d&vxwXuzcxkVNqA zz`?gBDnSrcF)=aG)BBj1n27L4koZk%Cm6%XqLM#+Fa_lgv#I)JVA30ycEH8XSCH~3 zC@4TrygYHA9~v53STH4u;M=#Tzc|@bW_n&#Rh4L*vbDKs^KEEm<_R$w4NZ&>aa0!r z0|N}5l$3OJagxUcAjV_TiiBMsW@BeT_}H2GTKtM5v6q^H0)Xs=HgIf!qV*qvPEJmK zexk@PU%m`YPoINC0z-pEm5m~M0iBtd2|Q_71^t80brlxt{J+XKN zCf+K?)-x7R$hf#v*+?iUDC%l!C80o|VI(BT8!`s$Oh1P%-h>kzoG(wF^7Gew>`XT| zi@q8kAE$lvCDk~{9H#g(rv?o8& z{oo%@xVpLu>Io>hR)bk$P79KNN3O0l!NLFN)7iN;lrpu@gD(C=r%ckKp_KJ2-nQgK zrHTB;GeJQGdKk$0*vwYFH%W#-=NcM>GS%p4XjGMz)A@{FAdq%$!gI5;)N^*Fm6e_# zf4_k%RfUA$kdu=`a}=2LTm6KT9zq%76+n&-h0zMRAbyo-vt5HeU#e3c0s|G;eWu=? z&80h*29UoWROaw-NsJadJNwN{egE3Y%i|@nz5{~E`}FDh_O^@|y)z5)DLwrH2q-W# zXv<^Lnwmt&KSvv*TjS-@?H~a`Aa_FBS6uE95^B(Xt*u>OU!QIAd>|D*;7E`B>Nw9r z6k%au@$A{Njg1YM6m6W9scFzI>T%I4j(7zb$Ib+1We^V-kn{d0G)N~qyPuPj{}vbD zl?8_(*MouAyd37g?BT?qm7brU_sH1pOxFco%*=yMtfUkPWNUWSMOV@11wGRDWLGxU zc)6Um9xNw79N<}KXebPw9e7PK_YLcLZv3y)8%(ozb0=@G$9Agy&%woCP0q_n_5s%us-RuhY@pQ z!DVoBb88O7isKvCSl;v5!ycrzeLC?1uP8}x*yN#lF767<5)j14M>wn_-nP}_;I|@3 znItNC!{C$wFi;>zL(pn~`bcbOYAV8qjg2h`CM+bBUr>;H3aS>PNPTWDWAE_##a>&g z0{iUT96Jd<(rL6n6)rzuwQ%p<@pyAIIm#fQ5;0o0>H5V5b!y%t4 zDP;@{(sOba<0P)344rAMy(*``Au1{=%&NS+y!619`4rZok{1>@zI7BP$%HsL2vrgp5MNG8>~}8!=Iz+ zNZz1_)pd1sId}m*2p5o5fVu(ve^e=m)+{S3T0cMDauaSTFYgB-Tv|G`-Sl&Qe);Q~ zg1S0wUEPzf^8wQPAkn}6*J-hvE|8Gnvj$tCdUi#5d8U9PZLs8IwMA5M@dl`dz|Ya| z2*4Q&^VQngnt8qxI0H!ue>Cj)+Q482j7>m55G?s^?GX42_I#pENjScP-np0aX~B0%eijg19IbU@Gn3!rf`nXG zzf9TT;o*V22hNQ^EdetjCMF)kf^@s?cK+>KP)f>pwMC!!+3&=Xl9F!`>bt_`csBO-Mhz~^ zO1eZ5Zb$3G1qCek8Uj_kH%9V7@U`2;ffyPZf_zeCwF^9N-Tni2;GcFpk*D-?pZGvc z^YHM<_B*&s=?`eFTWKuj@;e-8c~+LOs%lJfGU<4Fbibv9*Pn0W;~pTG1JHwo;o{^p z1OgJ;{s`18T3T>SQ(RW2qNcWbc(zU$H@N27Fbm#*G2YtV9+c$my}iJdAISioh;JM* zhKF?v3k$&NfqCtA$F+5JC%|Al zcJv`Z;I`D%)b#Xpgat@^oo3Fyz88xfVZbtnH^?7h=Vc#)>>NiYAy*j3%*?Fd+izJT zFDFMU5dhA}g6z3HlRuLq`z^QD*TK_t^Y+}s>63II9q>R9*5 zlPC1LkF<@AxzBziGCY2KE0fvOo45-V{lVVU6ryU0(}1dVNE}?tGm!-){h;{Ki@?uUhnsUop0HPrX5MxG}%o517Ozl0Tt z2@9VubrEb#PkdNV91ILuP0&tw4WoFsgKNv(GB6p;G%8tmPon}6Hn;{vA23|m@wZC@ zz-?Y$9)Rw;U|eXP+wa->q4DvQUL%Mkcnu8=SZMn3&ujUXaPvcA6l?d?qjix-lNSwstvB&pG8uCA_V zhG{AJd_Dlc(9jUyRyM+x-ENyP&6buHajc+Z&PCtO?DcxpYBlW<3n6@Y zc_}F=@%#O?wY4iNE9?k10wEk69JE@kZnvAB?CFHTrU1dK7*$4ojp`js>NHjM$(-Vb4kxHe+v4WC07cnK(YPHE^GMmj( z9Q_3UO<#HK~My*y$S%YYnz;$luG~n+vD+ghKGld^?9;_k~tTB6ZMqp?(Swjw3s#@?6VI2JD? z8MBBMpk5-8$i~J7Jw|cE$dKD~Wwc^ajSdKIQWv}x2e5UU@ zI5>cLS1Uf8R-XA7E1RC4X5J(a!p_dl+1c5$vNC$;_xsn@)<}|UZEa=WR|orDYs_K()ru1r zn$K&I?=K#YOQq7UuP=I1S64SRH3cDjczBS>WG5#lIgz=!xzf_o^Ye4$%I)p#nwlEX zxX^q)i=LSv2)SH-e}7NeXfz4{h{xlUHJi1TXuEP)SK*O6OC1|bChNF)+DIXSF; ze}7jhl}e=&hyeE@K0ZD&dP$csc&3+~42N_@Jy8=j`mv z;c!TG34><}=cfQ6Oe7M$y}hwmjH4NbnVz1mtgM9m;PWJQyM1+aRjNxEJd-b<1Aq|P zY_|FNd323y^fVMj`Tc%AKWCl;!!WhAwQp~4l3c>znSA*i0K+h)rKOjbm&n6vgxl=~ z0QC3w^WBd#PcktvF*i3S)g=s`N#>J)>+5TULcuT$gb>$=?(Xh}hK9VnyqA|3(u~j3 zG`+R8Ra8`Ta&of0y{*-1udc2jgzM|;O-)TwT?jFmWPX}Wx?C=mN`)?P4IzAadCASq z^>{qh)z!<(%cPkz4ob{54u^wX+1c4CEiIMm5}!%tlgM9RU)e(l*8qTxjg7*> zLY+?6(b2K8vO*qOoOu91U0q!y5@~E~WLGGPip645UE(vzd=j}@t&T>c$z&1$fNKDN z&1UQD?3Br5Mx!wp4ElUNj+rwL0Eoxq=jZ46%;V!@NlA%R7mjcynV)8pWo2bKIXTg2 z6aawhP$=a0`@6cj001hLs=mJ7VzDp`gPZYr0Kmb)fnKktC@L5XhQndB`0((c(P*T) zSTbgk`Dr$pm6bI#G<0-y1OULb&1S2rs#2@fXwGald%fO?i3!}y&O4pX%F0TbrZpN( zOH0f6__$pD|Gybdr*mLnK&lHF#blECX+Q^z(P(538&->foqv9QMk~o=^7Hc(>6@Dy zlgT92#gZ|TFP{TIKLUZk+S(ea#lSZokH?3Hhsj6(-d)H{;d~sxs@vP!r>7@Uiy`fN zAP}HwTB=JJJTqfHiwt5d1n1{11o0PLgfE{@%SqdBwGhN#bP>LM-j2d~v%lLy5P#7{ z`0~?g?k2z8Lfme*E|uNgT{M%iiwJmGMCPZ}im9n7_SHiO4FtebHpI2&r8jXJ*;c!?kmw$bIq05?@n#svY2;u$xy+WZlJUrxl zew_K)+1dR3{L|A@@(pZmZdO!Oe9y}wGN05bo1|%4sZ`$G-9ZS0!5{!291f#j>GgVp z!H`TQ`Q}|NmqMYiSS)w{z>m|VrKPsEw(ofn;`2$({Sz`eI%>DuA%r6%BUM#Z?7GkA zD=sb`8yn-B@9ga4e1*(rGdtGW+Pb&5_dPE{d_JkUoBVbQ5g=n1`5}D0gw@LMKK&nl-kU9k@YOT`0000XoD{j76h(b^BLP_a`%5OhUD9i<1(&%y6M7%4bzNW|5F z6NUA|2Po*`fA^P!vQ!9yGi#t!Fadc)ybGG~5mUE2!!Bv@F04M+$H)#o(M8kCr+VP3?&(CW8XCq&dhPj$bcK< zsWWu%-9}r#M?o6>TX9lS4qGxCo=0xy{=*_9NNEWP)b$tT7(_rU2Eob2B`GOMF{&kt zg2D&{LUnbuGS8={wWdwh*4DdcfA=VNPyXb(*I2Zj4`km}R8%bgHZvoq^3k@*cYUHa z^%fqF9~~J%M|Lb|MOY;8yb4uQQ`6Ja;~y1E?KN$%zY>c=COk3^v}4EZAH)s^7h zy7L^5=X6$v-DS46>@3S2^Ssp5BE__#2T2r{ zFBf%`w6w_a@fEkWUUQHqBO?n536XN2i^t)t8>S#ATp7;6vA(cC&&_RNW=8N`H=I&| zkw=)`PYQ$Qusm%?XHTL3J3|=h_Ws% zEx|uK4Cj+Tre|zN=j{DtyhvK%FN7cVq&7Vw-^5T_&C7d|7c;ssyu8Ypt+@m1R5F|5;A-} z@72T*`=!6X|L4!P4$$=m#w^`+Xs;a6P z85u=IMQBw`o~WBQZ}Kt3b}S^T7oVIw?es9{jMPiX$-$kpU7QCoGBOsTV-!U!K0cdk z4gAitroY>JtKhqU$I4gU!K3O7Rx2!ZG;+a1+P&?c-;*c86B>LBdwYAe=7gt zwlXs_u~@9lPZ9H0)_cOj!bl_%Ju^FdHb)48!Yo4mMynN#kB^%*d0m2d;IQWAW?5O; zjg1WqXT27GLwUJ?n3$NLVDIoS9fa1^4ae`St*?)FGqSP8vion&dU|^|G&Z8RBO@ZH zsHi;hB~wyUe=RQlmIWC1bW;q8w^eFAm@ok~gjv@2hLyTy$w*1hkAEdG3mLxb^#}-H zJ?$GCV{#EP7mGt(r-~k#p2i*U@$<8@v5~yZ%FQK%-Vk~%MOz63T@L)w_!k>{`{(Qm z3JNSNEJha_Qw`&C>6bWJj)}gBXS992y`KL5!-IpW+_h#c6JNh>pKi6u$;gmEfLV#5 ziauUm?5wOk0|Tg_2R!hz?G8E`iu;57_wL;T0}vDxJUt}FB_^7`u~bq1-wm=4yUPU_ zFgt4s2zLDi1Oc#hvE7B{dtTf~Pfz#4Z-MzV`>t=(iF5tdw{~>}JjEv`hbd~7=v{xI z&YwyG9UL4i58nq+bZwRLp1wzhOMH5sU)IV7K;?S4*9c3anh#(8^r zx&8b|a2hS;kaBw&j0?Y;zrDQ;xLZH9;X3o~o}^^R-k?-sVxn{hEewX1e>+s5#J&7S z7W$YsSGTGPV0eDAKEK2~*_SSqkdQzm5`%+-Wv(SwR0v`_R7Oubuyo(}SJ>HRJluCA9uKt^}2<;ru zeE87y$&()2`j!^ZteLBK%;SUYphu=QU~JP96VInf!!0c>p|;3{g@vvzwJH210}Iau z+kt@RSgf3!9B)))B%q^YF2SmUV#7p1hmwByg{`}L(qMq0p&>s%|8Wu$k=|_E%b=s9 z(-b0-8FX9jtxNo3P;ci*b2{b+1ppjwDNex``+proN8hhk9I6$>u57dqP8 zRmMJT`Rrz`T`)4Ls;IO_T%s<=R908Js;PBhutg-~<)PPyFRq#1s&V2^ZPUNb5|_lK zAS*2`eNI0!Geb%K8Aw`}(wKBbWu>!|Q#Sf402(>z!uy{g9gJPXnfG_hTc!VGp`cGI zD=QhdO|rB~)%M<g!NQ&UpD>SQ!H3_p*Kp8EbB z$cB%<{|&N6#9jYQQ}FzEJ|2_$f^nUmoSdKS4ObafPq&4(A?`ljCU5d18nY+-SzE&~ z-IuS4Mi$oAy1Tl%qEKIEo4oIei-Qr(1s|CO1)bh=nbmT<8l+x9-6UG9=VWR5 za->i+41@6X^bFizp+AX#zOw-uJM1wB{gXnDT!t~rRYmOTE`t|Gl!a}>HC_6iQv0g=V^rb`W((>|+Uq4#> zPmhn4$BhYjH8pA@nRWv_yism$Zrw@T-COL#xX5cpnqyH3(c#CNEn69PENUbyqjVoW zq>gM)X5IqT|DBz|$dUT`jG6scXlR(Iq5&%b*wka`siL8ID6i|P|pf*{*Vk|5yY<;rU zyJ@z(ynJ(Wb9x$#fQ5-E%4zGa{lKRU-TMT?q}8?KoBzb@p3&sh(62qZh6!xvmc(mk z682D(gM)*p>pPusSHFjQpPvOX#HOXBAo)|bW}Axk=TCO~?>wqCS8$nleM={QJ3!vW zWgXbDO?RRdR;g5!ODSY_YKjeMWNfU-$I#N;j1F~hSO#(7CPQqVb$Oqb2qdp!?EtRo z>0D87d83@tWb=!Gt}buOmkQXo@$qzIp^u;6E1F)!ZxRxcTuIjybv|6I>ANS7|NHL> zUfbWpBTFgtBL-1jQ$u^@ia~0SRu%WPYfs$Wb=1{+hKDm12=h`MYC@+cll_Vf@o>F!!wAqd@3pat*cdN%8Xyo0SnkC5_;RV!2b69uE=8lO zE8_M!v0>f626Ls{2RM+Woq+@!9`yf5-9{@oEJi=3x=2X{(_OY zIynUb4Or;FzU9(vV9az=g@x6Y+V*GMevo)gg$SYtOI-AHnKoWiTU(6?coL1p&P-2( zSa-O;|5CeT{5CFKfStL$d=ZogI@-j`c$XFx*_fKKb#d7{ zIyyQ$1blc7uQw8I6i_SrhQs0J0+%_dspC>o7#hc;sjo`9&uuI(W8L(tUcaWHq!bhp z$yW+JPvn$ix?(F9!+iHYP*F=uYwYP>XbH$OAcijQua3e$kCy4Qw6qkR@9+EY34C*G zR0ukZ>0BhcOe<{q0ggOg`BntF`LJZ9rbYyqH;9MR(*TS>#oRzx`MYbUO4bD15AD<% z#WAwP`L2%Kye4NMbCJUlgIerL;Havs1PS=hKz7ISUZ6Y|!_&Hhr0s1F@$8ND_1x@i zN~mXWkhs3y-`7V9wH{8p`1<+^v&6Mq0$CI`Yi5FyGcx!c<~KJ*)-e~41|%w_0|6S0 zglVa$J_ly#p+cJHK6w6mr5Xovs*sQn$R)tQfCVvgCingZ<^@5=&q7cr@@8&D1qIIF zxF54Meaf^77GfP1p1{EC8yf1eb>x2QFM^FoG()2;ot<;CvOWO!x^bfj$Wqnx+~{aS zT^+rUuA_@f!`rvxJ(dGG43M&;qd;c=l2;R!mUE3r92^+nOYL3Dbif$A@2P&ZC>YUh z;pw$K-##{mX%wO49jli#*fGs0C~&v8KU^*dMZ$i}&K_<|MV^%C31(}#IXZ^H&D%oo z$ikP;D=Jo}8XQXWoV>m7BL3tl1WEdd8#sr77X}x1_cqrVNtl&~$2JgPyGbdr0Qvm7 zy1LXUOX06AM)=h6o$oi1EBFSfOX1nWlQnwByOeWa0GkLi8w%>{Mgu7kKrvg zHnz9#L7gN{ISS}&x#j&P26&Tj#IPvC zK)AmuZ1m~Z&X@_in&y7B9*SC4PL9ypx;aOXdso3SIiDIIVu*8WUs(}=l*ftntonHj zku^-;m^#!cC4OttlZUKwIcS!KEKGO^slsJLjmE~x$XTD1z>v#yaXBYx^YqJN9-5m0 z=q1%r2gB7fD_u}Pp6(fGA41hb5v@r*_93~7No79ND9xHa9xd?1(Gf;XeL5M;zgCtL z+x1dNRpM1cgZI`P0Se=k^RpZ-#UOrg#BY3`oP1EC_o7v)&{!6kPCX^+6YzK!+y4ohnx@aLBn83uRuW6wQ=gtx(;d1N!~52tSM0LYlRn&h;!D8-D-%+pr#7P(!JBZCe%9=~_vOi%+Td4A`J{@t4w z>FG;EVnRYw=tW3p@YuwJ-y@R!WCt0aMQyoKb4rTTV@ZlU?IgeD(IPXVuc|DlRJO7#Mh6U+?AP)7aEB z)!Qq0=gu(v$3K5P(p&#rX&8TRDt#~)mynRicE38&)Y1msbINNdl$gi^p9~-kRc%xa I(lX+I0Go#m4gdfE literal 4744 zcmXX~2RK!KA3yfa{UbAUMfS+Z-j^$d;@Tu5Bg($^%3g_#>^-h6B4meqNpE39p52og z9Ai;jQY8Xox&i}&6zztwrVd5gAUwT0>gMPQNzLJi`Nx;EZGV^CW8u}(O>?)!q zd^&VJ)Ka2IJU2HNiO35JBg7J6P&`zTb#-;^T*|mOkV5`w3F?KPpKSf<$KF$fPA_ww)G$;rtl=HK4m3uboSoWPXnRk%1i=Z@NzK=51O{xfNcx%!vQPD`D! zOyW((C=@CrENpD!h*A#w>~!}>$!2P5s{M4O#>0o{a(+_L-Ti}uE#AkQF$^LO4h|NU zmNl*c*d-!5Iyzq7vSImaliM(^O49JIgQFvad~{Ebs-R$1c{!hCdSzwh`ue(It+k=C zag||hQC=SI&d<+YuHN3~Lz&XDva&eP@$qp`P!Khzrb)xAA4$CWot>RlnI#xZ-_0;q z;@qI1j#Lqwy!?Cy@}9W{M|jBD*%=gga)Kt#t*xzXXgK|7KRuK!?`UC>kd#CKkBN>R zA015fia2jI#qN1Xur6pLW`_|OV%uFPL4J!~%$y#4sE#bb2^7p^`?DZ#E z(Cp2LkB^VBkI$dCfo|O(QsPQd zkByDh(b0j2+`oVSzyJPQ{{o&boa(zXD^@pS$#^?tV`Brsb`K5@Qe&s3p>eAc2=7w- ziATHyI!lcI8pRU|^9E5G8-w_WmsSQ+K7Rao<|`+hF7BAs(jvR6sK~gx&|*JDp`|q( zWMY<4Vku81oSO0Wtx&+#WqZ4V180zegx~p5rnE;wLPGz*K<$SQw0s7EH#FW0b&QO_ zpunr+!$VvMv}|K*OI%EhB((GJ&?Wb=CwAZ5%F))=z{F&Gc{zWvm;nZRo0isO-W3Ky z`(VHawTF_?RX3X`Dk>Tn7`%MBGn$X&<>7I0buHB9M(^gSL=)rVLW>*Y#r5^|s;a8C zZQ3yrmjS8ol3Jdfd)_)>fuH_gelr`cfJu6k&J{SGAgPQ-PGKyudg3)G>RG4qH1r45+(LvVf_S^DjiDAYueMmhx12|nHCceAj_L$JZABB4M|t*k|i z(1)0ah_`cn&xACyWFp6v+v2r?F&Mi?j~?0Da?K{H7vkdvA=q#rQc}_nwY5+55!~!l zeZ#|o+}wTRCS+p_-2M1TqQBWX!{Q=(X zah=XIvPgum>*}L@EiJpzJQX7&BT>e|$w@IdToH-n1amJSFf=p6Fq8k(^5skZ**ehY z!Q-vzDx2Xf4R$ID3JL&|Q+1tB)7HTzrlzNhi;LgMrXdX-v>p(9&Z(I(GCmH*kx~2= z*r~N|gM({>=|u3OlaqyJ4?*kX_;_<`YgM-R?d@$gHa1Y|YUR>79c^_mYGwLWj~iQC zTR(ohS?qy989jY^wb+4|_#|e*Tiw&v(NR!9KsA#sUhT{B!EbT|+Y?h$=8)=&3JRsK z*0uVTCXvj#gQBqgOAA}kwA54v9wsKHfsZ|;k9Blv>+7>5UGIh}#Y-Q}IkqLGq&zIt zM!}-HCH%Cx5+A&~o2wZg7S{8<#&U%`L@D><$K%3>DPOHz?Ck86lsYpcT>)iLP!tvx zCM6}keEG5@P~;aZhcJ9O=<4jx8b3cjV6MoCnHdtu$;oLwtJMEpLIM>NlQ9@HE2}#6 z&MW{n9O!AQ@7ejW{Y(z^-A6)VVt!_dM4kHu=C&X)R&KTfX>pEAkFW(;BtkhS>6g{M zOJJH*q4jr>WbG@>U<1BYCyDi9DHs(sweyKBQCx2v>)Of+Mb>pu(OpnE@IHe3DFUXY zB_&+^{5w|$3wQ7#1sj{S^W!Z*J^KwUrH}OVXwwH-7NiiWstZl-_Wg<60QtDNxz%?_ zpg=%s!l{oeEiDVR|A3rQ_zYk7GcYjl(UMWn{snsjPMVpW8%=C%YzTvE0L5w z&)@T703&>Se98RAQ?s+BSW@&UD?Pn|j*jd4NbaXkp9sik**Q44-Ej-FxidAZN=si$ z6s*c$Vez2ArcE3i94L@A;POAE_i1TSUw(i3BtaS~Y}pe7QV0tVrzQ>oAlkX0;%FGe zsISwIE05ocm*iYgMp zPN)1_TV$+ew6LMN+R4M?XOlZ`6B`Ic)ox^Dq#dyeIE_`(1^-0Adw_Hzjztz1ns4@? zOf4)bVq{=&N2B{E6*2U!_R|8atgNUWYPv$Wq$ESCp^?#0st8fibd_0~=Ya)*-TGi# zMa2$y*yxq(+E6aikDx>!g?j(~{j=AZ+L)Pvfvw#i&Ev&dj*gC$6cn=PZF*=CusZV1 zEyep_@Y;`_@FevwAJ9ZEyjS>pvDaq*;suz7Eg*29!1HtOAcg(aK_*vM*O~09F-D7I ziRFJQD#XM-iwBXDldG$%gL2&SlIP)haelPnd1*;cPtQd=4ndm$Wn7wR9uCUM$rWp6 zx}ecnvOXsO0rV@3bWKf7b#+6tP(d+^F}VguJ=;u-j9|S0x}blBQ7}zRu5=>{#kTED zLdstWPLFfMtGy4PVT=nPCkMLC|Ko zGdf~?QAQ1CV%*@4+wc0^-Q5>WF*84Y_yL#&9o@xej8!cjA0Hc=pPz>yR(~u!Wk6S^ zC@gXTz<@;!_Ddu+V96hCs~}}ULPCf8%@q}~z009tVOes1MklR7wP9&#X})r-0rUR( z?ecm=5ER#|BbSB`p9eqImV${WV`5_~%FCU4R5V0s$&Qnrc!3!=aE*n} zAx>B2rKHjjY`Md&ZX08lmzONY*5p7%k%of(iP|C5bj)kG#TH*uT@Ca5>VJne8i3^m zO~cQlRWmM{C`4Y0pjm(acFV!3XBQZz;VfBc`j3|ZVZ&>VvvrvKd}Yi^8|fCnYjCrJ z*0V&M!|fRnpu1!$Mgt7jSriu;{g|FtGiU^>kA#axbX%~*iF@j9u$GF9gvd@E<9)W{ z;^uaCa>DL5@0~N-y?q=SR8&yFe)k=9`ohphff_KYnawWu>MTk(xSFs#`Wp~y z8OkL73Y6T@&d$7c1}J7A=bGj_;7)BW8d1%|_0c<$ z!MpNET^8HT@tAPX=%{WBN=nLGr?v^9M6F*#O;U zXJ)#4dajPfwE&|2SsUKlvGVb`0Q_aCtojc#20h~lUH<5xymCmcW5V;1aj$^O@)IRC zH{%rV_wd&%H;7M3K^BjL{RbTHb#>_l9F7}M^5A$_|IJDm9s)cF9cd`o`o6wCkS9#Z zfvX6KH{--3Hxgnk^R>qJ%tcb(L?ETlYIAcF2zJ_=H*<$rvWJI_lJW=Frbm2LkhB}BLK65RvvhvNjI}k$#5PvC&2S9Ob4{x{N#OH8X8LQt`GG>lE;mb)>rNt zP&uz&dAp@d8e!5i)VdytDuCVHGt$3!N)g9GK9=|eitektN0TBULcF}ueO5f^8>$FK zlufIW*>GuDnWb>5ii%3V#>K3Lf1B^cP6G=Ii-v{eMKm%ZBqFkmS^#<%&`1NYw_sM}viCMO0RaD_BqpZx7N65rU__VW`iosm9+C0{aJi3Y~sH^U+COpx!&4*O61|EC#*h0&*hS*yH@X17YTxb_95 z&2WyM_hs)k$z~6?1zfjQRqaVzibSQq>9A%W(r?!?HT@BU2cXx?|BR#lsd*eO_Uqdd zDQRh7=#P$%abBG@0nlq}Y&29>Rz~lv`j4AJtPFNo!O?t3?q8+xZPl+SV~P|x=mDAu z{k!shT*#_yV!5DqaevI1PO`7h-4#`vGF zJ~p;`m|m^8fj^vg@BR~~3=E;6p$BJ|K(E!EpxoR2OMC}n^EBA21)65OE}^%up=1wGj1yilo_M|ILy_x zwycbocD=Fk2^F?-bNDQjy7o)$Iq zE$jNGreI@ZdG5o&6eJ!3)gdd}5=|$FMx*5duI9(a5(ZXoXqSUhhJ}TJr6mpR%*n|C z+LUsBEr6W@*7^Il6%vUAK+2QE<5TOsmzbEC(^gYdR<^aZH8(OM2RPLKAODh>y|c5f?8xR+M`VlaL|kNqB4ma`#*u8E^=IiAc#imj=B*95%GZE{1n9ClMKnX`0vY3 zM^ha-|99m!U=ksSc1KJ7);-_M%}oD$gUh__yq7pR)uOvzxlGYg-!i-gZy`2#nPwE4 z#)W!mOnCui%%N>aLUs$SfMw6RR!hnMiii1~0xAFJ4i$1zZHenluO@3|$=!N?$FHt_ zu4+E1K)>DGrOSc)?*+{Ct{w-B?Z2q*WxkBM8ONnqp}_!MgTsF=KO?m|3^?1_*%8q? zD!ahP#lf-g_YfzJ3{T6>4uYLGiV{QA)YRa<0vGLw-^PfzNV3xP>y^3>Y=RD#U%q_V zl`5&Mpm5pV)zvjUfb!Y?)^uhj7ZX$B*qAx80E6j5F4fl7Ryy|T>*;CTxECDUn36K` zPBXrMS6jQ(`b(QbW$JJ%9)C4iyCL{om4_Yt|9B0PlVTE2eOEoW=KfZ>eY@#Ed0E-- z<}h+f5@P9W|E*dUkGe-)DY?11+{)hgjST@c*tz8D>Z+QWT3}!x_FmD>yAp2wOoh89 zCRGz6X9?vm{yIpczD-Q5oQU=yoDV4log5^KngyL5I`;Fp$|;M9bq@^B`g+2Ydq9-XSNktWdLZN16W&)4**f}_k4i0qn_47x2e*SDYKRae+W!>A`b8>Q8 zc%KRP9~mBIX$VBe#@5uO3Ko3& zw9}Cw5E^#%>QxH%0gw3>QY$MfadGj?N(vepxaSIWg&G2prVEqPMx+E!2>!fK zmI!5NZ4H-~mlqc9?Cy4Ta3DjNTUbzLPm#D!*F7ICwO(FczJ2?)3`a>#%_YRxbiAtHZ^Y249yE1!QX&-OjnUL$tL`!^4N@=;-M5^z`B3VG9cjZf@?@)>a-Kp0P^6>5jg>J`Yb%wd%S$rHSOT zy-9bZbZt@5`bdctFs;bzGBQK6vt?yvjbm1YWo7OU9y|baQ&%SmYlfivwa-Yu$QPEB zu#~lTby2bF>FEKXWMpLE^I~Fj0E}^;w}W5B#_sIzvpElqjIeHYI#fEzWXz$LjUAh9 zuQ4+-b8vEQtgm}-O(`lUm|I!tyf=EGGPAci32-BVtUkNlKHc5fIXXIOS|F%%s<>_` ze2cp>WbT+*%CKM-{yG&?M{g~@zP=9jl+R{Yk|%gDmu&WcKp;GnPR|MWLpg%~_3LER zCU|qalKjb$qoZRv=AMa(lodeyF@ApjA!F3g@Njq)Dl$@3SeU515Qn<}eJsxHf9&n; z-J#KC7Rw_mD~pVci*tVb*mhG%NogS~I&|j4_6`>>ug$txQgU)uR@Mes>+AIm4VoGn zBBG+5$cmU4D%KntPC47t1U}X5u_;32DK@XIX^n#~$V6;~w9)lqIKOX3g9AfKc1nr{ zX7IYSbl*3CTSP>}-k!I;y*+d@Fc5wg*jQdpSXx5b+3{O0bJ4Cw@&hYrAa z8xL3BBG6t+fws2L-*87(2=ejSulsKqWAp*fgfFSS92@_LOjXXnY8k&-llEZ)? zCnxN|Pz$?(%CtwcU}7hJ%L|)oMEt#`33(ZCsJNu$5#F!%r9qt3$4$1nMREguiv7(= zOn$zdt?e8h4`Q&is3;>lJ5H`R`0VhCAElD`ZEsy&>gpG#gm&JlPoJ`b&tC8+;Fp$A zyEfaG1Ox@uZES)A0=N(z4wb^p7h_r(r@18xHMesqpRNrEfvp2TFoW?taA$Y-c(~9c z6M|x%u-Fb{o+?8{kyl#kcJn4w(a_KU_VrqvdD3&WCp|6gvVXI0bWdRUNBcSE^rR$p zK}Lg2g^)qn9uvM-a}+V1tVtnuCKeX8ws%IEAp=ZlX=!#g57JX1v$Ip{gx0~)@%L1% zfbabL!WERli=yoD@$rxlB8vH;A!gL;Ry$HMGP~X%DphT5Z2^IS?|I4TsM?Gd+`8ud zEUdkJe5fA$sG=?%dZS29CIEwdXlR)3?`L4YFJTt3xWB)T!(x+@lDd0)KUY@+>E_%B z=0PX`iWW`?Rgx^J#sG%Rdy;tZdf=>wTf3OKJtBe!hCMQ2~ana#V*aLlJuKB_m`F)q$ zUl}1jF$sz4@^X+TDXys9E=HrS+1cQRO#f1qC;u&Armk{dDl3_WH?=w~MgJtf1Snfs zO{S!%eNw?T|v@XiVmfGKcmtuZ<`y&pwvD}p!esnFp8^pK(XjBS< zf+XXhIx#RX;600QW@TH`U(C$RMh6Eykw}u~HygEW-Q3(99rr=}<+epdQEF zySRv=UUwq%JKl6I)z{aLKJeF5Q+t=23pEtg*Pm?9f1@V55LlU4Q1JcdPw^W!W+x_; zL`1Ydg4%huZn=cyOtIN#lwdW`Lgsi zH=jOzipOOlr4N@n6G4H&VzF=K-6QB#0}i&qLjqKTA3uJj&RlUa{e+dLBX=!H{7Z*1-4Iw)7N7<2)@$2$Fj;0RpEL zDGg!|bh_#%lMqy1UXI|#d)4I*R@o%RG%j3%`lhErYg=7dsMtQ0-?Ath=eMD>3r$Qe zmTG@zqwUku&Iq1sRqYB)QAAjnu)p8vwe|*w!{HHpj8XBtH^`t*RaGzi{J=bkp@oHo zYkGwR&gHa-V#0s>QsI#l5+XgWf)R=b`E5wf(!`4xg6t>$0*{m6csRJ*Flm zG<0-y)YSKkj1aR=tm#EXamqehx!pt%5FUPQO&t4eqO7yk=IP0Ds*Q%G=DSuJK4#;D zhM<@Lh6DT1od3VBrBA-kC*a@C&d$N-r}C)2mX-xDlftatRi>!#pyW_I1lbm)j)(v) zV;E-!Y#VT7Vs#CVw|$EyRkn>qquDQAs^6dSr$+!4JejP1xat}zBQK9DECh!p0d`AE zOXiEq;E>=!XlVu^uBZ1CkH>d*c7pZ}(l8etX}CLMH%;Q?>MF)Me|CC|nEq!$fByWL z|8Idh3!;jGFY=qPxcD-`m$7?dWJC@ibbh}8tIo_st{Xuj6=HBUNVQcZ7^h`ol3Y>o z%*RI__3^_84L!XlKzI31Z7atG8HE)U0qP(-Gqm4FZ&hvM0Z)jrKrSKN9+-jxz=zAq zl9F@~Jv+Oik`f040}*spL}Y>BOGHEjK{`5Jg@spn;>`>V!2xG(W8)a#FF=v^nEaLv zAU_-3qeqX%-0dMKDJco0*Jadfz+W2ZX5o~lHQS*?R7gmO!HrX9h@OQdJd6Ae6VsYY zcPdI|E1QtdD3LljFo4K2EG{lC_zh#94L)zk%gX~9nY1W|>tOK=c@2XBZv_ouGl`6x zT$nk!?{|o2?G%CVlmjgXhnM8%zsbm$7#QFu^jhd_=~uX>gfY=ZdJ+~|hfT|?&9~CT zOzpq6Y%O7hR@nuWl_%TUG(fX7FpyML4KkU6FUq5yEfuq#Uyy0eGSJ|_ffEq~Y2DUW JFGbjf{tu<9l7;{P literal 4437 zcmW-l2{=@38^_PsX=EpqWsoJ2ZIET`TlOWgBx`ypYu0R8N|NYBVr-Mfl6}j*#YlF8 z##&jDXt884W4`D8&UMYX=FBDhg0snUem z3L%7)W8j4LoTb|3g=$F>V5*a3? z4I1+c42;g@csKD18{<}WKwD^le0h|5G+uVl9J2I%j9t^ zN9uF%WAh<_M&YAl+0ccGct>vK_2 z(fY@nA6r``gPW5WdbO|kavS@an>#;$nq#M}Fcgouv9U2`ek2VoEf^1G92EXxbkwVX z(4VIp60$#bs8$w}J%D68N-QrptFw?9*LCA2J(98J zXcG&ISmJNt?Az&q`UtkvfwsWa!Ku<~7tWvmyR&czK4RCh9h{tM9O_D{s?359@MJK+ z-0ZBt)es3eIXNLAAtj|IL-Bri;>4#<#F1QuKY#wf=`a`!wT^?WEzPMwMO$m@(ed%k z_RyWaq%#{E8?CLatbOm_>rqoDfa#ZFu_r|0IX*u5b8wlQ_Nc>qP|q~hLO2nq!dB}3 zw=wk5(NRoH%nNag><^x-It;?81H&Ib+T7D(0HIAv()aWfO}wJ0h@YIalIHG@4JQ6} z^Y#5d4anKrI@4L^wtQ|uK|yYAZf|dIa&mIvgI&fA zVF?KdNlD|@$=jSvNocgo{rgGO;w|H6XPQhjyxGb7Ownn+UtJGuj2UteEY*_xe&7F`Bi zUEP*@OHWL${)3m0-uduCTu?PgPnS0<>}V2W2*pJm{uFL_`V?+sGd(tDo^?J_8kkf& znMAVWw{XVCPEAcc&rM4kU2F}uit0~hE{y)0`y_V#bQ&E?PyYxArDPq*#;NvJd}P6V zf=s9g;>8EBo#ByzpFKOs&CZYr1h&!@tp=1^UoWq$tSlr1RlU06_An)d5rW7EfBwLr z&CSiHyb5p1%gcdY>+9=*h<|_SA6kC@{`K3pBje*1{i9caWJE+fRtMAakaykd9H6*V z9$9xx#@DZ3A3uKF*4BnGOy4~sJ$y)&q!WL)-SY!GRXhZR@2;gJBqWrVOFC-Co{}0H z6-ml#k~VM3P_0|vzn44h9z6&S4)$aH_T@aqJJ#upy!`ys zQ0?>(5b}KEow6znCU|Wq!@rw6i^JUpzgSsWWn^T00%@0AHi^e4wkf(Vz6;c#vommY zjon@Q5H9WH=op#RQCPTAZi8K1T-*Sj;=kN6Q)xek$J^T5kE7M>y?CxD=CC!yQcg8; zO{*&_`;lM_Om(%4rEYL?XIiSICI`@ImVJhi=m?4_4Tqvj(y=Pwp4G9vHu5Fl{DliP z*47g^wXmOy-Lc&zC4GZ~bWp(IPnZ1hMKBvZ#N^yu82R|X$JpH5Je@3#LZL2Q@?B`Y zOV1)eBJGX4I6HUzf17Y@bsqZ?02aL2k3a>z15O-P48~pyQq3@;f&R_T{%U*<1D04y z%EU`Jp;skh_w}%jp&{=0I8yrg#u^Oj>gxLP<%_<){>_^=J#f#O8X8suRHV7Dt>@bi zc+|Zb>+0_K`Yr$uZwp{Z>T``H&nzxF54^>}qxf44;c$3nW@c@=nVDJVt}J`XW=N!e z!dWqztZ{B`Zbn8%P>2i#xtM6|K;WV@Ff7u5R{@y_A_ZJA3WtDEm8Jp3i(h%mkR}h!QAU!j(UfM zgn%6U_CAFpoPDsizW#}&2XNc1Y&czl>BYIZxm9BUNDDg+il@ASf`*0$3@VH{mQ2S@ zs}~L2FaS~Y@bEz9k-zlQ$7`_)2*e!k-&q&t9)ln3@AL8T{l@Jm@R2-JA&7%+1Ucr*nv# z>jg9VuXLdmZlBFCQk0V`p7i+?jN0}-6#`Xbc(|gpl=kSgrGy{SX+3a<_-EC?zyPQk zWHr!7epVJ&WEap9@M&4^Y&81rojb;e44@!PNr|(IOPw9H3WZL15dZ@aXy8Q_;l+-K zhWL0`Wc~Q?Fcm~Pm~-{X3NoG)&^I*f|M{`3{v$0dt+%(g$KX@p3?pFAc6N4B#eY1B zpL?kl6cn7Cobm%FNigm+W@t>PsVN+p6IZMrJAtMUiQ()iiGQOB^Vpzx<# zTU*N=5ef4;#kEyc%-ArX@*6jfz)*NDxwgF6eqG=jH*WC0qJYBgW8lDB=iuz>$|6kq z{e?R5`KWh|V-u5;S}hsd+NvrcQC4Uk`MO=c0)XB%6O#!7;r46mJ79%szW&YqNdhjJ zI`9=>m877`4vjs9H^4#qx~ZwDzWxBf5i4Cp2K?VW;8wi6ye@4aw5``(?b+1lMS*7Y*4mn4oP~43```P8#l@YSF8%mf29f!`^G9{yyn`94A38C%uwXJN&FVxu!^?u_opYGPa{*kw7@Y3C5ns z`yIz2hmbZlHo2y6l9H0TyD6Z`pL{oq(ktpbfD4ZR%9PK2g{H{Hw@^TNEY4v!u>1nR z5^yYVab)3m4L~YW(`~Ho4qN=+&`RJ67hfEKaB2@3UHd*jG+U3ZfN7t2x# z6E6p3BZxZvDBHbl-Jcp8+hj&FUuj*G4g9Otj)ud1MbVi%?)w{INa&psWt$dgkA?AuhK2^=L_k}h?8xUzi;9X~ zy?RwzdSq%U=wNHc=Tf{@Eg%dqjQ@P2u>>c`k$Qq33rqUjx6;AEdw>?WsIzMPn_Qa- zm&Wo{8v<7inCS#D42||hvTq92BT5KQR5UU4Q-ZTWG#~AfM3fR_zcicsB37fbVk{`xG+On z8bL?9>%UgI?Ik!*Pft${f8~7ebe6HVu#g3tf`W|@YuULnZ1rfp8OhOB4?vciTk(eO z!DNb7lpTFOncm{UagEYoZbTTu_w`rMfW)(!h_Z`_h-@qQ3Z&CR;Q;Ttm(v{@yqQx6 z*i#2=rDgy-iHqX~2G(0vVp5+yGoS;`vzf%hmv-IGZf17&`t|FB>p?IGV~{2#DJjgJ zA|oTi$wXUzR!}4IwR=&_54<sOt#jzMe5(97y1DISa>PYN&#Q&P)BoVasAxOOb!*O1 zRmqKwv~%3x=jC;akF!3ImX@B#u#QIks;uc69vTV=30VtJK~YGcmFola-ku6FYM=PW z!!(XCHB};yn<$Nc^4lrTE05SzW|%Ip)EX>4uf$MHm-W+7{J&dJ$0Qs0J{1pEM*#Zs zg?h**hh#FjccuFZE&gPj$Mpdl2S2{;czQdLz2K{IMq)oWvFI4c%lswV!hZTPOm}`Ua2a&k~(t4a*nSOFC`>&3-|1TA2RC4 zY?YXpn7DcVIaEwXJ*;44Mt^o|MZ(e1v8}ybP%U(XK*%+{NZIqiY>nRq7wa;$0=7>~ zq-m@Lb^?00nVF`Fii)BlEki@FNUt#%5dh*k#V=pJeCynrIsPqG4-p~(L)(4RdIK@avul|QY97yg)tt&)pr zEuG~D%~*0)!tiwz77Dw0l^&|9TgT91{9vyU%DdTmKcw?e0g+Wzzbhy1zsOSI4ght zHzx;ESOFS}{lmlm*zUXx`7eVATw3>yQnryOc(A-PM=b7wP3J{ss5-#w63AHJT(4T^ H*2Dh+uluN& diff --git a/collects/redex/tests/bmps-macosx/metafunction-T.png b/collects/redex/tests/bmps-macosx/metafunction-T.png index a9d5a093b69982f9ed2749fcf1a5cdab64a0c4c6..29a7228ea5999ab332da6e7c7b48c9b1a9a39ef5 100644 GIT binary patch literal 4725 zcmW-l1y~ec7siKlDOmwwLApyoK}wL8UP>AzL^_sUx}-s*6zN(TmXJ_dX#}LZl_t}}}nVo0$o;&Y(&+ptQO}HWnAq^n_03^yv^4j3J5d6wOu)*VanGy|n!naUW zln3tq`{c9~B>?~#x3avq-0gX&cn0(h$|Ze?Q>s@7+Vi# zeNQYee|dLoo}F2DZe)ERxSLTo6pf!gND0A}#&&dcWF_M=lgrNcQ;!vCaF9hIR<18kN)PaHW$^IuPSyv@N=md^ z8Z;hRIyv#B58?x>8yh{Hoy~riWVhHcT|e-!gO}IVQW6ufsa}mo^!zifV0b1%vyk{JpWUv%5PyEKEUBv8l1K zv8ibQ&Bo09qo+r)e6+Juo*k%4W9>xPbwTChn7I zSM)<3US8f#ZaP}p@T85C%VV!wvHZj1ICg=Z$ zTYU9v2<}Hbg27-%l#KZF@k^Y+nVFfd%xU60x5v4FcJL-6BO{81lHusPj5V464;EpB zo15?1F0~094yT-qc>mtO@V}ufT!Kaq_x5VeyfTD6dPE*2&zw-K_c$A$C3_7VBqStI z+z!0^5iGi~@S^jxvp)z?bCUEyCkKb}l9Dga>_2_^LTxg$u%M38Hf;+Sw5VSGQM}uY zO9+(26=`Ji8P*h(m#g`6vuk3L*a*?PXb5~rMJ`{>Jej0Fib#3u(0etbe%NesXnnRa9J@UKAm%Z6<28CB$A9SojS!+O#0jo=EeZ z>(Rqg*T(s_<-44+l3lVQ7b0_4MK4 z;pV2z^n$I01sMzm84wZ{UTkz>VPjkCj3URyUO8V193CESbKfEh?P#~Cc5-rxp?rL` zRg?`T$>`XaA@8Sxb_Cye`KX1dmqz2SwWA+8aK2PW&?i!ko1@G~4h{`I$uob8#V;mmM;g>=2jD^36_$63p(TL`KM|PUS|e$AHrj*1 zocI0i`g;@|6C)=ptD>r!o|g83R!lo3kv%>^mR>5L*?H*&KRMtf z0o!i0pfTrTz*&3WM@b_>K2iBoY~V+t#{PnmfxsLkAiZOb8}LXUmR$gvKSx*3#l7K7 zVLCwC=XQL@jI{}4J<{ItVZXAVxg1Ry$RzhUd6Nt;(4sF=yju84nNzu`xL1||d9}~c z$kF*Z=&`(%WmQ$bL6wMzObre?f=OUu0fs6;PYOt*w5KYJH#Roz0g=(sA#DnbQ1BOo zVQJ7SBk?8mp0t=rTTPuSV>*4OU znbb5}ri5R&0V8^`t#3xuzkV2!@(*48;>_sf-iLtX!$D;!_ln1JKr7*7V8JshFoL?3^TN3>0{PV4M)ff(qPl|N3uR~;Wdo7=a$!d)o zrKa%cFE)8OAFuZ1X>p+Ej5pM?xwv@s_}}%5I4`O(LVpboVgXoKSabD`p*wD_u8k&6 zo}R)mzP6BLpxLGr7H8E^WWUYMn@;nrrGJ~|MnM}20rtPh=||-ta#yb zani$RBKpK-S6`|d_kf{^CIt_5X8;g8SE1LF;xD*0R z{faCK+bcY8Cw%Y1l8G7!KUkygadZ*I6VF6$;{h2l*V*JV`u>0Obpo4R1WudUvZV%n z?&yKTHuHZpbBj(f&ujj6YW=cYX!}C=!` zHw=dyNA8JopU+m75Z`B_rPwgM837ov5RIhmrjZt3aBj@!JMk(Gj_pTs{x=VvwZ3)t zI)A!hFk_<nTyOrpFYdk3N@w zZf$%Buay9$FCYLj_fw<@Qik03)iZ7A?(>#c*1?g}iDIF#>U8<6h)#IXtu*WJB3ih) ztv)jGNQ?Mn1BU?@J6G~o2P@9mvYGMQzwPZoHsb`bxmm5NeySA=_JNn8n1U8NM`fPcpc#I=D+b%=L%5dwNI>_jp9Z$#rhcFCiI4Zzb2r{SfTeYuR+* zrI}!ai_6GId|K}pZ)%hPK$Lc9rqkdkE?Y6q*o?`f26(;NDyV`b~>?IKCgVA?s5? zK^M{a@e&=~1C<4&xA(X2-<{?gwe_Krat~%QB`%=bkN!qaC4<^>hG~PTerBlI6Xbx6+%cy}iA7W~EJH%*giG$jA|hI<6mnZn89Y7NJl~P)PMoYpk!gnORPDcDBR;gR%-4 z zjEtNd=Xn7*#jt~)pOTZoc{?n8KLzIw(rm5OAol1F5`298ED7&F;Q!j$i5vNAb0+Jf z-*_XDHgtJ+)EuBp_dQptP?bqv?(rYm8NHBJv}{-Fa40x!M^!VsTsno3rJ5)WV*I}= zD^Ea_1hMJolBc_SuTn&=(|D?ag{ZPvf>aDHSyXIfB$Qozy4By;$Y{3J{~wsrG;x*1 z#Z^^RoP2zXRpvOnzvt&o3=PE`XN8bDyz|T8v(C=WEVy6o))p06BM_RRYhXJgB=qVw z7xvC_X&c42kDP5K-FuxH8U5t*0j^NnSnUK~D`?3$8BN zYLx)n2UvFf%(-Z^1}hop4a@2v+8bmFP#UYjh?7?HT3T+v<@(X1lgGJWZE0y~Yg-Z@ zuc4@@sIRYYVetoyL3imLin_yFC0Fz6>IwkBVr;@k1uSoFM#|<|3MCBAH8_K$sqp-3 zbv1PbZUC4WoD?cUkc|HR{;Dd0BLvO_ta>;tjmFpaU-h8RixvL6-3to(MtBbNznnk1 zETmA<(CAq~%+AhcWo5<1X}=k}foVo0FzBlUlj5hSptMWk=_P$mw{_jzPI|ta7{7kW zjY)zlDi+n(>(NP3N(ppzb%Er-2R2soi;DpcdkN8LvDcB>gnmlz>F)zUAmqlL^Y%bJ zsJX=N{9Y_|ceC^JlZNCpH%k~B8#lfHNi|@#AV1#?v#E7IA}KXhH1O6B60+FrT?;lf z!P1}tQ56;Hxtd_;P>4JdiBwSNy7_m`hQ}J;lrG|&CFWL`lheMiAj!fK+Gp9_*(oX} z=Hca~sGtBgBO^9nkB^VpR6o&5`cQ=A93Q)Ka1^b4`13P@^evkb98M1pINx7jC9~~J zdTRpXBK<>k27;sGT)hkwv)V@vw1eJr;dh(BqPXnr;qK1O!@~sO=I5W9nu<_gs(Ck1 z{kG==-Sc|H$`9~HS*WF*9XIBK>O<(easRpF=d(-@J6l@<2n6Pm+8vhQ%KTyt>;^&E z-Q3(n+^0J}I$|P=VkJ{X`Vka0=jCC?y_AD~HUAkN8%tabuQJ#Ty+^uS^9qZ}!^6YM z%Ic7<0PJ&-uMO+$bfu+%h@alK*WVDh-V#|~z8JoKz0lqc%yYzaF()X|(b4tqNyPUM zk&x`|>?A!d%u4_t0k)KsizyS91=o@2_AYJ0i_1%ics9*E?n*GB6YPlm6G0lW4^AqpQhss(L^_Tte$qcWbd+tWY#+H|r35tk(=0F8C zH8qu$l{GYY`TI+LQTwmO5E4QK6$EKcfk5%v#H2kt09@Bi5Zz{HjkKgNpbwXomL4J{ zKAzpXpV;asc2~L5pTZ+b3)j$y?=bsXUq3l9;kejrxE-iiY*P>sp%@t0X7E0q`=tu} zi-l6wg}=Z5p+8Yb&inVc7nC4`?G{BxMuOZop$g9cQL@%7Sk1i zMgc*fUxE7oV2>PUK}($p=jY*>`|h!0LrqOjzc@7of;&7zl{4=D8Ets5~#NubTVz=fSeHsN< z*4NoMIT34pj0y@0%@Yd?V%VIap`q<9kgso`YwSP->Z$J2M z#$aVtRi;E-xAT`8Clld}(a}-t(}e`{gVbx1g@uKXOnMIS)AOG-8@oXq$pecUDBgSX zwJw@qI6^|?IZ~r`+E20#zx#Lo`~K@!)kh@{k6Q1Uk2v^FLSo|D9^%c==*S43Kw!xP zL%24GN=qBsx)hf&TpDoS|MYlRM@NT4!v4q4pWIikQk(>+t9O4NeYf)sm-tGAH90OW zPR6K%fss*_#Z85g;mR#A2EeO~jOnSVSmKcK*b@9K|6auL_S`M);BT!Vofqd~k>h!) z$o%omii!#f0FTFiAIGR7FCyb3pFVvW8rsAf8BJJh33B`YmFclOfbdV2CODZKC7-{0Teg|Q|JD)D2RnmVHY z*;%|RE-p?_pZs7?5SNkmLyzw-4Qb8CA$@@)Tcak%U-+q0(O8#it^*xSF^q5}$EP9D8DH<+_}2q+*dv#iY-gp#i*&~7LM9yx~TK~Q{ymy9< z8vJnng=9-DE*@cTRHOUw5-xdhH0#vV)U<&0=i}i~30zO==(u23{R;rippp|9xtB{o zZMnF(fa>nL7+i-b>g((C^75XYoq@?_qocaX-%En(SW70> zca7Np9{$b8!!~fCS{fS~_BTDV=fs5aSMo*h>|FbbZ7+O%x`_V|6nQvC=2`h)+hEcQvNA3y zDQRTH(81xG(L1O^N90{$;VYfI z@=YQ(2r+3|@v(5|`ysMU6~E}k3#jo!1UEMCS5{7lKoWEjcc=@+zjILls~v-<)*A-| z(x#=Q1sSklRr5$clF!I3d7cVjfVJ#dOJZeO#}Q<|-V@P0<|dI6{q~=a%TG)`4pKDt-8=gWmSAmd?Vpn!1$p@!s?lxxcy>8s zx;tWGsVOP@dwaH!lMIlPlN%ZymgXEO z)J}yd=Aux{z%okpLXAeRB^zmZ--IqTe%RY)yZYsQ+NFzw;~e+@c&aNBwTIfnZ|>6o z%iC~UsIZ6jrUU>u!evi{GO9)Ld!Kma6Ax5*Bu?yYKD>Ql7Eu^V2CS4j@hpBn>G&1_ z09SCHC)Y~-F#3JYQh#3S({@MXRr&(J`sR3K+Kp9WX_C%vNU&@Ma^TNIuTjc>w9>*d z7pX!*e|uc>_fpT5u+LK=rTkm{4QciD^?7*?E-vrW($Z>b{G+3zBO}|u)S(`jSzB)& zoHaH!LZQ%rfPg|i7b#AcvJYA@dtRii2B`Gas=2jxZTdtCfRjYhTpmp_Di04(fhpKS zrKJw-e;+TSHi>?`UWSHVaF|!w`}W3?mhzG_qi1L+uhX}$wOyZiO5c;6C;-miWUir4 z`r-o*8DYml$mp|6S3|~4V=oq?7s+gW^s04GX&;y1Rx)?=t*vwgEf@^u=$IcDr)gj? zRP_iumVXZyu-3QdtE{91c6{&@ctW(36Q65}h?(dzjFI-s>5Nz-Zs8FUD+(S#A(U!q}d4-mIi7gBt@{a zu(?_S=I@1w{kZeV51*?&8!Sfy`puo4syT*Db#>jYb?WNsvo%iepa@y>y|c*s7)d)} z)?^5!wyy5U@o}JHZe?ZV-JtJk5W!sN12)bb1CE9HnI@KDe-h?-LWIfr0zQ57558 zz8adEQIU~0;#S7SOsT!C!6eo;w*<(mKrUQ+6Pt=4VPp2&h@`*$u&Bfbs607PoynnE zS$R9!?h2rH7xp97XHFd>k~?_jan$`!_a8Z9NXSaPMpPuq-e9!ZVKkNKR@ z+0PTN5C-eLALv1TQeOlG>$8BwGM?YsfX>}1c zOn_q6*-XMl_0O!E=;5B9LWX|Ye-QYKD?nLA#RHPR9J$8WZ+fKTgN53~5RJjG^D763 zLY*IFTyRBoJ_SYKC)F{ox~ZwU={Vk%)y;5%aD&&|-;0xnhmBD+W>Vxw(h0WboJ5pF z(!-~=9zBv+{F|?=Qu%ULsa@HZY0KFdVEaZbR{D=CTK)!0w15xySm@bj849RLDQ?&^ zC(xtFm3X&SQ&ZDFgo73UQ2iNhqH^+J8yszbZxL6;Spk3-h0e;lA_3|8(ba3GKczb_pXkh!Y z*b()oqNbx26k{S^bT-H|v$N>z>}J>Al>Ges(^CXJJ-u+o9iQ;j!70-Aw!NKQN(og7 z`3eNNF~klM%F6p)7Ksb-rS=H8si~>He)6GbLUT5VtKs3TUS!=Mfi`j;9UZN{X699q zf5q_YRyz@Za`&dU~OuP|UapgeD{;1VYKq&TjkY5y7*! zuMe*?=pLx6OO1~gP%5|B%2S4)M&7p%+accL=H@1i%0Ip>mP#2eZ3Z3;80(hN~ zu_9@UL|(4-qx1z|zkO>5MgWbz7FpPH$N^dfYxsz8ih$A{q7D2rkr3nA13dfv+b<~S zjG!oTEvM9fRrxQ-ceS;Uy8K&C{6MZYc{hj*Jwn&SZ3?QZiQw~qf@u;g4m^RCg+--f zduw%dnxU|yV;g7M&NG~D_6QA&)9xk)2|}&Fp;%eQs0TAMGjg|^dbbqBF{9Ka8$$Al44{x(YL_{d2#<#b(7Z(e?6=zj5=Lb@I zLC^x}mo!xj<4DdFvlcylECivctE&qO3nL>V3lH~qb#4&qy#t{EJ286rslUH&&$aCA zY}4Cp$>$qiXsH7T!Em^UkkDw^3#$x_wuZpau)rjdm_}HM|8|Qine-o8}f$~dB!5?dYlY8pkOw~@>*J2 zrhl=p7Kbawf!nzp9Ubv-`;pO6&_~I(UnCXTGi%R2X5zcw_H+SC6APmL9zx}>th`CS z%Ha5TBL8hEDcHtPCdj`pU%mvM&ClD>#5Vaajk(rQlE+}NC#31pv&d-BPL`B-xVWsq zm!iON7Xx|K%p3gkOBHCgIM~<_;o%;hp5S;D78Dc*t!A$)SVp55RZO=t7`-Gw zK(yYQW=T3pm|24UF_{zG%`%I{G5H-xgWp&>p#-tenVMsq;5AoFALmc9<(xlh~*ev6$*RT-J7u`xe)cfp%C z$u9I7hN~(o>FDVX4h|Ha&c{#ep6;!+1a0CUCzBVNmRo@K3&DZ|9aVQXS+x@`^r@a6 z4XVGQtPBDbz>F(Ep(W6KQDp0*yvX z6+e^umH6fjIY@w<48me!VlpzUuiu!fS*U&H$ukClnEG-qD-DIJsi=rJ+RFUVbl4q7 z4c>+pw40X;AF9)Zwr?u6z5(P1iMhb>{95 z{LyQP2?>FUJT$ReTU+tBSThY8>*{P2P~a*4lcuNEgM#z_9%dXYDmhB;LPy zQ(ZAwHR>Ep+e1XSfdSofjr0(AF;P+0D6t!apXdNWB_^vx8CMM!=xD5`|J}c}ZKlFnA5Ka$`};C zb7$}51iiLcz6T4;{=LH^8h!Z>4r-H@P*$3rv-AGdC3Snkn=Gpc8wc>M5umSatW~Yy G9Q!}M>IiQD diff --git a/collects/redex/tests/bmps-macosx/metafunction-TL.png b/collects/redex/tests/bmps-macosx/metafunction-TL.png index 1b0410ede7f8c957006607bac0a4f4a11825d2dc..e82e5a51b557d092d8ac29548c4cc9fea0b62651 100644 GIT binary patch literal 4332 zcmX|F2|QHY|Gu_JwuUsx5)xUGZ7j`L#)vH0BP2`qU1Z6=%QE&b*+qlwV@;Et@LED- z%a)x`DNBCG`+qdG|01dfulYxhmbE7GTXl-K?C^qTx>{oim+~DSXd!*`XnC%Danumhpp_KGm z=o)AM{(*{`x|$`PTR9$re*67>?|&ptzkhImjf*?kZr(BV|EZs{y0b$G$x~@&Bc-2y z>tA2D*Q>6s7L}CzJT|6(9hTSe`Ej6ALXjoB&TD7(=wRn+2g^M>XXiB4*E)D{9-i=4 zGnLcVL?Q>;*2d;#M#g!G@B90AytZH2le(?^!;Hs*Lr(% z#%peCeVwJ{rf7Sns1@}{boU|&G(9t;%w3n9oE#e3UfJB=-#-c~;1m`f?Ca|r9=_-_ zJ~p;B+j11i5#Z|Xo+%gjH=gYdjZRFj55EgPL)+-+Xj>bai&sYG%j|5x>E9F3c8I6% z>+8KRn6UH4wtVm+=MRBVnEYrKzn^0UnLJZpzGUKX6r?0y^!QUvO-&~!CpkGe6B85X z=jVCvzk*NIUA+K%gt~X{o`{HueFozV^&!EB1_s^B?$O&Zt!At;9;+Wy1*D~=C0%Bb zK6_6L4bz8lcWxx8u(M+$w*xhowr85{rO|nnc)Z|A=J`;ld7?@{FbY^De&Ye4MtTv(c-mr)8T~{-z#yuB%`9@;$rK2l9G}L+|1-;v{Aku{}q~u#ztuTHM5Rlc$5K>WjLzM~@y+(zBC8en(sN9Dd(hmwJB1lPW_H0^-T9seGjv2qGaNxxg%#F6-aa(sGh=Q}_Mvg&0lQKTqb~`=395p1UHe zaP^?6aEqXKb$EFA;lqa|(b^+(b0GO|Ge3=txF7v;O4$aPhr{9iLN}C8DIKCQ?)%>~ zs5n*4;0VX6>}>W7_3@!0*VDiLDMQV7^}Dbf!m#MQ{rzZG*&NLuP4V&Z4<0-?hwrIP zSD@0EId{_Ne}sr^ud1mL^HhxO{3Jxb%sFg8#-d^Cqe3f0kI!4?l&D1(Mo{n3(9&i} zKeb-yh?bC$SQ*SY`1Q-#*%{$kKttxqUbeWf5D^h!VQC3^T-NL0H2fy0s1F}LL`0n9 zwh>&sJZMfzMmMgcdKp`;j^ywgq64K&NRa8`TL`;neiNf^~BHOfzIdZT6-x9w{ z-Fn%lF+*J-PvKKiQWDiW&Yf3LG1%X~SwZ|OYMT6``~)la_xD?6|#IfR)Vzsj8^h0brECu5WM0zj)#9;o;%t z_GhzZ5Zo~YIeac3=32T+ z;C(F&9^od%N*5Vw4i9tfP2%b8?X@R3h>gt7(m@PV7d`sFCS|K1O&Vf z4Gl%-UAsRtSz|*2v9YnekvBDE#|^NvvI+_cVvR>T^px?GQQTa1B*{o8MXgx zP2PK^S9@NY6T#mC8430E^>y-!1w*|5EWZ??ad33} zvA-`SCe|Eq(uCnUPerx5y?yKE&8q6^Hn-zc15;_wb*5p>w3HNEu@KoO{n@Ci%lm(h zJ$nX3i@Y$CRE|ZDSd&*n&$+p_W?nN1grTF{ zb7LHT%QCHRxnn{8`%X3LwT`s&v{as!p^*`PqDotP`}60|g&)6nG&jG<#MEI?)nHPN z#nQV)A-HV;#rH%80LDJ{^h^*OUK$F{R+^I~4$iwaH8nw2OWJ%)8X6iP>qscKtSq+G ztN|QvXrQ5?DJ(3Un3^Jk!0%fo4IhBW{^TVMzINvh&TvgjTf6m%=x|ASLIOiHhAUA; zR8;iv=tx&br+;8T5sii*beGY4PjVO1n=*!NI}5e*FSx1_eQHMvf#Ai0aAB<6}Q6 z&IohRC-9(59#L9a3Ig=V#N=9->g$o=;l%d&(a)b9#>)q&nhwOp#d9qp>Db&oJ@wzR zEmKlbULYs+DCX?>_|fRSpLAh=L2z8$!1`F}ThPkN-nFzC8ygRo$6OYc0X6I2S~Q50 zq|Xu@WAym_-CRwr53gGs&mlKEI9Sorl6AXpaTlnQwhR(EJuskQOco&_iuM@_iMQ;I z$FtDT(-Zyvh!#d5$w3+M^z^jPz_O#7o^7$X$%r?Cx()Q>%k(rdv*aftMX0Q70GSP|eD`j8WCVtWv$JR8aHZB^-HVqlUCR4WNio{f z*9S}<#{e<5!~lEPVzWMq2O=9u&jEzewBGrVf`WpZo12+gF2eJ%-)<);0T*%gE_34q zXz0B-uqI+EWctcNDK_c6^QcN?wlB5d_Uc|W8H z;4)LfLCbgLpRAsWi(w2WPRU70K$&5Tj3f}SU?1F&2m~|qb$-4I%*)!1WxHc-ZOzQa z7I#ig`~t(JM@=5RpFbaryjEjq`?>L1*r-1s)PfTbMFMsZ8NOio^0UhcH60W}fuA#U6e%8vVuie2o+(qARoOjcWArTgdRPLKcW zmz;-!)Ng=z8I+sgOG}$QH`44qUR)A*@Wjdrf8%a6I?u5AnUjZyxCC>9D6 zgaQKLQhQ}??zOD={KW%X3vVA+*15)~yj9gcOGCTQ#YNsB*Vfi>2q!?~bHM2<2gDSe zjr;l=1xzonz6b=OrKQEm$%#N900YeJNXoCjX>^@O1K5hV_F7aK85;vz2v&6C zw3qSnSu3tDiS3&hL2YIv~a0gRCp(i$VL#zAx_9zUMbW-(ZtOzOTiF*%uq zdj5+eNAm8shbhXu#OTh>PC!3k;K7rLfUqznG))YY5dLQ&Lg_Y@ws016f~1De$K*NXY^_5A=C^ju<#rq7NKt zk3&4d!58>8c4CCurAH?>($dnZ4FxT#y@5rvvEk($%n-8)dZAkY_|EN9`|#6ZaiZJJ zigIKC?MoJ!KN_#ZY~qWHS2ibWxVgE(btIjqd#r1ArW-@)goTB@!1X;nm2iN!wss8& zhfEH?oa0X(sGwT%bLZHlT)#%or+Vz+Y^|*y=;@{8 zO_%&XkFS@Yj5QB2S0-1Xy0kRR{VpjrRo}_!ZNL~_NnVs+FTo~OJ0|Ff-W%>g!w7@J z$K=-w^5-^S_}llqdALZEwDaPTmaL}HQD6w)UZ<~MyFgwW1`I-9^yw0P2jf@AfLWLl zZ9oU--?NEgXP(EC+&Eu>`LAQMUEt!ygji}+ZZ16_5?7)v&8#|p-$=%~XL+x-R-8$% ze`3f0`;VT10r7j=1xvi<8X&{bgUSHG(kMx5>Z^=jJR+uPjQqGv}=%+B6o zq6Wyf61@VMf$)bd-jaDYlAeDU9tp-Gz)4GYHNYVlKDS*Ukp=8D4!_GiI~@G)q$CtN mid_|uIQiLA29UU8S_$R7q5FUS(FT8CK=+jHW6IHHA^!t2WMA+A literal 4667 zcmZ8lcRbYb|No%4?2x4FNX7{j*_%{4b#^(CRmjLXr^^mW%HC&{5zaU(dzL-3GQ*jv zv&DVizTdxozxU&Dk9$AvbN9Z_y*nl5an^KX7OKA53UVqrskMx48Kkx{kEzaCjUVp*&VF!}7@U)ngA|F;%{DbP{TaDK8HnJIva_?>%8h1$1*zS; zch4Zr`n~?{=4Rh=XiH0rxEaCA$H!A*er>JG693@AgXH97#OwBX3Wzr_H#e6+AY^A} z3){N5{Amq8-`(B4yYVxe(zYjg8JiiT_5_KH*15cbHK@!4Z!9=jYaLMnD=RD33Mk~Qc{0= zQsk+rsY#37@|Znm@+yxh@;I8um^V;6lDqr+ceVcXbY8iXS37Ga+>sUDBpV-}L+j31 z21mNXGw`jB&d$|idA$TFL22oSa6Ar&BM?T0hS(t97+pt4Mhv&ZSZ~T-W`<$Qu{NBCprXaeMqCEq+Tw0j}Ae-WZ6Ie z_DQaxBO@cA+AN`gYPeruEiD-#k?{!$6p*W%Tj*3m069NIh1cs~>ni*3z(AsuwXVdz zAWJAqMEtcUO^e-03oP0ZoWqJsEupM8Zrn&pN@8GO$bOJpT`d=*dm2)}>|Ik-{5d%I zFtl_&jGU>huOAfPyi9sqT6iQqB6ZsQ|+7NG`ulPel!?q<7 z1%wnicaQ&G(#;61O!rua(l&R=`Az4(6ICrp8S+d6tiwgBo215R639yNgoOTdp?Rl-7RzYIl7+ z{JaD@!Apo)V^}~`w6n2M^)k!76uIH)Y3%Q*+LaZJT6PoIWE#m!VXIqLBqpqNZWeDC z)qtkI6Wpw*l+3%`aQ@VYI)9XN)uUFDr@K4DFpC4;c(T*<@|gOmk@>MwTf1{b{(A=p z+=^(V`}%Uw-k#T(HJ@vAT%1)W#hHTk;>Mny!u=&U4o=QORJ}Pb zb9xJ)m9nz3mDT)dI`-nRwT*07S67?f)GwbtEzQh0FZFOiDz2_2_4UefiP6z5Po>OE zO@RnRxX!0i;o;%F7|h$ZZ)3$w_zyJ} zNc(U&d~9q?SR_hEK~Yg!N(zF)*~P;mBhSN51^y5a6LT2OGwAQ{2b!ZUT4ZWwX4{*} z0KEwfO}O!V1h9mTmiB3Qbab>A8VwjH42n5DJ>A~^DLvg{AnP^|6rgs{>$0-4$;rtO zCLT(NTfwVuY6@N<%cMqJU+hr3je2EV?OQ(=8Q8I;EJ_f)q{ zY5o4<#e(S6)YQbpae!O>>sPK^k(a-y*giBg6n}RS6g$QQ8^qez^lfd;fh{5;!obMr z#fuly6))04Lqh?Ym+!=ionc@IVn%y=bICeGYL)2iXEHJ}1>DNY^{-z;xyZbtBJ9zD zI}C@%<3U$|obd%-1kzdOTQix9JzST8R31KL4KuI9m^^$~nx9W6o)a1wsl5z-krrJz zc7Gx6>cborSY}2B2R-$(iJkQcMFoXoIqcE)kA2b->)~-aLfCDwOZAD7kx?$v^zq}z z2!w@&#U`M!md43?`SK+wVn?iqh=`?Bg7Hv)Kfa*g?!9}CQ(wKSs;Y|2YgdTG(K371 zYUNP}LPf>yM8%7xf9jyUE-v`&Y(awaxBh;8VKze}qfFwbv{zx2T3TAf;AZ1GjJK7Q z)srWD&zn@W@Z-& zqV#?qWoRECRHbtxSO6tIfBJSO0xi2SJUr~=>TwtReaSXfvH+=iWM@9pLFmP?-f&XQ{tC``*M za|&qZ_w@AG*j1L$xw$#O1}XFwab{*FIr-9-7J2W_eDv; z{I(nHK$r6JR#M}WlEPo*aNFD2b@cWE8W|mY#VC>g%(s`9m-~uyu(0@>?_XP4T{S8) zXW+ZUh-Q8RFw@ke1~5G)egI;@1i^82WyL>>JD|&til(cpOD|1HJZW!jOnNIYkom)O z=H}_y>7w8ZS=@UWOlVk8Q(K$X@QrL`6<9yLXum!(a$sPWuM@BNdL4$q$-0)4J$?EVfQPS{?)P;4bft?xK%;Suhq%b_&`_DvPdOB78U!$46SSxN=i4Kt z6S}gpvRvld6wzBc@Mgp#0o;48c+B>&5olou^WS|8DDd^*uFlRoy1M?%CB|as&&TED z2wm?->FZPQ(ZgVN&!2zP%~n!U(tda8Y#eYuSQbKf@YDTI{dOH&;3lFT zQCDFDf`fz8(om+R-OXhvOyB(@uw#A|H49eAaiN; zkQH^6^ea0i8mXqs?P2Fct5E^2TB**uyKuql*V#O*l?NRSm?C;qtDJV2(|TPy8F-@UJ+ zLu{RH$ur3R@bM$?-3Us%a}OUqn%r6*1mXY^Y(FCN^Jif`zQ(RDhu&00;XdqP26Ge8 z1kiTYpV4-apRWiCZWGD#q+aFUnynxO0=EMxfsNzFGo<&)x|P&jn3tEApMSXgDGh>v z2t6MuaB+2&l9E!R82$a@d6Z5W-~!0+8A&YbQ4}O{kv_M7o6N&ORiy3fTZ<6h+T28Z zg)Nh*tX^-w*SXyOj_YuLDeVv$wng@nY(OU~c)NncK@^|~L^MvtoV@t{SlQCb3UF_G zYip{`ccQNkVQMN;gTkNJIXQQcEC80682usg6Aq`3LKRsEfD7b|7LE^FWSkt>@A-ps zBszYV@6BcI9rqh`S}Xc{RC(S9NeAe~QNgA8%)ZQ`*iLjyXQwDXe})g**mxAD9&%uE ziyFUfO)qrz?Aek;g5!p+-k0#v{zc4RC^^F_ zlq}~?D+ofilGi4rMqFEayHiwbEJi~^^AgF+jL03@+;oQFva=W7amgd((t3Xk4SjW6 z(nCpvH5_S!W2y&h7NnxznZPG1UFLtFuwXh`pP!#!TDl@*f&Tj|G%byXc9lp>cZ^Zs zE-ESc&_4gfS1CnL;_B7qeg%XC^Rah!IysWb1kM`X>Q1(>w-2pLUz@1-4W=QWfwQx- zLPA0SbtMM1zK4b*92Zu8>Az@PBH_nl;g99K|Ng2oXY~8c6zG4f4C)KU2r#4cSmH4l zOrY8^7yDZJrWbKB>JbO0qUucHHO{k?F}l`3aH*TSyBSO>n+`}lJ$hv$ z_W$<&NZWM57#X#W_Q5QYoRV^tjW$Kk_8JG6;dLLK_ggB89+hueaGjW#h$`0@YY7XZ zb#o&D9kvP;7Z;C-i7_-ZAMBo8vB-2lfk`YoxJvi~+av@5h~x6~yBoS!)b=KO22W^oh1ONMxThs3(Hf4Vu$MXS!B~wsF;zx!r>A8VF Pg`nG-dK!gl7XJSMoS8#V diff --git a/collects/redex/tests/bmps-macosx/metafunction-multi-arg.png b/collects/redex/tests/bmps-macosx/metafunction-multi-arg.png index 0ae325b3b04c5e9e410aae691ebec93a43c5526d..868a354eef66364b629f72442721695d584e44ab 100644 GIT binary patch literal 7455 zcmaJ`2RK##|3}J|b!|mf_9#ST6GHaR4n;$DE+K@QjO>{Z*?Y^*-kXeU8QIwx|F`e| z_dNgoKc0vCoO_(}8SnRN9e*{I2LxBIU&X+{AW)E((ZImKRD;j&5m@kBJcJ1af3BE4 zd?15ye({r3lOB$NK{KQvBc+Ab@9&Z8nQ;-DYU zmQf~tyZ*dEwrX7?SBsl0H@z8UtB!Y-3_CIf{pA5ciK}Ri75&59Y^>Ljbl&uJ3{(+T z^dU!Q+xzj|3a0P9{g@8^j3x+f{;ah5HPy9H<7|nK@Rl^6X%3)FOG~?Q<;o6;H@$JK zTc#FbnP`TD^je4B^#B=02Zuj6M6~oiw~W4N>FT19tINwgf`a*(nb+tpk?WOM_4^S} zdmOK@N=Qg>?e6af|5e|O^78Vc^Ei~^qWCC_ThWAVsf3x|mSn;4f(TuLE^wd-=q~#J_(1n*T~_Xoe+CeASnW;`j01 z@5hfHzk2n`-{0Tb+PX9Pwk2OI4PknIJ`uyv)KrgIp}v8EU3_(QbxaJEEO%&VsIs!M zf`Y<>U>f3pW_EUV)kJY^F+C$ABPFH4;^N}OL=!hR(KEsR(a~13!dE}Pk<-%lEZP%G z!xiw)#ZS9G1PA}xMopC4ux>UMJonO_+g%y_{P}ZPSs8-C7S|{(H5V#RbMkK|xV$+1t|nh)d`3`@HT3Q)@vWbyM$*&qU)zzY+qT>@2=-iv(?V@602kR597JS6g z&CSh6M@QK@x!>R1qfyb&Ad!CGIxptBn^9QU-_pXu$7jDX@D)~=3C*IL-Mcnc%*x98 zAd~0Tt&Kmu61p5OpFMl_@};ArqZSu-bf3Z*^_IA}xL!e7nQ@T?ZqzgW>$L7JVm*lx ziJv|NE)EQ6T=fl0NO1r2t2>-kb!23Of{e_^&#!|M?d$tExu|HMySuxk<%-P}Z0roz zT*igxd$Dz=>o&hfay2w}4honH}+RE(sIjg1X0S9hR~P)UFD z=8gF^5z_c>kCQ_?dHFW)%XkRy5P7DZj;N?8J*2-3JaT8}*xB#>TRT${)I&Ep|q0|Bi`?addVLXA5n&AiLV!)`nov(%0A5(-Y$7Pu1t< z=htEkwXK|tzHPE|bh5kaXg?u8^xD~(l7gbcg3swV<4wWX+B!#9f{1QuT0lTRVWFL+ zW%_YP19J(vs5b}QtG(@Q1r?Q+osFMWr>CcdpFVw3N>)=+R(5xHm-xGO=PSb_Z+b!+ zAyW&Bk{6@5!WhP2Q1P*`(7V2PlxbhTs%H+Bl<>~XU%OUWRn^+ka(s9= zvlHrPf!2PAY}%f0C6@jm;1znf(|OxPlr{=>h-x?L_$RD z0=CrqW;1X43d4<-AnNVB(7apzA<>lo?-!kI6dlx>aJbd`);2?UFo0Bs;HkDsJQHA*B}=7s;+ZX$ib`y%f<0 zW4!q8Bl7t8cRn+TzZOS#Pmgh-S#t!tCNfoSMG(gF1rO5(Q1|g;sr12T{QAHJh32ic zE>cnriD$d%CLTw!#lJ9Z=xqH%`;Nbs+WSZ+%QM;A*{O4Jad4RN#kwYNCAWG$%=j`w zZBv3pO-=oEaWLfi*QJY7BF;dDa0z1hmyLV2yB%5Qo9R z!I7N0fb4I#8gL}e4pZiC9sTv6m2GytT+t*COWbKul$1mtD(|?zHdbF>57_Vi`N?Hu z1vb0B1h=l1mgD)^X<6A_5s|8ynVI9`V}tTnzCJ!yBvK6%u+c7#mJmt*n-VZ-{(vY!t92 zOH%mf0x1z6H5nNh6bfZ-o|2uN?V*x~rRe!E&}U?Nmbay)<&I@fgvmG%&+6*x@v&>6 zUf|{KIGk$tdS*Xa!Q#cZ`1ozs4?%%}sT%CkZTbRe&WLd`^i3_UGeg7 z44}LnvB8Kfl|g}Z9TSU|N>zq2w6gN(9S#vv8d@eRJNrJu$i%w2g@uLPM-wvm9RK}$8B6NzTZvZ#Kt|fyUo#fMRmBT|uD&_0py@n> zczDzd4Y?=+v_Fy)6K^l~r;xI$xNSF6uB@z3-ZGR#5D*ex#rA&x9^o%jWYy0Yt5jyu z9tM;4@xd1(cuvhKFGOk)JIye z=PzHD6c+ji1{!{Ie5R>M+Me7#yn4?TjpNta+KPh*1otqCtAQ^_j?`Z!Kljhc(I32X z5Daq3YDLAx)Yq@?Z%)_2hEGmT!Y;Zj78LMsY3b;EtE_A{5xN0V!Gp}c)Rk~@)@wFd zBh!AYt1Ga&D9(J|QTQhyew)!gxBfTu+W*Ow z4XS%`a&m}d*he6a$B8xf@84%8!Hw>8KiXkV>{V4&Wi1bq;dWCZfm*(SkB?76LZYFe zk&~Ni4(*qcqW#-e=#!6+PenyVXvE>)zc@HJRh5;zv0ZQi3iHKi-VF&4!_2sVfX+0?ts;Jtg5uv(zRI5;?XdDRCgo^c|#Jo9+@`I$)kBgDxFOlLxA`vf>RIcIYt zZ(?E+VYp&rizdYzR@yg1-%U+gB##OJC*`0I~y}p)u zzOp~weO4W)%S0k8D|@=tNVN3|AKMuv$qElKtgvN>8hcr$#PY(*sxL=@6dM{ICt2-m z=?7Fjf+5DEMY8^q@Ov!|_me~3sLsw#cCwDZYj^mc_sanO^eNY#9lrqbj8p_EuA8IB z`=o;md(0jNqhj_y3Fn?gXTyNLq$M~3#?ZFrX4%4mjEwi~7OU20_)49a!T~`+K?5IL z+oIlyh+-@gZ_&|W>>}>Vb6?r@dULR0RO9Nj*bxcx0%RnoZXW;LyPpMZjA2sR+K~h2 zZa1!MYTf zw}-RtF{Kc~+ypH69;vB;pb>tv{}OD0k`n$=Q)zJo<^u2D5)!JYtvwsbHDF+1U{VH6ZtvjWyfJw+5;#P5u|?|t(3FLxC0ek!s7TIQ zI;H>lix<-cMxzJbuguKmGHw@I+t?%m?@aKj7Q;4v zyYjA~t-bvoYHMaFQxh7>dF=-=Ev?E_YDEQVqRiT+RkR!H-D^)m67X%bv{OHREU&H# zua;Q_HtjE^Iwp`A4{$ru)vm#r)>+Mk|LGdqNzrx3^RyK(yx_^R997rsEDTZ zTZz(cDsyQWmRP|mhki+Vv|!|sqU>i~@p^rHXh=);aUj^z?s!3GXXlSbk)QlmNItYw z?=PbMW;|QX2$uSP{V7fzc~VVHLbF+ES=roOzSZ*I}B%OtEi~N-?i@O?FEe@;6exL7etgf z2xeB+^rj}6YI%dgPDC>J^&29uD?kt&9x}1A61~WZQ+_pBvAx|&H!(IgJNRWBnR3jC zF0=(e00gbZ)}Ao(rm5u3vfP`hd6S%+Oh`xwUCS6MUz)2UG{F|^#mZ`AXb3VMzJ}#r zTU#?TH&;y%mQ5cdB_Tn0*PE)u=H?LIYHNH_$ZXyG&-WZajE}_Lu}o7*_~5RK>l6q4@nd4* ze4g%{jh%h0=m`K(_smR^#(i&kMn*;rO-*v&Li+G_*ixX_t+cYLCS4QvQq;DY8y|RQ zIB>39L3rzd=oXxIyD2C){C#CGoleM>o}1fxyyO`#FK^a}ikl_%Fz;E_6ur2($6%WB zVQWi&|Mu2wBZ9$8QVlfej?LmZ0)a@<$gHqgUtez=0lx@q@^^pToG%uU40AX+InmD6 znXREAWMyZ^WoVk;rWJD?`tifc+?*6#o8!trS{jSfORA`*rX~sK8w5kB{4V(Tn?8BQ zH6XtKF0_+g5AstLPV8mvR|8QEfk$vK;U|;RoyAUWgR-^hI+MaqILXPzb~svhR%+US zHMt5mP?eWg)9*=E35OH~oF1q(NMYO|#OUei0RZ?wVDeWhqz||nAY*wsLocJ|7BLkS zYN3rdQ_B@B(1QmLlGRX4JqbsDmi`=_7*)Lv)dN?27+rUAnPF&b%w=y?+v!_on~!~2 z=%EcW9UUE)o`J#bM@873{MXkT-r?krTi;viO^lYXiHM5QV2glCj2E=|Eb3AOF%B39 zFww^MxVZ4~A|oRqTiV$K`Gvi(uuxq_0AWNU*1HB6mn7o!@AUcp?rsw$2E#5|;>7FZ z`ec=}&9AQ5opN?C*v_V=Ny*6#KYtn-FO^Sw+~MVgys6S|{)%))cJ@Oyve%A|5z*0{ z30~^)TzUnjJ)iEu%?%)8DtglSdSeojk`q^Vn-?#BudJwF1R5!WD~i6*>yE-kE4XTJ zjJ%u8u2E4<*1Rdt$?2M&u7fr%DH)oabhEOuIy*UHnkTERt<|%&wXK)HRJ;;?piHD&CiHMrtvV`IZ*ZfRCL_K{A45Er*$6F>65XCb=o z;a*|ZS?-{3fl?xE=4^1omjUPo(^aFR=Y!eYg9_5qTYvmG1lrpPvz{nZj^kI@!w(#9 zs;^HCQXlJbi~H~kmnR$6$aqs%O-pSzwGgYJIx=n)Ea z2)Dj~?6{a1*n*Hm1w1@F*$F=Zy-?i6mrSP`GBvH93gJj;h$>LUVDA%jUS4R&PC;l^ zfK_GXpzv_gi+BrPB%}VnN=I?Y+AM1&mOBy>Cbf?=HSg!O_V@F0az1?3Yg2dn)XFMj zclYtZ(1GiJ$Hcs!E)el$P!RQq|ec zVxb!uHirsmAQqcz4p8)k$}+C=sL@ESs(J%aOZCT9o=_t!1~M`-kkW8Og@p}FO#Fq1 zT)%eh^5x5!=1l$#q+?@4YoYps_JE;q4Ww2i{yx1+Cbe#lN`w9VagS1il~_{L*#48M z1%*ER98ec7>|CsMI|}PvN>5M!`17u86t}@hf4?2Tw2zvmX1H6HIg=OwGprf((0#gh`~0d@g7&u&;lgFzen?1i<=;fqotv7 zeEnMP`6pxTA20V`lmF^T$krc(bnwTI3P|4E7fHvMk_KdTvA9JLK+@EzVXr* zl{7c|VH>Mar2b zU=LBA5%li^1Mx{o!$HbD($mW^s?sqQ&!P3Ex3{goa@h8zb>r-1?Wt!U?1`uCs* ze~gc-#PUJDW(B~sGtU8V^-=s7!NC7wgsT~#*>4rUrIrK24(5-ojYSX-NFl+PQQv)8 zZ;wJ%0ArbL7Vs)kbX0wU^zPs)GfPEr&?=SH4`YIdCMMIchVmQ`j4Lvc*fXns7JX)I z-E0qb)x;!GxPf2%Jm2$yoUdY?gstJXxRi70RaIlFAP-{f(hHnOSS)`WOLdE$`;XT zq)uE~W{e^e8Nu6EIoG?oyW1%rKGN4$`79c1i2JS~oB(@1T;iZ=z6J9d8y$6q z3}ykXlim*94-#gpI8UQ7)OdkMj*FZ7U~S9+@KX1=K&X+l@=&3gzyHe1=fW*AUFhEK zZe?n(2nYs?=Whx49(V*COvU5OeekEP#AqT z>1VvQv3F)!g}{i$W9`hghT3(a>D~@vaO3REItkIyV$rI}aYTZb&&Xh-2xy+Q1!KGk zxfx)>Pv_~#hzJ^CM+C#r^z>~cVj;T$6fS@RS)|)eJL`qVj=ptalz`Pg1O!0duv!Q* z0Jzq1uF3y)?IEL>*eTRABDtYK3L*(&V&GXwTA0GyqqrUoOiq3Z38AM57|k`%)zFYO zJBMI)8w-`G_5A6@;g_BXu91Y4bg_j^|2_5D>E>IL3fspJCFIwgeY5PP)$YEzcRjJN zpr8QCmkpA52%EwF$RdcbiD_sI0S_V~7S`6PK_`khZ-gu}AQ;)$GRn&jV71!Y+X3oL z-kz2Yw96oJ4a$RC=iT>)bwysU2{|sSNlSYRN0X=A-kioUCT~OQrpJG<(i9iPV8cAx z%DNz&_?=lyN!&Ix-H55I<6ZDy5uR?S)W#!-^{^KjUpx~R#TMNXrlO)^g0~r|sX)>Y z6w5t$kUcVMD};-S3$eyc_U(fMB0|E~4i2DO-~_z98O<{i@i?i_5TK-t)=XCck=oVK z0gjhLSlD%Fmx_pp2-01ED|1coqVL{a@`!BXe3aoMT%*&}-OUYcAuK#TH8s`PcwhVm zPZ%wTUeMlPBq%8<4Gbp0l8NeMS#bo(fj{l+=rH4<0utI>TN8EJNsZgT>0`|BubDXY zjX?RRLBR}T!c1p|J>3q~`;Y&1u9Xn`KWrxgWh(0Bc8Ck-w$k7-I}5I(Eni>X%F0ST zKTn(psKXnbXd(gvF_#^tT3hgTd?7^n=0{s#S>QESlRqgU%+fOymhVE?$n>BOwzk^3 zyMIaLe@$G>|`7J3?PXZfm z(4ySw>5Omi#}h#uN_0awA~x1vkOABo7CoJZmRtuqKP$`i;HUFq;~`9B1mkGS90v=` d_xtlp{r8NPFgnz2;EgASf~<;6p0ug=zX9z(g}nd( literal 8456 zcmb_?by$>J+wX%&HwYpiAW|aTDkUO0NQj6uBb)B-P!W)l4LF1dh_jKB?vxM^kw%d2 z5+p<#&ds~u?>*mpz7y9u*O@=O#%G>cvz~k1>sO0#&3j5@#0{wD`+DKjv~B& zPIwOf<>x8QLJ(F&Md7xN*Xy-ZU&H%KzZ*l(b928B4#SIkZkZ#8gL9j7%S!CM-h76T zgMoE~Y7sWyy~4vj^O`;1OFp%S*^bw8+v$b_hMv6QFIJ8XQ%*QPLd=aPx)sSD#_{v$ zB=KaOD@9J3Dwuuym}~KCs;|YugsaQXu_V_v`F!1{;cN-2&XTVa5)v%lDzJT=-P8{c zyA*-qEGaL4GhEb;Sg?ADr$|pf{r16Vw6~XvmUeJ>czA5=$ND-s5*8i3zPubB7M56g z6P|{Uf}$WNN1G?1qoZSRa8MQdrvlr^@G#2ZnnehT^OoOUVOrYcGb4sejil!#uIa0) zsumX)r@u~0s`B1mP|?c8i|ZIGwT{DLIW8=GO+92+6{4AQ*=KaD{b(+1+5P5t@B2%f zFHBDI87~zxA3S)_+S;m>ts|Z?K0aO-aO@+T^u<*0d1xpOGFonb%XNWND!ryAMKO~o zL>|=|PQ$gey}i1+Iy*CiAn?tdotjt*w`c`6Pu^aEiEt7(XBW(zPF*8bvgKDEh{U_78^#|*wWZB@4}C%@jvun zi27tI*w^2Wd+wZ+v@`{iq||W3N$ReYB3l7IacL5*B-k&;rnx`H*+%JkPnf|&~&OYfOTnO2}E(m;ULfmckkW}4-a<|c>1xu zy&Xa9#;e_TRt9g}xPb(bF^WsxytyKv-=Ob0`#Irywf*kz-}PRbZ*||wu`d1i@lKOl zk60Lqo0hj?lea; zvtTSMuHdBrSL<81Zt+?VTE3!j$TCF$qC zQfAj%xZ%1Wcbk{4`OC|!v;d#6C%@i{Nmz6x&(F?2R=zhL0SjwhD9R1JsKXQDVqlPR zC3JXXWPV`*ogyYC=I-vEpP&EX!-unq=6Xjovc`45wQJX|ImLA^65!!2Uu%^svp5&i zHd0xS` zo|lKhYG3M;>o=Wl3UOQ!T=Du7I;^bB9XdHUITnYW3cu=?fn(j^$cPG7`}p`+!v6ca zl;C?=p6>1+lkhXCFI~DsLvshK-C@40hnz(wFM$tULPE~a0t#%g-HS>} zN~>vV=}Pu0Djg95^?S#=lZ^1QLCWl$D?#p&VnwB;C^fai<*YQ)0eHSdO~&W)8I`V! z(c0Ne*Po&|8JU;{3g*_wYj%H5hPng>o^EUu>f*;Li;9Y}V>+?g+4}j$)o#|-*4M`F zX7+ym{8==_dGJ+2!lsuLE~Ax0SSy+{&e|)$9QpJlqoi%atG1@*7P*8)!1e37fFa8d z<=J9ir>170*s0wY`BHCr@{5X=*414OZBCW;EeBwcl%yXuFfbS$8v08+J3WXjDmn-1 zXKH2D-re2Zh@Z^py6|PB##2B%*xc|X4m}CoN|NZPB32vw?p=IBLU=2hf+FTlDEVDQ z#U`T)hjE|1jVnmw=g+GA7+l29-{0QeKC7hqQ}^-VF1!^p5!MiBN0`%+=KJWcUcLI< zkPoYUjXL~O>dPR(n=f%ti5*0viEgAvyYt)o3T&Gy5AlU|SaA~tMFy}`ge@(Cco=>G z0h40$@RAZ&7Z>43Ciz6#c0^PN4|7jN#e07q z{#0gnsX7|SzRxIb7t~MPB~IB!3ZI9=aCK*|m;qVr94zPseiQiT0o5|nLUC-2cfW0d+GW8V|4_PT&+S*`w1&pfQs#il2*}jY+sCNSS zDsumLd3)aoR{+-G5fD&HB`In8Le{v%QtRvMJ3BiI!1VU*+k3AiGpa}qPp%(O<`F$5 zl_Qz;uuf3Do7I1pP0P$|I_E(y)Vj-wsqZyBVT7}+SDI|#$wJo|1>L)MPe@2;ZEX#h z1)wHr-RH_*P{L~Z3bk!7sfQ0Aa&d80dT-5jEay|8U;OjyBq8#5Ua89`^0XsvLJpX} zG`XdiH8M0CyCNeaAGbxTJ0?)xCpufSQLKc+*n3TGnbRZJa0QpyPh{dLQS}$Cby;zH zS}To`71;cbcfKVhC6UnahDAk<*ZF$N%Qv|_Bo=c2#~mgyI7lMOLSA0p(lQHPkH}=% zSlf|O!Sx!^mha!ccXpE0yry85vVyJW=ot8GiR!{%6+U5HWWtC#N|1VWqRtndQSR|3 zJ8{U9C|6b#vxo#j<7V9weJle?cu1n~(7($CQcPsbzr?~= zG4NP!PENe)A1*E~?(SvU+3c~(2N&ZdG*B4=QHdV^t_--ei2sW)@OY_~a_fI51g5C( zgA8b{#wFl4s&1KfLJ&V06IRN`BkJ&Ho%5f~g;96Byu9@E5_5A` zzoy>8LCDC+GCz2NzWIOT{ezgCq1QqO&ekpO8qr06{`n_@;Njt2Am+GrixFv@ckz~* zsBGicFAY=0zGy|?OqJ1PPEeg+T-@DkV~Oi9N96wa;}0z@Ei{^KtkYBwa34VoDjbaJ zeBAHdBS%b|pOejgz$-Ax_kOb8M+ge<-#J}@t+(X@IXOB1X&}FGZCLa4Js@;YGVijo z8n!-P-{0R?#Zq^YrVZmDQp^+vQ#KQ|-g^0;0 zL|0c=?GY`SNn{JLE+rC7oSet>U&eHY+PD`UVC@Mn*V@A;0H9M~b;{6>ug82cE;$ z{!w~5t2CDW{ZO79#YEWV=I`J9e0*y^eq109fn8L6$izZ>CNR z4&r4cN2;2eo1;*q391}%9lpPRbhNj>fB#+*6tQkOaDPini~H&jRk(so8q4L&`GLaW z%w-leoOFqA5>}`_{r_Z8;q)5OCf0xOX3fIE4}HByk3K#y-I4njZB7&aOn&`;jzN@DMqaEa*rM4lD=|UOHbdFQ%Jr+`_`t>(%f)&7l;*ihc`kHH8$DsCAW z0p)q=d2|x&I4VUARn^bXVXsqC479Xjlap_b4<=dkJkxyE>k6WLkBT-{xzzvgH*j>) z_BW~?BL=fEP?Nk~*V)+QvD#4#`Svob7)5%C#10I8tlCvn6cE|b zkslDO?CE~D=H5zf0fK<`qNSznH>%+xcd>q!O+`uhGCsc4ZbXW(NziDA3nl`N!d z%gdXan@Pzl>Lh0^K^m@baIjh+A|i5;SC5jBvBr0I{n@kg$Dum9y5O%|ZE_^|(!V_> zoPFM5&dJX1=HUTA9bH46FUML~QW6mz{U*6uon+~3x%2Y#>uPHS0|PduZUd_L`W|K~ z#iS$sA@Wy3n{Nah?fn{bmQ5DQGy!87$Mu9hA@LdDg)6 z!m?z9M#gLHdl`5Zfaa*EsID$pg>@uoX=&-r8|KRN4t8p0X5$ABz?;Oy#X;2pR>BpE zi;9xQv`NjJoC@E)Yk@|HX=C(iuX0`F<>Lc&!>Oxz|9(G(>=7jk%jD?jbxOjS*;#Ng z7=ELJ!_^bncJpG`u!sBmj|>bnP|c(gK@$_k1O%ac2IZ9D3O}fS0Yd5(P7OXZ;h-dp zGiYv8+7^vYF!NK>l*P~0&HvsI*r1<(ve8Vj>~<3cbp-wE&s3Hv|4$Xa{I;lw3Sp%V zCzXAsie;7!I1(a33nzt=U+%lWOpt{7{oS?zU{f~w&r1#nb@;o|Qa2#Vd}pGm&JE~1 zm4fNnOmBvr^hxUft^YSI+$*;q{rdU_?&-Peni^}-WKHgtlMA5hV$;%0OiWlVUL-)c z`T0K-6nr~=S_P)v#wMqx##c{|KB84ScMu8sPYJ-wgaka~eNN5`5X$7_3r>>Yp+iDK zd`R{cB0<-o39=Q|Ut-2qG#j4ggeL zS=rLs3V3JK^;qnNm{?h5r5EHr(0o^}T!COfPyxKs0kE zK7~>t_JL$Y^Fwwv5gA!oMFj;h@xgQ`i<`z(WGcn6{>*&?wyqX5eDH1xHdgz;4Nfcw zc%`JIczM4J4$^)tv9+?IcTW}KjPr&}3xKN@A`_(;=HuU^jyMR2)XsU~BviNp?39Ut zfeSP=H1za|uU_fu>9wPa^!4=>tNuKV(czhQsnX8A;6Qx-oYgT1T)*Fwo$$EbzC?_W;FOQclVrL#>0y^PnStGEIN4Z-i5wR&dDCw4Y`q$$D zd^uK1(95RRq3O>ka5(C8QTB9sX^A_ogXj8n7HOY%?nDUkv;J^>YrgXl@6cfGL->i@ zT<<*2$y#p_4vs&}&F2IH_ao#pOaB4`PKh* z&+E|I!69HeoB-D z2QqqC7U^xg(bUw0B&)cjhL_^rR!h*RkZb9heuYnAx8Ej5ygp% zz|*Dk!!%{k7*|f(Rm>LUt;2cyKVK-sjZR)HLO( z<>%)|$EWZ1bD}Oq!m+%p49woe-`%65qo8?zS+#%utY7bU<4A&nh{)Q?YRX9x;=JUn z*jDt~a1rjCS5P2G@IYv<+-Rn6sB$wkWxa6Li60D!{x}!BvE40u`e6u7N=^=VAP+V2 zpZ}bYbuaY*48!);7Fb1Sw!%6D`JwW(ZPtFI81FNPgk~EtoUyU7!t~c6Bp2cFp^!3O z8_)vOoalREbiiT8#>RSH{=iKr&i?9C!x|6!k5BM6!l{rA*jVBc607A#A`L)wST#&e zZY~Z28I^oSVMT@K;qNs93T9Gb;ukS7ft#%txysk88X6kbFA6I82fM+i``e4QG9{O? zaeAyoNk}3XB^(BZh7=VQ0cH*B{k(tw7*WLvv$LB+%#(-v^vRR-shOE`sYlSRwa&Bn z2rCcIN@Fmt4{_^B@kM?^LS$)e?HKYaaEgVy_8A!&2Sx|bILQ@pQ&Xltf|=OpB1XS| zZ$Ud-Sa718ot&&398NCt+k=te=t>q->&Cfr=guq-9s;{hB zZ^1q-d}UQ1dQ{iDhAyIy1Ev(Z^qv1llxcqdmvo{b*d=>kM7pi6^)eh$5{KB7Rp;iC zIQV#bS5;Onm0z9(#2*?O^87i`s_n5p28MlkZOtDRA&yJq%?;P*t!V#^j|6FfC;LCG zZw9H02-<1xvN2@iNbL;Vhp8CySAbEvas_n421v~qs5z{8LEubQU7hrW!c#E;0RiqM ze!uKNbG}Zk+(8HhdQi`7XI7q!EIuWm5LG9Mw0MXFg;KDf|4MlIvJj$VX}%^wtNL7s z*M>~QHm(Z5>Q_}&4O;-2f%~$x1%+}Q3F@4WK6ny};)Ep0OyI_zpUiK^o4TzCqBrg^ zS)b1(;x}h&Zy&O2+4Vf~yBu+d%hnu3l|%%&AB<|Ax6Q&9SqOG;aDeLSsTCO2h)YT3 z4SJ{>8W};*DZ4*MBbh!pIe7|sWOtfuLuu(iTU%%|Bv!A1k0mC&9uJVe3GkAdfWb#LlC*Fe%pV%0AO0sn_OvrXz<4EHPdzac#Bj-%?(?9|AVKhK7c4 zAmV$p=Nzs80o3-m=j3uX>15{Tc^6Pl(5x$triO;Eb$E{3WKVFAAd*yJ`baR&AC(>r zPk?{}aoX56p8K!>?d|U^&1FACLhW8XDl1v+rj)NgBGl?|`zMZjfY- z@pN%XhSb#J_VYrg=_U#H;acw!hkFzh6t=djkYeMCb?f0GNS=P#N>d0)d3iaccWrG- zSnY&YuU4vmRf-Lu$2e_^0bSwY`?EA~5zsq@juZmMwUuRMJCmm;6^8sEc85us@SkcK z8b$`1r5s=lcE^CL3!RCI#^YC+BlG zcIudu_WccxTSrHSNybm_x&aJ~M$Z6&gekD4bwd(0B#UWmYC;2c0}()iQ3KN~dK`N4 z#oOB(+7^780vpu_`Mj)P5MOQ4mq+2l&`^R{<@gTs4J=iHDkO}{Z|_Dx#sC}z$24n+ ziS*!;0A1PH*(1M`SqRbtHjS28QUuGv0gR;g7JImY&q9(Vc&M$dEd+tX0yy;0kUjnd zFehwWs6OG|I|W*xw)@T7*Yv1p%7MB(_2)ETZVilsG#61EP9xy zhl3Or7KVj|IXOG`<`a1kk=hjEs1Jd>URYRIA1-PJx%%zfMc)EuDykxME3p-G!_gLr z-y{(NBx6+Nf`#IOh&UW`?OuZcA?uk6)OZZJ4|7bGcJ|k=U(*5(tU=!TePLq3CHP27 z+zNquyz0E(C0J?DjR72hL3M$rGVzCphto`mI*84lo|i!Gs#u#cpXEO2c&roVO%i@{ zb2Hp3R(l1U3vRzu z)I{+d)GDy+U0q8oo`Vor{Z?ShVM7N;We|Rgg|xvTjz|)!dAr*jSCFzx&6IFf{80p; z)7HLUxWX1R`*>Func79d^XMWyi3T~=_qn|@krFbNs@B;}==ti*tB=KcATnfUS6KZ6ACcRRD$2}!4C&vACmcV0@m|T! zNW%}c&(hAoCXq4+RQ-Iftzi$xF6Yx5=U@*YtKIybcibh z-|D+wwdfWBOaF1=)EXQ5{JBk(rp+5g5)u*(jqaB(DSwQQ>X~@bYX~WqByyfPzKlJcILEeSQ7ox-#+e**dChv5?~}{ro9=Eg{e)lD7YJ zFZt(WgQKnOEmw9L#edIsKSfzw zp(H$O8qqlb@&>o%zPR^;>~FmplsH&fS+8BQh9nSzX5#A0mUDdzFsOK$m$mdFi5Ypi zmvw(6MltaQxAAwU$g9Q-W(#oXe#Ad7)&6r5LxFjlt!h`lFkKMHmo52EZ?!)CeN~!Y zkxn2=&=sa$2?Ly$XM{Uhu15boj!zS0N31B~0gNIFhLFC~^Sa_G3{6AOs;0qD6O93a za;SlN0T1QCV3Q`1aXE!!Xgnx}BYj%*=}X_UnINDleSj zQ`v_<31~k1TY$p!UMr<&rrTzWgb2*#r`e}ZY9Im^78kE#6p^4AtU8->zRw$>2i2sZVxt0qKr~Mts~Z68Jn*%kAO?PYWY1iH zh0OY?raI{I>XX@&7Y72-%RW(8F+!%Ur}^sLT)OPwG$^StT<$EeRCzaY|BiF)a{R-7 zPNY$$7ApZ{_E#Ape^-sJ;98!ESHAT}3a)JNDt>Q*)IT2FF;r;=w9YTuc*9NR`B9{* zvR_t@&&$)iT1H*)&t$sz)>cbxcLUM`cP1ThIys}bV(W@si_140h$hho0yoGn+wrXKr6fY;AJwytj*ePeRYO&YE?K-J zxFXSLIXSt6gakVWhoF;{yxrYhLQ-yCo~ZeE_vL=@Y*PyVLsd&~D6hEPBQAXl3(g(< z&!1oO^TRvlbfD1O+}tb&>3Y`Bjg5_*L1+3lHUR-=XJ?IZadBw0j)zA@LITstaDIM1 z3WbV{y#5y|-xhqBc(^v2U0z;Q#rQw#*xA|T<>eJ1kcST+`uX|Az{khO8@<=f_8Qxz zonO3I+1$jv5}2Q#CnY1}iryTrt1K&f3*lg6Gplh)(aOm>pSQV-1ee8xR=zp+t25tN zU1h&OO z=KoZH@*YSHz_3fW)ZkSUm) zoP7TLIUEkx%K0?;463WkDd%B}D|xo(-D7<)4IIFd+qqiw%ge;by(=n`udmtKJz!l< z#aNerZ*Fd`sQ9ERyxPYwqt75s?s(Sc?c^i?h=M|z%M2c$oRBcw-%pPY(f6EdM++lr zma`q&)a0yo-}VU>rKL^$_@VsxF~z9rNE$E20_qRRXEzcc<4K5#JDIQc$gcLHj06+{ zj>M9BfRurFE%!@cA>0fRi;IhcgM(-1=dl_Q5fQjj3r=?Sr%)&@H8l{2)9Da8;0TPW ztE+P!!Mt#CA_fiNa4ly$JpqbAQ_X=u5)n2xHM<7{@{9!jbao- zOiu1NPFL~1h{(pu$}1nA7Vq`H%ggy085WNoT|7#LPC)d5p^C5-9Qe486wQg%z)BiV`Gza)tjB0o0|n{ogi5g z9U19mO-~hSb{Oh@vbTcAJ&P zYA2>0)yI!JtDSLoQ3VABfIXcWoSYf)@r(&t#(H{h&9~IKV$o={kw7Rt5P~J3@P*r2 zTX%MLstQvF1_owkX2LzH)yLu7d@fK>fsxb8mlNaT*TKEr-CEk(D0&egA;|H39FP=6 zMS>8>Z8?k0iH43Dci>rIl)TRd#BYxuwM7^%Qc+Q%Z!IYi(bUxB!MuC-ZlNcMj+QoE zDd^&ODWm1pT$nbW+5r%iJGXBa78MPIAeYj7psBK7A5^5K-ga`^t_}~d-8FX+wD47o_sN62WSucxoCufPB4pD!|X<|TUkjmYiU zb~JlWcQ+90o!wnEH8n8Gqi(#fkM=ls<@|6;$$Je3-0zCJ=d(G9ZmhTIh^nX%&(~RS zadmxO=aFMjpibA?I05J5ap7<;EG*>W=8iqZy{F^6I2dzFPfurvutg$|dQ&9I%gaMT zLJl{l4)^vj1qHsle`JV2fByX8;Na+#(V^pj+`4_+3+O9VRq26s)E8h^JzH#f-#lNeaofVjvy96U7q;7dn@MG5x zs0nl2yJg$q_ii8B&&Caz|AP03o|ZaSXIbH1+6@qW6)bulXehZjpI*^V`?ZUT@+j94 zb{PMNbGiikAuQbOgDY0@(1?@%5FWwPt4b=oT1gB7N(@NBfWSbYTT_+{`z`gQU0htO zkJTz2;B5%f_KmKB1^aNKH?1NfB7U4jqi>IdV7`0nwNvS-sXWVHw0J%NF6!;=1-y7; zz#(}poj}=$LQ8QNs`s2=D1Z*Ft8^|2dfRDMd~k3uR_m6Lk^*lIkgG?tmX2u!1e%cE zp{%68<`k#dP+#ACG)ui7$v6823WXL9+x+udcmG!waIA8Af{~JvLe#n%>n=YEGz?YM zhr{a}upD*fwA!NzId>omrrcJ{s+LQeot=-Bm48f6XZk&Lb1Q9XYKr3h68GuT?Ch+y zjSZ(_z!85QR81}9L^rZ*X`sBj^HdYWjYn*%oKT`$a4+L>!No zbhv@ii?x! zEdi@+@|?M3HfI+CoK)-S(*gb2lw8;`!x)2ewX~!pWPixey$jP;$YemtF2g_3F$A+Q z#B%j4rTatq83huw<~1(|2MvmI@0&FLs;R239xgNcZC&2bAP@TS^XI#8mXBdGB3GT+ zrB&m)*5L!G5fvjW*WIL^moHyxYG}m3F~gF>0v1j$BWldRD2Kk(hz}nOl%zIa!?rVH z%F2VeJhW+)r1ynpVPbCdYLzX*SvGdMjxO+rrFKPHTh(YlJc zhYMR}_&yx2O*T?*{eTtU1>}}v3I^yYR#rc^)Zh=xC=Jyd;_>+n2JbT? z?p2C>U`3Q^XeaN?Sl*_$K@=JlW@|>5ShPIvAg_INO$XDfMPFHEiB1<=X#2?zLY3v` z^WVEi-UKA6!o|@X;5wuoo`J?l06>BMy*vV*AEh)`fRN~SS5`(xMr!=_2|iPSGJJewFS7N&1K88#f0%Vo(A%fDxEQz!&@%ui z@k)(*`}@TO1p|1|tQ;CTx~cltMfLTcUEGoKtu>NM=kB^6OI5i4G1B2GKHh+KrSn1f_w9hW+q99by{BgK1xm zHDHAdMZb)=+AqU?Aa6<+%w`CSjEG;G-e0KX((C7^S*x5?DP8K$M}cj)c;%6S#~2Dm zNi8QuLAGvJK{hr8(_G%`w{G4a{kb~e@F>%=+F%Plun<3CBKgs;M0*Qf-5yG|sUUvO zz$3Bv!sRKcL0^sr<+ThZnrpR8Xjg0krJ^8l0V;+0{{0@4Xhmm$Y8)NO-d{4vMrmXu zbWTcT_ITPEwbIbg0Q{jhB0k=(NHjwV@VBI-m%V-1ch3mnuhW%TU#Dxb2G;A?CLD57 z-R zkA2u6qTez{uU0Brw*q=n?Wp%H5tGe<@}i=2FP`+*4e3|pW6kvS^$`e!si`RpMsdHc zm`y>s{>lNpsgIw)Yb1|=&P3{)X(Vuit{9k%3JNF*L;S`92{0iOrD6T7nM!M)q?nky zab1dMTWar=L11$j4CZz2jBaw?1FamGvnGhyYJam8M$m$O^!14-D4Y-GJXJ4kzeHHO zxkbCoyUUJ@jDX$(BgX61k%-^3rOhXWWo3HKbj-}mKy4WUN@myB*B2Imp)bcspn3x; zk^~5MO9u$#;^M;m?9$9;lT86Y?0@H(UnB!Go(vis5@3Ug5L}es-$84HKteY#A{gdD zRa)72V;KUEFvw-Br=4o6QzXazYdwkf8BE6+jsVGA1b9Qsr<`5`=+PyS2?|jqIFhyw Qyj1`_c?4B2QMC;I53l-2$N&HU literal 4418 zcmYLN2UJr_*9}OMA_zQCI-wJafK&kiBZMMg=*>`{1rY=R14yXSOGF5v8bu`nQlyH2 z6lnqJReCQ9C_S`)-do@L-(4%YE4gRRoSAdZ-g|D0sj(gtJr_L$0%6iez>(lS2|jn| zD8aXQ*z;=;$i?&eaBcIaS--NMnVJuswe>(L8|jS0)b%=Vgh6lihRgLavuj^cY^L#e zZE8qkUalpIhkNH2(y@EPX>&{Z7~fOqnp#sT>UgnQqglcPk(c<=Myb)`@3&9p)%N{s z{5QS#z5O>Qck54WzXyM>S+3vr+Ha~?p%aJ*$s!UZO09pct$iTq!WO*I7)(P-%0N>j z1D-3T?chq^mc6(4pGuD(WHR}ZdXARB)2$h8FE1|(i@(B~|6ICES+>5|+nXF0XJ}%Q z^y!nryk1d${=sY%zoew(C4PLHia_0+z5V@bDk>|^w<#f6+1WRtSQ*_VxeJI9k%-Zf3L1Cqr7h<5@}-Mc(dVb_~@|z{l|}q zPZQloK8h5GTB@OLDO($%YZ@813G>PkgR>rznaHoBLXcp*|J zlzV(&V4$n3u&nG)8$U)$LP8aD`UN4}+1-6Jr<+77C@450uNO~FOguq{#mlLxjtvZi zyO)=gc=`K_ainA`GFu2lurz_|)hmI8QfsNHQkOQo!d-TH>MW+pc>3`0a6dmkuvQxz z8(L<*tc(nuTrPh82Cvzs+2$x>(%<6uRNVPu)1d`sQXKw%e$XVGlnv6uO?d)wOD8r`~ORcK8C8LbQ4-FFgE6-*2a=O9m>Jo$1k7q_&u1PQ6HuLt8& zak%wO_;SLhPd?7h(2sqst`-@eVu%iA7VURv5WHg*{; z#ZEtzR=55ATJEzw{PTj}U%!S#Md{hwPrNn6ZA{h0RmQ=gpcHuPs7o%4*=(EAB7|8N zut;JS9=|piqFZ>tv9z*($FYE60h=Wy+tO($Io!NKX{NPZKrfL=EG5OxBCV! z+fH_SOG`^v7h_#wz|*JIwYB`${EUd^lwI5$m0c4P_5v*T>iHO`!j^L}d_UwhHBX1E zP<3agM@9~RROx;fqRYc}d=QWjdl}D1kNEib5~HIX*Pf=Nq%1Bj7FZSU?d-TdFyfoP zG4Od|)+tU^^FFvyUnn9GiA235J~@?F_A;Blex;HY8529+@Tc43goK222wUXc^{eDR zAK%+9u@Rk`XL|O)8r0Oty@VU%emp!p_SIgq^KD6&vlu(OGnGe*?B2&=cOkzJOuVAS zxZ&a9y1F_7fiUj3;9w$uPw&CXm1E7R;o-`^ySY5B=}hekhx+9`PwW^S9mNXiQJy=e zr>DovuX)_WARGN{uA`$vw*CMrAOMjtKp?~=CAoNbCTjgXU0oMuW*mcpg0!?C5nBhp z=V6wG`9($45W2`F<>{bLA3i+j$1kK=>ENs3<9=VX?nEVa4hIFMd@`*9RTS zUtt+Z`Hbm^1d+12ySu|+FcfOKzrTNH=LykV5{r2B!%KY5i;Vhr4t9h;m^AO|Xp?LIPgYnjh4EcKYyO3X?68J3|4@}VnNpP^Yb+V_q6D0Yin;A8I6yR3q)ipd8h^K zh(~O#4HYytHnKDg4_n&V*$Ka!n!2N>*9J;3Tl3j?Tifzdccwg^Q8foiv@dhjN268! zSotx>zx}75MP=If`R(<;HH=XR-knTEC018WtkK z#n!@Nad~;amD>{nk%Ym(QZq6#gjr*fl9G_b6Ao12?6GcrCD6adKgbaEn?itlYqX6EK@&dupuy~xeY4cGw7!5;3V zK|I3QM-R>%E~J>$A1-mbVgu0Vx9{I4B_^Kk{qO|5vAViSAKBE=At5GqHz-J5QgUsg z#)qZpN0sLhnGAIRc+ASm%6C0DXs#uu$gT?5mY0{4$pH&CuVd14a{eix3FRnkO%9l* z7rz_mOEiyFHzk^b5ZhfAbfXx-@2O#cl7u?b{Pbwup8;im5ed!ba}jTm)HF1Y#>*w7 zr9B$Ms2LO0H8tze+e=@+Y6UbLEjTe47aD%8%~Ag}+X;Z7u}QEeA&T~9oNq@pe@vvm z2)e}70rz=JsPs}OtfN`r<%X>9XHHR$V3ZLbmBEN%HW_QpIG(!T#A2|{iUelrnIDCj z!;?2KF_E$SF-3PLQwOOBPYflof9~mapW+}Pps8#9H$U3fc(3-qW#4ZKI@ofuva*81 zsrJrsyNq+16`aUYpz}a~sO1)13<=`Vf605Dyz-{6?{;i(9vmtGgOR$r;LoVLy*g6| zFS=sO6#1KVfNMH4Gc&*dG!WA91XKxQ@C~@GZq7CT4X{D&xc{7~D?b@a z*P>HUP*C=q>iQ{2P1$JYS?9YpD6wF8AO-w+{J+2ZK<9XR%34YSM7yC$$jQkuHZ&Z# z@^PutqQKIj+DlMX^>V&~3aPVmZhjsnDH#wLIMCl88yBbiaCByIks7kKyUTm|a$|zu z@^{`AaUnkT3MF51ZO`Y=pZBK%nMYRU=Y`nmA193Kc0N+E&*Uz9sO9Th5gvYyOoO_8 z`yxQ(ln&!u&4iz-N^)|yEi4qTTnVXF6|k(Vs=}qEz1FoyqYwWqk}M>LCTsnHssU{4 zCG>N&R7gpwvaF1C21fg4^Je!xsdw} zWq~e~NbRI%;7C51fB0GjQ3w>+SBZ4Ms4~FI_H-8j43Ix(l?)WT@{Wq@So-JM+Dtqi zj8j!p`!EC@iVc4NE2S5OID%`jGqv3%d~_D606NJ-$PLCLDf{|#dGE=X7M&Rq2{JAi z!$Gv<5w@ITH=>&bsv`L8#DAd_`^!sJ3`}FGVtxmH(!*q<1kn*sHE?luPPWYAAZqip zSj@3^wI%VlwYI+Q;re|6_n=P_$iyl_ll^H-JP%Ts zwPVrS{taLv|IIr#HkXB>w9?bl0imz`{ORgtL_^?{z%}>%m?$AV-3xkdchtrI;1 z*`P$qyQDD5)U}nqH^uej4@=xmOx}XuzvM+@4>KO#1O^u<1tO@asmI2~?xh%s25!_W zb8&IClV{c*=bL{3oc{awtz4q8q$_|9;=@=ImJP%R2`=@C3{u;B@0# zw}>Yur6FPV(F(E>&PMg3asR{?p3dUd7#0@R+uIAX`WT;(aPgYsdWTYgeZ_;n`V6Sn zl)kit{rc8;hA@71X6Pp*QgHQ(SJ^9b$%^vwG)z zCdXdpY!Qb7BKAHF8p)JO(Tp7HWxnDTD;rx(UHsP(S2<)w>hpFm0Agxty46U_Pe&C7lCZF_02Igw3d0-t?Ay>e zUnRcRy-s$~A9C$wa0YM1Ombc#grhF-QfBQdt{&pFlCUo^KYtGJmJ$L~ zASi*dvN8bbVJ8=wf>)v$~WNwmx0$wT_4CDnGu!1-PD~f)CvQD}z=hn!S&%W1Jju6+xC6 z+@RV-At{Qi+~;Sz4B4|nIXOASSYrS}zBCXi#SxA&3gI6J{WGstQ7?wrx(%6LRjui+ zy02YF7Bwxa?3@@@>^|rwsmfWR%zFMUr~hEMsRR@As)#OM`RoPbBpUzlW^Cl-rPb~% zr!!VZ^@4(ut)A*y8oR=UYY@V4@S8*&>$SHEt|rC)%o6na9Qd)!qJV# zhLCq;I~;pS3p#np3UdAFs@ta`0s12bRC%)~XTmRMXQxim0wOQupJz43$A(lM(ncO9 zh7VEWGNK&acSLJXMdYATuFK!DFI80P_zE&8DJflGW;U~;Dc!w#Y$$cr-bjk;i;>?y zkWhy?J5AtLu4a2vX(_&a>IM`CkeMbX%s1Uwta@HyRF?@cSLWQj1^Yp=fxhq-)AcAa zeSSg$9AIv49uXOd4hWcPz+jBslC4c98`J~$3bV5vJUpcL(hxAt6qPU<*%axs7k+tG z#dj8sOK+<)KU8n$c>i#iofVDr&2S})Awfc62-$^cYVk>5W>q2*Q5PS&KP)dT3ie_h5VYEx9~sa zMSpdcVDK3kvBwgZZ@MKH1{uf5|7R|UY{y@^Z%v3l1XT-;jPhb) zv`97z#gU#>lq5TSjlCv+5rZ=2JlIz3Yw5x^L=U}NR|5|(?+NJTZ_aXgqLklliWxxK mdC_<&-Popp_?^PuGm6q#uSD2L1q!?yf#}~fhJVy?4EsN}vZG@F diff --git a/collects/redex/tests/bmps-macosx/metafunction.png b/collects/redex/tests/bmps-macosx/metafunction.png index 5eb6cdbeffbaa9e4488ac3e2e9f6afd316a1eb7a..62fe00bbe5403d48287350733a61b7552db5a99d 100644 GIT binary patch literal 1026 zcmV+d1pWJoP)9t2>=*|nM@`e$Df{_{^gzd zlf1mV58@la0HCq4(Q37lNF=pdEf$OO^Ye#>hQ2-NzX=HdW@l&hdcEClmq;Wu8cn0o z?C$Pn81wS-vazvIQc@BK1h%%es;jFbk;tdcB{!|8Mm4h{|s3{a`mcs!nK_W%Zi z!I_3eqsb)&i$;jvEYyf`Wovnt8)! zv#qVIeJFNyb!oNQtSK0e$K&()Mx$|QX^F*Ry}rJ#uCDIv?DX{XWQcUT-Abj>YPALe z0Sv>qTy8R%^!a?Pt*s;y>AkbKxcKVo%HePr3{y z*uPvZXR%lxid9ur>CW^NKnR_lo=PMV0AMf}6bgmU=Z}w%6USrv`R{VMYHDg+E*C<` zXf&$TYU1Kxx7z_A{f>}GB-Boi&(AL|E_gg1oleiN*iB7M`}_NZwpy)k_1@lIHk-|6vp@Lhbh^jmd0+X| z$zU)-p-_h0Zy`P9uN_!kUf$5qklwt<;|YaA2q8jz^<79NlMfFM0)ZgwByx1#-rfd- w!EiX7N~H*q^~ryOJoNMb=l6t^-SWTY4^v##Zi*Q+@&Et;07*qoM6N<$f=;9EV*mgE literal 1076 zcmV-41k3x0P)P>2@D*ztLjxo%QW+?{&`F2Zy34004l);kdcE z;q&>4iHY!k0E(h_cXu+G3;-w;3W-E2DJfZ9T}6LGB9SySG|bP>i$o$UczJn2|7IK> z9_saa7K_!>(}M-0qoY470Vs;f<#L5WVYAs#6!rOh{r&v}0>R;MU<`>wf^9@F_{UIF zQ!_F$5*qv<5CGWU-*0bk&&kOF00cpLdwYpQ;>X9wzub)g0D!~c!h)Xy0sv)YWjdV> zkH;&ON}*5~7Z=yv-TkvN|3TmZU~+P@xw(04Y)mW`Qz(?Wy1Ko+z37km{r;7em9(@p ztJS);wpLJ3;B-18X(uNq0)b$0aS;G47E47%MU7c?Mx)UT3=G7$dXveN7J(=# zp%MrHP^r|Rp`pRSL5sz*zP_&4>lYRlwzs!MBGFeR5Co~Js#;!NR;$&Gjg3b~N1xJo zJf2)GKR7t3uC6XBDoRgJ|Ei$DV9;u{D=RB{z5eRzDn{q|`S}KeAuO4YkPwRma&vQI zFc_Meng|4fR4SE9rG0&U3FH?zFqup(EiIpN9v>g; z>+7ecriO=yA08gmYIStoAjo8LZfGWg3k}Bob9BReXGWEKV>SA0Kyhb%iCfva%*7CjL|c z;cz%yF1NF@b8c>q!C(Xefu*ITot>T5*4F5%TU%Rlxm>5yS*=zCLD+1z+wC@+&6Smv zcsxExOHNL9xm+_dGb)t|%S6(=UT;cDibA0P0GrLmVzG!sVl2)X3`R#sM_4i`DJhZ} zDFG;oo}HbE#bN-U)9GX~nakx44h{zAUgSJC8jXd8g+`+hMbXaAPNh?k}QkJ$zQx7+>t`pV<+ z!X6KMbw8!yaJW$0&(F^`o6X^Hc)eaM_@?8pC2;8PKbEg>et!P;_J$eo`FsG7mzPH( uk^cHpqTu%S*5z`Aie_YFq^73+pu{g!Al#8LLv$Jd0000%i|^_#VPVho74FZy&-h?1!pK z^2o*IS4Kl#Jc2MHD)O>=?(hGkJ~g>!IM&Rg^7Bw#MnvBY2{ z9bX(dE-&>pxGnYdU0-_d6-^Mp2$PUeP*6};kNWcEOL8(zGj$y?O!(^6{{H@WR(0bV z=bXmI#;mOQ&87=NRGKuZ@%8J0C|VJz^CK&xm6es4zOOsGyH-|K-}?Fj0s<`Nx)@Mz z)W)o6(UIn{F+&4`w|75OeEH(~@?~vxwY$5!o`J#LD?B_rnwpwSvAFnaYin`T)JbXw z`}^?uLV|)pSbP3K0;I}_UwwUj@q;RjBz`PJhAEbiUV;to${Ws+tZa&jjkV;Qjl?8H zX5%%b!otIuh;daDxxbW`-yjY1I{ce((CpZbg@!n8|5iYuE?zA6k55cId-klvyh%z# zBym70Ffg#`>|pX}dp;sO-1p+ljX%jmU%x~DQ$~ix!N$0V!!#x$;dNj)n5l58w7c{z z<=QQc_o7Zrw{NR$S>fX0(G0W{=;p~!_P+B+kncl7;yx!XK0asjU9YPgX3kdznZ3OJ z*$kv@PlU=daXqN)8yOK|V!CT)CM7LB)7~Cbn4OR?^1CC#yxtuRd3VR{Z_t%%M+7&8 zg!T(d8z*XBwdLhow{BHgv;<(`Q_zXK zeEt4?t0#dIW;y>kFFt-a7@snv-pSt1?)UHC5NPRAQx#9I@suwuJ$7)|gcB36=@%3d zQjnL&^(DamZv-euXD9Mugehhn|NHmgztP5V^JdQYXB(p96U7{znMR*G);OJ=op46Q z#l`yi`s<^`^EcnVd6QjO$jQUQKt;vI$;tVH@4b}INq_1cy98R1=cgN=2jqXkw5=^I zEuTKEu^lThN1cs){~ptAJ>BT@uRH!$iipF~=SkQ#N**&ha&mn=J$a_szHi?O^qy&G zM5mih;;b8ziTs{Mp#3t*aZPDT#}Uiem8Di%m~A_xASI z&>%G4TwHWL*tkF1sysV_pUa4bz{Jy~e2nkkzi(=4Z)y3Vu&{TT^nSJDTsrFfO0TxI z_LH->Tn{4QK~YiT3$CuNpFe#vvaPTp(!rFq@E@bo%+a}X=T31^QOJglOm}6aFkY~Zw)WugFb2L{Wh65$KkhmCH7nu} ziWcezvm9M?)jfPTE&cr(A++V?pRmZpkI?AAZ47cV|1 zB2Sx-;TiHV804W|nKfyH-Lq8yaJ%+gX*CE?Lo zO0QdY-iy6Z6f~m8wdLs&&7RwkyG)PU?Ck7JOs!pAx1^=h6SGrOr{>y1A(80m=Gz5)0WV#G9A-sgU3K-|{(i!nH}BrPd$p<{>*ys$NEOzD zRgrittX(03A}248mYTZQtiki=)b{`VYh@2sRU!tGVRd@&XAw|5!&1O#euoE_ohI7IY8;u>mdr+dSin=?%VH4(6S$fX$F=CT{{-G!pO zA|lHizlMgKf45&jniqQ$ZJ#}B7t9{)lXk0Vx*QiVcW#?hZ^5b@(b`ZK|7KcRWW~h9 znkUT&5%+%wT&HhEXugk(T*bQ_aR)Nlo!{NW@*3z&%kDA~XEdUTaJrkDn|pY8SX$00 zG5BPcmJ)F~aaRAJZZ$L0(HR;U!9rpZ60TEGAxPglJ~;@rnB3i+ol4k33X0AX<@!rMNX`N+Evxt=|^kGw3SxPBUax zC=ur{9VOxuuarP?|S*x^_lV|2z0IPd2M?{Yy?(p4X5&vt?+| z(8y#Pnb{)qMxqpNS#$Vl)a#4${l+fg&FVLC67???zb!Tryi;Gpyr^H>?er(ToLHtiQc)87YMy30n z04!2dQNj5+LS-OgkP;LTc^wwEy1F_?Hv8yq6v}a+tK;fh9Bdr7_jpxl68rl1+5H)Z zr>D+*WHMs^ii&=H6;$14$W!s-$H^+jt;#=X8F@sAD4CBG^ThzqKw8l2%#rAR{GuW( zvHL}5=!oa^A=ZWShsqokGXp}|m@Te5S1Vi*x zO4rk8_Ri*Lha(2M4x4{}50Amx8oUlG?Z$UzTLM3R{8-v_E`IStK^8kKE;Y5mW`N$! z?GUcn*w`?wd%38XhJo~@2wN?$er-JW?LhGqEfifO_FTaXC@pn>&`K7vRZ~-ABfAHY zx3@Z+q{jL~1Zkd{GBq$5?eFIn6eL5ohBc+3y!-z9Q-%0Z3p}>Aw#LN7Tv=P=HgBXm zX~x9DD!;O&^oV`*wZ)WwtcHzs>%@>hsl^a&UPg5U*z z@;=_VN-K;YgxAF}Q8$TkSJv!H&`k=SKIa#p8Ze&UY&5wqOM>uf=;EKZi;&C3D~c5?l2YYtW1a~eLTeihdDV*+N?s3my@swT@2;3I>rv9G8rqCw67pTb-dwZYN zp_}C73HFnfaIRbe0>j&)+v_81H-?*G{xkS4;z11|Xa^Jiw#FnJ~tsYYTe8TUwj#lG2K3d9Vcd)IlQ~#7%@X=W7d@R6{HQwW<(Bicn zyXt}unLQ|u>z~XOJUr}OUDfr49^k7U*$6rDhbg~FOi0PdL#=N!W5=s7P#w)3>@U5f zv1Lw`lzi6H6X1f=ph`wg4*YJmaERB@#YIh3RoB4a@xFM$ll;$uDedfi1_KIw_)Z_(2Opi%%^F{yEW1hrFF zcX&Yh!o<|{Dl$tp>qqgJmol|yXw!Knv z=EBpX&F#iarvmDeSFaQg!*$oI)nmCioCj%lT)Ek|>yF-ii?v)yXki%jMMG@dE|!lH zRHZCiD1Ga`T(lws)k?n#$2L^@pIy>POq?;U5p<7mAjjtI$$W`Ni`Y&k{u`0yX-5EhsRrxyjt@ z++n7_Ftl-ml<}3_HDG$5t-{N%#LgFKKl@mrH{v2B7-|=!*;Jf*egDVXZpCY4=Pz+B zF0ljh_d}_}pD9!Iipqk{U(8k?Tw-p?Ibg8HA1AtXmq}H3c6IR>SFG^x1ocTE&Hm}W zMs@-YbGKhsIrV$~<*CX~#)|xqRUp=Wd|d}|w%a|Bo}u8WoTCiG%gigt>2gw#3z66i z*efi~E%|0|wh$Z={xKwcE#{#~gDPfTX;V{UeSK9`;>bE?X3odX0*8|Qp~^&*-{XW& zwaL0+SA6z-^%ZioF1R?tTaO&0``F@?*r(~wFjB_C%9e=@YpjpUZa)>Z!gxBfC`yXc z)XUdJtj*HN;v#+)%HX@Qx*B^RbF{rSQV3kLT+kHQug>KlrJ=dUNPO=+H!BNcj$%ri z#ofc>Y^#l^2rEoBZ}{x=)Y#aVWqft38U#s>YNGt~?WIiR_KptVhpQ_q%Abbk=KlWu zyRcC4Y=ncHoSZ~BqPT`mHm0nsjGWUz*^3eV1~apjg9GaP)MHSXbDE7bKs6e(B}@6o z$OufK{3by)=$a$}o9EN@HP+p6y@@<-FJID2dAs+&7Zar65*2lC4Z5Poq5sp7D)ZS3 zsG?7wK5dg0GLdE2h5%+E#lG4-vU0$Z7rM)96nxC7CowzVn=QhySNAQ=N zjI7;8g2`_8{Olj-CbE;rErktjmY_H~`T(Wam5tNH*t+a&78VxFWDsP&Q6=xyRaE%+ z`0iIdHGcxG+xIR`etuH3H>RehnrRYO@bTjl64cez zfqe)6a}H_K($T5)KIXR#+99bN9~{(%!_m^x($jO9ZAL?6Y;6l;2e;0oYxw)dL^SS5 zC)`ul&{%TeB@a_VP;_*3l`kx;+P1l9{8ZvuySuxEL@pkUl;r38-4f*D`UCVO-Frs` zcHPtSq%TRpQUg7oUhteG&k87adPoSiEhY0)T~pJkkrCIOh3?(ufzT#lVd0%Cp?nhU zR0;u!*gJ}BJ^)>#{iHC-duD?p&3zN|nTg3sOaB&&y~D$- zR+xOLS;NDr)Wqy3<}*Q=Sy^qpz4%k0o&qt}H#QbH`f8~uDaXEl_j{fOGMJMy;zg-t zl^8ECF$2SEM%+{lCF1PL%9m{+R|DwZHNWBu$DCavVccgU1<@@lE4#hD?Wn7(dySA_ zf8y~qY>8G&K|#S^^&auIOI4OtHIN{{vE9AAM1+MaD=QV{GBW1IBnX)I!uH9c6llLYb^H8_iAqEfLow`@=gR)?-cf-T1$qq? zXUCbl*F_2AH`T%l9y=o+8yQ~kU60cvCpczT*Zq~q1+EfVynUY3fPmKZu~LQe^vs1C zx6SF z__l+|Vp#I0&=Cu3>vo&e95RwI#{2sN7Q8^8N=)lQ7{7wR%+*N6TPFhMAkD(g#zrUR z9Hfz_Bro6hUhJA|OixdbdWtY#Qs3yPftXlLTwEO3G3fqfR$bA{1L@M9d#`l;c5CZ= z{vE6i=UuyY&D6x?p_SDgadD_ac6N54x`2~d+u4B-iAzWja{K#>St*(k7hXTIvT9rB zkaFM3K*IrTP``kIjy^Oz99l0X^-2~G{a>IYfCbQE+<=9J1zPI1$S5c>2gq$~Y^0^7#Z%9Jci`_45E2rut*=v3 zQXU>0vb zO&aEMv}I|wiyldZ1j-`_JZp~Q5gJyzWjVz!Z(m5pvww$jHg_>)-NnqpM=`l`W$_3T zQMFPRr@H`h@VT!Uq|IVt(7Cy}H8eCh4T?a-*@G7Us9zX^3MHE*llk{CKfmnrXAIPX zM3|DQswx28w`Zo)Uu+G1eWjAruz!(?IvN*YskIVczi$8NQO?JY_p%1T4GWKmkd&0H zS&F8bV+72qtE(G7eW}Q=tdVd9XE|yHq~00#YLzYSgr%C%@boIg@%BD5aws6$GaZ8OMfP- zO7rrTBX}A`Uv5y5z2kp$Pgxl^N-;2HAWiaxlas6)>g>c-S@|n3{qw`WQ*!1ZXb21G zm43qie3CMc<0!`%C^)beL4kBPeqHc{9vF|JqaYxsn^4jcXii2&O6YkbD3(BL0sq(7 zQUt2Tpk{r1d>kAcG&PC5-=ZTlG&BaKW8EIKk1WA9}amX^R}G9<=%#=avz~@#RZ{rOpISLj+M&RNOMx7hW1j-<+R+0W$Bk^f?uUxVSii;0Ca; zvO?tsns>MR^z;6>7x};DiJY9Ax%mvZD65UUgaib3c8cGIrTp(OxCgM7OYwQzT{q_>(+Ke^m_B z73K=?0LI==FzHOzSvpAW`IT>VN^QiTtFaFE^l*raPjqy2!1LSM=D|sfyIw~|h41EJ zVUbZ)CGz0r7&-5wM~|SStYoFgFrM!8@<4D$hlR0oajC1R$(!Hnbj}=RxOFYWe3F_4A=dj?AcY(gO7(7)Z;ceJzY{%1g_@o#v51b+*;zzt&A6~!hqi$93JAw zxzZboDXXZIgYC!5yLEWD`S))~0uWU2i<9{u^#B-WqzKdMak&1O_yTd9o0}U-#1P_7 zRAo2re6shHtqk(q&kr$*j)=e~ARsG?g(3qk=;^7qh=>R?a~7CZpT9|Y9c(~s%Zj|F z6GLZy2-wrr-kuTKd~H>1>>fikixm*c*w|Qb#|4Fj&%xfE)dYc*CgI@>hOD=DeOlV| z2f0vU%nyT45WlffbAco^TibOwtIOC33ky3rIr(?EsYJZc?2my@aa)EM${#1k!W7s7sRE8Uot*&G5hkX9 z3+;IhoTQ{AM*(s1WEsYas;VaMV^U;mZ&lX_&JC`tVIXOed#N_?^ z_a-P5%F|O^?*$mmH8nLQCC|arjqm<3H1zwwS>*2kk1#?()>WGk{%QE|!C!_^!ea+h zHfCePjw$w)u=D=f2rO+&dab;S)t&{cGOBcP1e_HJYTzF)Uc3Mv48@FJKmbe%E-p}0 zfVxj+!vIvk`p$}Y02cj2FmH^#6baopIKSV6R&b}A3uG{ej(Rc+jGCEP%erI zcW88!_13Mf+U93a8H@PhAOP?0GPZU^sIlsrnN7E}+yGmdle4$2El@E_()&nDR<>n) zJV~Bub!`o<&8pjahWR|xDXiwx%RdwO`T1L0TVT#fdL3l!2e353=ip#tL#@I29Jai$ zK#YqiARqv;7^Kbj?^>{KL`GG$7wRc6?!hlTtgNhqgM%x0qrZNcK>vrCyt=yD8t~`Q zBWOaoy0`>|ga8kMRuO^##e(s@#6zgHhABB-ztG^%&+_@dQ+050ktGl2JzvSp?kxYJwdwVE95Nwbq&^$2u@+<*%rtP}Se=JTUZMLDlsv+G ze3mISP#Ehx_n)0BMY$#bw|PEMp#t;2e;@p@vC+}ibdZOT5QT3yRDxn#Zm-)nP!x14xP2BQ~!K!aB}hiXv~cb z*uF>uoq``=2$h?m)i*aa`nW?_-8VK)PD=7QUQB%Q2_x0pl;Z&7_SkA7;@)T=CoI&N;3f#~!1 zmxVr$v-1w5Dv++wa}M{oO@Dt-QK0EE%*%NDn&>w$(ObsGMA+G%0*{1HAj8WkD|0;A zTUBGdwzQ9hRM*w@_Vi4Qj|Yc@pd-E~t9f9*IW(P7AiP$c(7cHR2m`?cU?sr}C3=i3^wjEkp>vzz48K$+oiSxCEo z{h~WlX=a&`p&@CJwh(pj4qN2WR8>t8vNbR^rU_uId-=z>)`dOzE_G-8$C?_k+qVgj zGT>Q2>ntn$*sC85!GT*?cvdts&_v~e1cp9n5h85pu1fjKJzPw2eoTA$@)x1YJd}9l)jXr4qeH7Mz}%e#`>&)mnXt*1I%5YqZT#dD&&xHo)(gFOg>VRQMv0B-;> z+DU}DMXP&mhUVrjfdC05tY&}gn1JuE)p7!8J62+P=lL&DDCa-~F%am$fmF7L=>!r0 zBw9UH+!eH4kvUHY!5I&FcIA`bfp>peoVkckH8;;LbjMRuQ=gxo16+bo*^*9##t3#G z^lQc7W5Hr@_*D(22zAKD!btLymWrO^(&sh`aQpc9IA{RVOmYee!1BnCr&Tk)7`L^J z6S*E>>-QH54btyFi9BQCJA&)w@-5Cl*AGKM7qE%W%gakinS_e5xUfJ&OFQ=$#H|QG zqJThP3Zy%48A<7=C>JiX_%o8qegEGJ3oc;8-+*W#FEUqDWW9_ysdG3rN^X;Pf=@|p z_n2s+I%&Mk4Gk$NE|*9n|L^+|v6#osLbcQUQExNOom$*OxE>STUoq<@3m9KPKz@v7 zAe(7vdo6fD?tT{~fbs;q3AR#>0pNJ<-o1M(*Sw(1z18yHVt7XN(~^?z>*-lPe5hk& zWMpE}r>X|q0E`!MnwOU_;U09hzkd6spbwm!o0Aj&+7hS~8ft3UgxzQA6&8kzcZ;7> z3L8lWFn%|(dH%elw6w`}-C$w!=gF4%tLW&r@$mwJf_mE8mjrC)r^gr8yS!&nK2(L1 z(2t*-oV=x;+-^KRGh?o&mz|&g#L}|G*xcCoUXBj1i0YC-kW!GeRb^!s0!rJ@)b%Wk z7k^@2oP=C<`2ORz!yJ^OEEChy+|0}Zcy00cSh@P#9)KWNDtz1qjtLR`sN)#iauThyf7DmG$+{{p+U% zg@u9Jn~LJUN&E^;oGU6TLtuo4s)}q#lsI>58ySh(PY4#+ylDqozU8p-|0w$9sw5ss zE;Z|p{{I(5qeOq*dpvLZ@- literal 9314 zcmZX4Wmpw$wDu4J3ewUgt+Xhe(jh4&Eg(opN=lcAq|zml0s@K>(%sz+0@8v=OPs~~ zoj>RL=8|x;_w0F|S?jK~!_-vdZr-4{fgs3D1$k)=_?Zh|16Zi=9W^H63_<7+1!>90 z?y1{p9=e+CBn_B^5>0iT^woZfOmEZ{(Qc_X-pH?%x^*j)a|PwpdbVIeBV9|(<&4X9;<>e4%(oeDqwLSkx6?YatoHTvF3t%j@vc(c zL6?O0MQ#LZXlYs4*?lf5!f~iG%0@vl#JrPv%-Yrlvq;%>KV)SsEibzq{Wg63wCnvH zF)^{Qu&~3!!_tANsk`f@E32#Rt*uFkiMI1~)FditLQLx_JOTF+lhFdLd-v|OwzfWc z^vKT6uDG}uo0OBCi%TxJrluyIUGE_yp{b;djLcATvVh~y0o_1CJ6}%g3!lQdjE436ciLn6B{u@Ly$Xn?nI*YA-7SHT-6L3a`HPI9NUYF zrZzT8bohMsb0Q;X%`wD7h+mmy|LMsIyvyYDbm6B@-k0Y`aF#PwvwKMu_VZ)I!(RUm zw`Z%}SX5GV)zuq04o?qkC@E8H#*0x9qZ)S}n=y7VyE?BUPWt~2c6Q~4K}$=^O~=MO zQi31Hr*x>u$mnPkwJ-?{&Bf2waId4^t!-`0OiZHQrz3rR#r?ytTRi^$n*H%|b0AX+ z_U`25M5MLD{A+l)l9AEeN11SD)pT1cs|lUJPoF-8;?dT@I&E#Y;5T%t^PuZQ8k(Ad zcjexa-EQNo6MLC^^{ZwcZ1&5IV#8|L2#S|~e#(g54HXa;&Jc7CxvaIZ zvGH1Lx`s%&x|Y}1i>oG`o}R9BC&+6 z)ntEv|J2n%p&cX7NJ&X4nQQ;}?)U8Mp!&D|{*o_WzBDs4laUFosNh#k(yw^&{Q2|F z&dzHX7+oD5SYoI37pFGExsRygvgD#J&X49>N8z-CLqkJdU3Ucpj`vo&vt%Qle$nNB zG2?!?H97U&<|HF2CT8*HPeO9?lf!L&`WOM%E#13ur)MY5{QUfI`p3#rQcJ^ms(=3c z@%Q&H4bd;k%97I593CCLg{T=A*xK5%v#_vqtjR@C+``9iQ1AT9pWR{jDwqySLs!?z z-X0Gb7#m}bk=NGNUR+%45El> zKW2xPcPbLg%Uu-|6r7#Qe*E}Rc@ZZ_7Q|Ucd~u1+$HU|3qQfwZOBPEBP+#W#lJ&~4Cj#5Z!Xvd~B{93pC}8`w4E zeX*0E3AVSl5rmwa93v0~A%i-ALpoH;(C~bHnB`C<;_X}6NUA%7Dm)J_@3xCtn4Rr?`lV7lIxdchFf34)09Bl3PA%N}cc{;DD=C<15JxzRJ~OmP<wB>?S6h0vT`~X0veW>}hN~TAz=$*Go5?dLOw3SdY)o|Ypr9ZD0RaiK5JvniqewJ@ zm0*t7Ni(CP-wO*1^Yc5Pa?@yEQ#Wp}2(W(4H^Ao=^p{9{V59Bn`J=Axs;6Zr^e?eq zaJ5SkJXt|a?nFTx#9v8BAYsyk^M2w|4qk%U6%{%U8BPN5pPt62r@t^WYc}DoJNZSa zs@lIjT_Huy!o<{@CVX^p{*P+U{9aXAndZlLcOE_Jl`+^KHItH(l9onC7S2xoLU+ef zj&iSFx>aRd9kjISnLW#hUuC{XQ?iI>Ug#{Gc)7o=T}Lh>7$|eIH&pR0gO*GF~srh5N#9nK+YNs z(PbaY48m63`#TaB=S8;vnwFp3dJ{ohW#mNrF8|K6;3+97pdlox8G>=P932U*b6m)W ztU|Wsne~kjPeDCBbV=M|yrIznbmZHRRZ159w2%uAyy<@ag7Pxi^_sgRJ6tD74eE31{YH8V5w6FoiASH}+B z@f>Omjg2UrN$czD>a4^R5!z~M4nJG2BYvr=1}|Q4`b(64{TiE);O6FriPU%=ypi(j zZxw;H4xG~I#@{B?@m{5&_&c9cAHvqrJazd#W(KZSW-iOlZW$SI880^6q9wpW zcPV64^{>k>DB&HXZZ%q3qE-jhk$?pNO_{(_tI_N zdt7IJsV$jRyqquc4vi`b5J>vx=d6YIzujlsuXtNRcR6{P5no_!>BfJl zdE7i#@}5|Y?6!STR;Ulfw}EbXeVq__+wJ46uvujrOL4}|h>5BpReW!>#>2#2f9HP+ zeZso)14Bi{Eey&Ga-yq@Gt<+;qN1}SBk$!Iiw&ywpu-0asE`Kpdr8X7Uhu_$_4VcE z*w~mhMFa^YC2aI-IxHc(Uv~z^LEg{*s5o;#8W_J-;A- zVy}uB-M`k@ql$o{>#nt;;^Dk*qxhbcGrd0@3!9CA#;Rvq*4&(tP@v<_)6vsk%!jg5 zLc;GAZUnes9wl~kch`IWE6>lDpBQ|YnwkpIftZ+hq9Q|0Y)m&P*%8}$#JRvgN~*cL z+otu+EyQoMP>0L7j%tkb)~#CiKR=_yFIc&_e0LWl0rS7xjQ^;vZf?Aig7et+8I5~h;w=S=x(a<{=-HQ=<(OCC8d`wlPAE^+BI~*$tK1N;P z?1)556eXU)8~u}v0por-RXn4kvV^GIg1aK!^Rv!>KXv4%C|rh#SMZ78ocAx_dDSC+ z?)B>KvIChA>GM zVyQy>>?|XzC#HJ8EgEnx6|eGCS&V<7i*W&TI;q|`V)OgzYuAv$B*R&LF8vV|u`0B& zD*Wpzx_;zEnr(dZmKOYL)K}Be(9qJ@(0RK`L)5swv3_xU;caQj^6!x7^^dPND(XDO z@V?icVSmex)6$`?b*(DQlMBl(weR(m$>ej!?ZJ)L-{)MIQHb1TY4QoJ?7~biH4&k< zj$6VJIxZ&b@vmYfL=d4g&Zd#)4r{-E$A43$4*4jLAZsqCVMHto0gb!am6eIpUo?75 zSl*zgsT>^~*jZVTE&Bwo07-oL@+H=WR!W_b)1Xp<`Q3vD4=}5YO&tLpU0sd7SrKHk zuKWANty2cjnVOoWr>9GaMqk9l#sUMrpW%}Vla9exvt7WVk@*Ov_3>j9NS)7BU`GI~ zN(`&{ybibiuJ%`a|Gqs}`)}I5-tNT<-0RnQ?%&VW_|z2AjIWcj)E=d(q(nKO(~P-K z;Cr~G2a0?@T3CX&D;X40u|ZODa@S>ABL{O^M|X5&WMqZG`?xqqrHeo9v_JrBi%Gne zW5tHybXei7^fB_FjzU60EPZ;<`|zTzS=kBP50wqgVwV6FoPoSi zkmZ#XN(zdWeI`fxPppIi;WyD6v*h2B^XAso(YzQF@Yu`F%gc+6B}C{%M5rz_%PT6x zy$;#I4$8_hKX~x6FI8|?I(?BF^!sBiao!&|*^dar?pyXzQAA)^4j_JQZL;3pgB9L; za%=096~P&bIbcGZi&kG-Fi6xluo6zBXPciLYY1hN1Vd}Yc}>jyyYflgi@&Vyab z&C63wAxWvNb9&I=YI5iw$gD)V2aixg@c1bR8&+mSJ^)U@KKQyBl0*)exHf? zI(ihnBqJdj8rtRAUsa^x%`LXRbkXYP!_2pC-69Oz2S=u!B?~gyez7T7t@7*Fd;I+4 z6BA@KPFr&F3JQynjt`>wz+k{Lbc%HSiwSb_@-B~;qMrUs7FgS4>UV}#9YV#ft*wQ( z&v$Tg+B5b&52iU}Vm@3?QTtY2?&;yt=%lGhM5PN(MOERj88U!Zr~B9A#eL4!78caB zv|7F6JM1vf(Tf1_|LxR=^44u^Y{aqY-0*OG*sx=mo|N?5)D$I4URPI_jGX*>qOHGv z5qRLtO#g?O%E|Yy%f=)My)2Nv2>vIlr{~cgNexbsO}j`<^PgA$Tf!3Wo7@%7Iy&R+ zQM7`G3~L)3&z?Qovo&7kTgZAOtvtxB5BN{C{TKAA< zGP?8flV80lj!SI{BOijNyLm9RNemp-xT!ThYNX0M_km7??ML z2}wv~>F^(GX(ezO;}UV_}9ndAfk()0Wo+;M_^MjEX*gUcq0eqHzJr2VVg%srvDwt+n-gd3i`k2s9Yqg9qDF z-@6+cK4fOz=H+$XTkZtlki=)?>RQ>e9nH;M? z#;3F16nX#ATJ3Efg8B1-A@&PNIsEK`g0AuLiuoP+w;>MKBh*+0#wYA- zZ3&5pXvJQU5fhugc+qFV{ZLA3QEuxlKOdh89P;wJySocki<4!RV9!f?H2u<=njTV9 zQ&+N{!!3ritKpQK_u293>CpNSqm_pM)+Wo4J5(vaB7wQ1y7lZ&L9{PB{F3MYWh+peCt3B1QZl+#C{mpxG!#Oyh*1aAc#pyy0i5TSjKD1XkD6~pbz8Y$Bzg?MR|^K?;%DY z0WED59oE@h46%n_8l+aXmWa%Y08hYu(PPUuxp3U03b{myjBdskQ$D`O{yaaa3bKs| zLk3p}K&-6`Dk>_lR&o2VTAS4_`>#u@sPsY6{F{{(4Z^u3`1p$4O)!$|L@~bC5j`}+ zS1`QwC;3#2I99;^;UTW&{QlyWu^86=y0OonpRElI66xgDdCEym!v|E7(b?II_mT{B zb+MR2!}JBac8|Dd(X)vN3EfWpo35}|{{qZj z{N#HVC`w~vT9OcljRq5Lh<yGm)~|_lQTWy;$mY9 zfBo8hcfr5B{IE!`?C|%ja1a`$dB_f>P7NIvfJA)yh1-G(7Z=ydmj{rERg{+la4M$? zI1YZ4krHl_T~*$r;lGTp!U6Ee3Gd%ahz}GMv2XRvO4Q%Y8?^H9@K{@XO~7Ch znO29-VHwwfW#xrod$9r($xfp5iN)sM%9qsM{)g+60l|vQ7`7$#X?d#9WExP0L^Yd>~ z^2vKPG@}wI^Sq+R{9|r4+oe8n-c5l1si5HW_zwd+Kb+O@wyuP9nIdq(^XGS5M7cOP za)#GMT9cELKk$3V$zihNEMz!;_;9hZs|I&)HZ~UkG>u76{cT=Abvhnxg%fe(d3U`w zWIw+ewpS9-bl|5}q@Y8b8Lk2RH~cQ`w~57OqOA-0zkmNi)(pKx7{Mfp)A-X6*U{BA zSB+J7n7`p`7v^o(<6ZQuyR@lSPw)BkirXv{PqkFQ+s4jrMVUU5sWji|ZQy513S2n7 zWNH2$=o-)xjVoTBo*`Y%F;H-m4jfZPw(JFG2b<#$EyU6w3(?h0TyAR)O-v*^+|H$X z9gjgCe)rNkk=yj4s;a7iL8_Xism=;CJxB%EJs%&R`xG~|#P;--}m=I;vh?|A3t`L_ARO00JQ;xnA}j0)_ULmJds$ z=vxJ^ASVaz2COl+w!S;lsFI_xy|slPpzz*7;wtLps-lAX@6NSr*LW@aT-@AXIY;~Z zF3!%~ot-?qywxu^wG9oak%h6(`T$-1>7r$emh6a)jzMnR?e`4I)kLB3N+@-7bsg^S zH+VPj@bHxSK+rj$_q+b`yd)=wDS!?p76Ze>fo9X70YRt^@NpUbxbJmn+sH+mg&R@>?2OHr@GqKJsz_jfc?)6#T4KRH-z4&B>xf@Fmx9EMakgGWb3C@3i>_5FTF zS-CTl9mcW1%HR%NdGwl^S28l!s`cYbpGWf)I6=-`ri>uz;=Y_59ClByj-jzJ*S%#0 z)_3pTHS=)5fU2vn-BwMb8IFSV%WeWana)dI#&pwp81?2=)TpFTa8mJWhVdVG6| z4q1R=7#tk5TH8oXr9$;LF*k2n#O{5Uqm+;?^wJts74Ng2fuW&?o57C)-wt95BPLK~ zv$L}}7)vu%&LC-YAQ(J6^f}$XbC&ZD(&b=mQkXAAp1+4vaW&dakr*;{dP za)P-V{9(G>PHNQ?{`}_68ypNYNqm9tecjzllU^`)36s9};DMI5wyTRv5RcE|e#FB} zi6rOMzQ)pvwf&nvH#Q1Bd}ttGbq8w!yGeMq_a)zn_-S1`Wq~`i=X$nUV{*YQi1#_aS7{Tjz(Z$;N);HHtH3X z4GgG(L;;^#rc>v0PEn^AggQ^}FIXyU*3Mqp#nY}6+e0CVf4`at*SGH2d<;uR+JWlg z)t}CyDu#fi-PLf_XT2=+0=TNBi9HmXrI+%wXXayYuK+;+8tvz56jW5wxlNlO4PB56 zVDS!_R-H`9aX8+c44fSwA0Hh2QeCYN+oP$;%fmC+)wKcDs$XvFkBWxLr;3qJg#;heFfO&w^3u|~jEpEB zM)w6fs?1~M6<8ij!&FsNwAI!B?C(RmjdlI{Vv@9iwsw4{dHnnLiOI@ zXwmeew6t6WgmkF%#HMkllw%DMNO};IS6H#&U*Q-O;7s^?dpivV71q{on9F2&-S-rp z%}z}zW(__yGXq~pVANSOc}>7`t9z6ZWA2y9lD_l`wVYlCPGRQ>&%6na2 zh&KF9z*B08udk`RIs_OPK*AJ#{kjLUYNX#-jGaLL!s-7SDj%4G9;*I1TWQAp;*s75 zVuNFIb5mGYIK0r}i{HXY_oXC#Ut3aA5~$iZ>24}`L`LH5Zb@-*?(jNvGrm{%%zuyd z+=V=J79vuZzqCx-8vpNu;!evQP%fG3RFe1#{b9RjEA(`IXDa{_=J)gz6h6TX2c=zF z8ZG)Jf)Or1+;3tpVZPqi7szf6;}(64uAw1EvHIb)^m+qg=?QKBRj$j$zmt;)f=+$) zS%8m?e-qIBR=IXaMSM?4Z`KjqaE2j{4;E!n1`GEODmT#x+0CsjDw8F8zrs}7CXCJ1 zu<-D1!1&6|ai}ND{&W;RPE@j+Yl4YX0uFwn7r&wd=U2`d+)FQ_XvJU5)l5!IxX)BN zf?4s8gV8=jmq9B~??4d{IGBRB*-D849(!tUZ~ye^*Jr)S{`HE-frT}`=y+q7n}pa(Ff%ZeS#*=2 zO9Eo^+fAWwf)TT@u%H!jr^~dF6FBSUL8Z-eeQ}Jr8G2wq1i z^Ye$298n9q&eV7~1I$B{Lr~V!*Z0i6psFfK^g=9kxRKw@%S(7_swo&7atO9M>=pEI zH$mx!vy}kMP1rrin|?$^MWv)rrl}ZzdD;qC0jbwuE@%#*sEZQcb8N(qt^+=^0Lc;# z4h|N2KzKOz{=_wek(pWX@d{aOcW{?6r%9=gj7;mmzyPpGnJ)Xh@4Nt#-y)r3fBqvX54JQS4rN&Aulty#w*2>aSV8~)LR%{A0j%tvTH7TF&B^Y80 zbMyWG4hXkRT3$l_Iy-yQEnstP4N@BrYR&7@d8!$?%1ICD@Ijj#?C--wlJWGWiDQHz zdfs7MTU&fQNuok56~KuL`$sWq&svv@;Q6Kt7zzzcnbq36ZMtAw^n*>Oqi}( zVu{e59rri|OAGfJdyF|1;~hJ14+f_%c1ACAk@9s{E;r=s$*{g-?JCqM`PG*eP6Ofq z=1(6_y5Tb@rWbo19rB2TtZW!9u3c0XwwWEo|vcvLm!BVhx;x%wz7+< z4+;$mo@KK3QIlUGm9vRkTcqBVI}q^&r|>u7|Ne4lV*I8V9z^;7{)+c|TsXb{Y!jp3 q7~I9uonK^;*wzAs*8nh&X-jn`V(IdeL#{r(}*M&voC=^W1yReRcu}f&hBJaolFJaX1`Lkst`C(}`hNU|=9c-`d(@GMNDZ z0hA=0o0}{aYiDw=`o9!`e{TT*fM?I1vDxhE>S~H^wOWrJJ^JzE$DMj;Xz2U*?=_ptG_dzC;UAlBB zC@2V#BS($^fX!y(@p!Ydv!spB=a-a}2!%p6n~ezlht(HMCX>lz8X6i}TwMJ0=~H84 zBLD8*4y0NhV0OjT7)6>&$-n^-;t@WDP zXf)>L=0-`}gk;4i47U)d4_3K|y3>WO{mf zc6PSc)HiS5Jbn7KMxz-YA6Ki@0D$B8z`%gp?f&uOM^;wW#Kc5ZRTY!TRH;-b#Fq{L za=Bcm)7`ptOQ}@W)z#g(a|Zy>J|z-KUS6I`r5YL<+S!r*5u87NJ}4*%aSn%*o}LZ> z3^dkgG$kb^0MOOd6&Dxx`0--^7#$s*nwkQDvuDq;Sge$k6oEkCHFZr*O<7qP0N8A{ zzP>)ssn@Sx&&3>AR#u|QqJ>IJO95bY zb+xy*_g9wZuTZPi&!0c1h$@w;va-@o)X2z)R4N6stmNw=JUl!zGZS$P!{+DbDUmN; zydWRU;o)IK$Z|(VM}PV9#nV4AF%cgh&*gH_Fe4)amCu(xIXQXo;K9Mc!FTW80f60Z zcQ_nYs}bg-@kunFc{!*!F}oR@$nlQ z8~5(r3l9$m0K46;*Xtu9B5XF>ZnwH0G&ME7eEE_hUb%9msHn)RzrMa+rBb2WNf5-Y z%eq_S=jT^fS9f-HmX?+p3JA3oG*H0$f@6%`dLD=U{TU*6m5 z+uPfF3lxjRY&M%BCMPF*H9vj&l*i+Rg@w6XuFs!8&(F{Q_Od1*MNghQal73@p^*NcWeV(eds|x@0CaS8+_-TgCMJe{ET7Nk z^Z9g~dc9tuP>{bLgTb&^EI|AbxLhuS!LYfxNmKv&^{c^Pn46oUlUyVcy?XV^llX^B zCTnhP_9VX?bicCp2^Nbb5D1t|CQbdofdc}8;KYd&H1m&)j4UiH5Cnk;j^kc!PN&mk yGMUY0x7&@#ZVy5e0mQz)-u}l<{Gr?WU&BwBz^sqOJ4j^!0000kj2t=%eD#A?d`*f_di~j&D;O?>G%BJ=RD_}=bSy~oY4q^ zfarkZxL7O>R|tY|xm+9$hfb$c^ofZH48v$NTDTqv1pIzKo6V*~_IkZ^Iz1*PCd!dS z34$Pk!61XdSlF->cs!o}W<*2*v)L?@$uJC~=ytmu0B{_SsGH4ZivH}`Gm%I%J$^|^ z$(b`}q8SMV3WcJywDif7Cm9(ThJ|JC(+v4IzB$`bULG4E)Iv&+}zCP^XIbG zvqW)m@qq&e7z_p?%a<<)fU&VLnM^h`G(@_krKOdXmF?KEgU{z9LPY(ej0lUxVzF2{ zIy$UY>&VE+_3PIGfbMiU6$-`Mw{MGzijtF)bvm8hZZ9k>Oh`yjsZ?IC_wnP$H*el_ zxm^49?TZ+`Fz)|U30tL05Cc_s#dEvY}imzQev~&$X2gk zzs}0aN=;4G>2#q`h}5lCE9!mEo;@8M9Z1w_wM|V;<>lpKu~;sbx3{;?Jk_|kI7(3> zK^7lM6`Cz@9KU$+BAd+?2m}WY9(?oW4FJ$5CnpUC!;vFL6bgk(rK+i^NlQyxzkdCt zOPAigdw1o^m2KO$?b@}A&*z^waUx>eQ>RYt+_|&5y1J*Q=j_?D01yZS+S}WGK3^yl z%E`$w8jYtFet&C@8=%tfHc#rKRQR)2B#xI2;)n831tW)-AbQo|~I% zGMNBiXlO{I(M(KCT)ldAYHCWQQq3n33xd47yd_JPAkOFWv$C=P;7^6FuC6XCD+7Q> zj~)qy!n(RT05BK~{r&wHE?kgEBwxOKDJUq27+0s$9X@;*0LI3~T3cJgKfQeUa&T}E z$8nKJq|s;`4#(i&AOO_W)up7Qyn6Kt0F+84hr>bs_4V~E7VG)*=QJ8^@7}!w0|U2j z-`>7`I{;*6X6p5N0FX!|8#ivW*=&nZNxHkcl}aT=+`M@++IoLOS63HW;6K^ix^*ie zD^{%7y?Zy}91drAcsRV7+wIQJ&qutbrba520zi6tI#PH%-uLg{!~Km$V`5^WNF+jL zc6K((rqO6DEG$IgvSrKUayjBAlPNAP?(*f!$n^XDA3uIX9OV=M;^X51V03hJF|wJO zn%dUZMiG}TT{=S(o6Qyo1hTWUfy^e0#Uek?a8qG2nOnAOL7d!Bv9Ym;Os_<4w_6|( zkmjmYt7g`nPA5SSBO@coOiD`P@py=17#1FRo@dD45EBz4kw~KV4+ev^wY4{H+(72+ z?qVz!tD&KRG$}iAI)p;u{rmT)rl!!Pud}n0)Zf2 zRiOeuTLgo_Ikbw8k3V+o7)3<4uIadY_pVGPi;azSyWQWueH$JgUfgVo#bUi)uhD4E zpFjWe=g*3YipIu9062Q|Xm@vaQc@C^%U!#6ty--{{z|3NXf)>L=5o1QkH@3cYPDMJ z9Qyt7;|JPJjg5^bPo7LjNQkl_m&=`g3PnUqON&OMA=iw-VAyQ7sNO>Jgxl@z?d|pZ z{S+O?@lT&Vg+d{U?r=B^27}#h|7T={Lh<6oi*PbCii?ZU6Nn@Wi>Tg0^8}mCPESv# z93ucA5{Wi#+BE&_TDfv%W@hG^HEW^?-qqFh`Sa&cD1=BL5QymJa=9!P3y$MHpAV5a zOyr-S5sPy;{y#9A&A)#A0stnHIXO8A08*)R`mzCl&1OUY9*~|wp>Xx;)eAeG-zQ3j UeS4BrtN;K207*qoM6N<$f}Fz{*Z=?k diff --git a/collects/redex/tests/bmps-macosx/rdups-delimited.png b/collects/redex/tests/bmps-macosx/rdups-delimited.png index a24ee3c1b1aa00babb273681f0a3c4f129dbea8e..a82877598fab412b850bb351499aa94d7b280cfd 100644 GIT binary patch literal 4188 zcmX9?2RzjO|NjtKS2$&dB72;(A|a8zS7fj3nN{|lmCj67oNNh&oEfrbiELlVnb(mc z&i~!-|GCHG^Lan+K6mf;`}2CP*Cpxes$HUHrG_Brl7_m9Aq0`gfw2-LDL9kw3NwSt zMSCqZ73loms|fQJ1wnN58Y*{?u&i`}nrl_xkUQlinM1dfFwD5v>0QzBN4V78v%4$-B3hgr9Dk0E>MAOzsHl#KfA>frF`IT6Ep3pW zUvgrii???IabaPBNF?Ux=lkF%(OOTBcF7@08JRkp4q{gf1!vendVao@vU2yeYY$IWneXzIsJn)8E%uSyctj%g$F zc_-v-&BKpbqE;3*Ha3Qat1BxLb8~W=8cp~~a)%_N+{VU6wB~EM0L^@i_#X-@L{?Uq zgyl!?rOPx@Qc`4FeH?lx%umnZ zH9YCRZ#56Y!op4xjdDMK{;Zghn3$;lNUw_+X~D=JzZFeRW4rRT%4{fG%xv24AI)na=5oB`ruOfjpq4B7rJe%71R|Lxm16RJxW;@!?j znuKFDzB@O}wzRY$b5jQ#Ng?7XeoQ7%n-@~TRZq^(ryjwn<3vS8p~%5OP1dxZ%gbDJ zlqxsqpZBlff&tiecX#9B;w(kY?(t(V7`;M;-kCPAq{$A#zI9es7MqM0I|s*yrlzmk zXqwi3DrgyhOioT7s$e5_UC{UBU^7p~8!qVJ;861BjpS{^QpKXIIJ)yMv-J-BpbWh! zOe9cKQ&Vqm@4N8LNi_IDSy|bVk`h`D`R0Hv#>FiHZVj2c4em2HH)oUf$We?Se)*zq zY;0^~!~k^;4{P(HY97=p-(v^pjEag9W~^#&Z?CVXhsMXpp*(hI{Kt=>4LlzJ?I9~O zGcz08n$IoPHl&1v_k444i#9QJu9t<0>5-S$Wt&DUoKNFhwK+Z)zSnV1EPXb;Nn7qj z0xg5eL6LlV1-9q?$M_8$9i42Eht76(xWgHnA3uKdoN$H{qIBOjJP;NWs{@7n`}eN{ z^PgW6+>ny7aRwT_-WGyCJw3H}_^|j4$Oj2DIy&mzarS2s^VAOA(VkT>hH37tLaBxr{q{87zLX{?LkyC%Dn-n*D)!xZzeSIChsbx;({=Y*R4N6&3 z!d?8nveIpRFq1jHi!^UUT1x8X_wRFarY0r=(odg0?X|~Mnp8>l`}`bcIpx(5%Y1S0 zRdiIWoe-`2c53tSwYBZNJ*FfT<>K+FsfLOQ4gM>&)|e-i6xUtu@AyEtfKBA4Z^j>P; z+1!*(+W?T5n3$NUvpG6Ej3e)kWfs&oGs`Y4^!D~H%*wh*qj+|JDvo(&P-?iDEAfa2 zo>WX4d`iG^Mx5G}HyAON2AOnikEgqh5D3A_%E}KO@-ZGp?|h>cl&dt^v(9hibR)P+t8Czb@M<+8FeK$m3J5uF&d*_UG*oVR?IKPNGeX}#1LUs%||Vk@UI$3zo* z0(z6L=H})C#{u3=LPAm)ej-r)cEZIb?C|RVijPUe;^26raBsGOVh>OY>;Q#A84HdK z4w6El`&|^)*4BWlKpefiyjE6Lu%E}BoSeX$Yin!3Gk$#ZR($-6?uz7cZ&wHLWGhSL zq1RIToeC!F&(+)Hz_$!S=gWo0kn-~Kf&44m+tnTejz|UuhVzpxF{N5pF03%l!c(3n zuc*4(W2rrCDv-&UL@+K8dyv-C(-Tb2C9QMP7ZpYF03;8fpYKwcC>$yu#|&DN(Kl#{ z{T_~dmhlR9`7&U97c#eO!ZvB8an1;h!Gre_WDYp}q8Hw>qOP z1nn)RrKWE0?wW3>#uJI*{KyP-o_C0^+{{umjKb<#S~0XLDCsm(ry+;_XLmvgfTl(% zvj)HpSy)(roVQwj*>)&9tW8Tx1K5Nh1_l%k=L<#V<>md}h_-X}_TIx{Nt?N5Jw6O} z+;J8M)fZ-TU+Ip!DEmo?%g5I@O6(Rr^^3);Q3%%mKacyUa;3%#z-F|vMa7v@Fo<1U2HT&32yiogMAU@Rj7`A}5Gkz)L}aLF_UA=#}pWw+6HEzjt?Yn*$kYH2*dUw7I$IBbKjgrY&#m zTBMZUiWCx}smm1>62c!H*|Y`MGn$nfN>Fv^4m59RP=(@Fd%L^4tE+`6C=yOio{a46 zQ_7TrEZEW#veuUdyBITklgs&%;1$_D%n{Ilg1ETe_OQReiYyEa=;`Q+M$Z?5mTGEh zOgsb^n_ozBmDElrIKONo8j+}GbgEC?&Njf6$$%UpBC>il*e~vebLgO>NRe30Fc;pYFF~60HxZKuqplg8j}qeJ z|7_1*80vq{nSf;hEY{P})@EmBUd9DOk?u3K1M9zk{c?dK8yfsIHIpqx&)2hUTqG@k zKdpLFcSZWN#!%2QGBG(|8Ju;swPRyrL4>Ab*Wew1QBetqiOsCm7re^VwXn3}OO4^TuB?m#oyf$5!48bq#LV7!Qk&J1DpeBW&+>JO7(5R)X=)GukY2XSN&S%M@MVx>v5piU0q$k z5O#KUzyO$o&!BiWmpXdVe`Brj!p+)vp8VvgG~6AU4mbY7ic zv6+)@{EC{65vJstUU5OQKb1h6GZ{_7FM^}MzM;Vb8P#B+%*X@v}zfpcf8P5mG6{icdeh*`E@}V zjJY@H`f2k;n7u37w#9*vY|2 zo(xsyzkbHRAXc+CnuLHB)VFXxpQ>Z;T#+eZH%CH*Lv literal 4112 zcmW+(c|26_7rqpUu_e0*lO)-f>=_J^NlZe@k|IW9-}iluNw%^!B*_3QfO2x7dcr)>;DRAS(_Ivq9G*&LcR zA&7bSrnV;9Cu=p^-^iqWv|SNy8HWBsEB^hZ!g;B%&{#z&#}!6;hr8l*&qbXHglj`r z3N2Jpm%f`xa;tc~$1ge%j136OF`CZ7$dU_Ro;vGD@JJ*gX+kaM&Pmj)9kwekB-Xgn z37+i;IwFc6+T~W>-gD{6q2xqU3!eUi>#(DuqC$%eB6t(xL&KjbzOxFZ5F$0soIYJp zSQr@*PP;J8wc zN7@>dGx2%o+OTLcCn8PE%`;O|<)x&goQ6I)k5++muPP}i$;F96 zbR;~#ZkF)Wr7t_eo-;QyGm}&D;hf8L|NXUV;^K3gKDmK=BR$zF9hP(F+1X1iYh+YZ z4(rw%RlNS1d3*1d-miwAyXof#QqUB%*q2Wx2h>#@Z5zf4U96&V^FOifR3Z*Pxp zv+Y!~u(7?+^Y^v%-Me@5k>Y0MUn~#%**#WVw&>Jf2N|SG&_HtX@}6E^J+Bp+@1CRS zgu~%^2wU4XrX}pL+93PV($YWQ8g_Pe)&(56X=-X386_*Z^Ca#K-NzOd6m0mYVzKMX z%gY-Z8;y;PCHKmzs;g5JS?MDK)F-R#E$<%;jgHUK3~&z!+iD?1q%qv<2J+696! z-HMaH#}oqt0s|i<#Kgo%4Nnw@t>v%=Jj=TSd;k7@nz%VN^x1b? zL^@24$FLav#?8ber7=|xZd+jnh43mqGZK9XULz7MVzpnSpR8dbk%yDhd++Z^SJy3u zAictYZ{LuVS4T%jAtBHU5pcb7>Hy8WyJc&rL)SzR^{?}X)!&e^DEi@Ho z;wc?otHeSq;ZZwNB653Ux^-q|W^T^T%4!mn;ckhkyqp{a)i*TA^Dw4#e46^2$g9X9 zVX0U2b7grs0wD-Zfjo-VLQpaK$HKO!a`xjCfYCx@C8r^Acaby9{Hoq-eE%;C=$OU* z0xOXb9D8FaX!EWN=_CP-Dx#vytqiH@N5ZBb%xp$}_=c@TvC0LkdCz^v)z&K0hBw>E zSOxA5ZqByjN%i%r6=r zDn>>|Oo~wQBMmn$X2?8_vnYKY8*5(cv6Oc0KFA0JrAu0&^z{+WL6qI$ws=mfT91yf zSS0?6q@)$WG1a0}K|zyGJ>c_)4>0IrdS`rGTwmT|dWVNyBo>0`BW3J+_&g--vaxp7 zQe2&h<>fnwDVV1BPdbD!;JDS%>e10r#$|b)?%-oe(V%1OD{$q6`i6%uO;vJLpO++A= zytzDBa_>LOgN?X-IzFP1Xn1Ef^6KnQ8;;re z`}uuqZ|5C0DMq`ev%x?@t+~+1|1Tc2DH^S3~O zu@$3<56%M|pw8_59MD*ynlsv2r}&ZkJVLdlUP%6n?*l$w@V zHK~I%0l4g~t4T2hw=dN{ONuTNb>7Z ztEOQD!p7a*U0*+LwDAqY5(Oq^_#Z}IQSl57O@4{f)-3kpV=T7p#>FYO8p+0gGe#Gf zU@&+Se(+MWpT=-#{Y3A@Fl*6Std<~OHY!~YZpu{)Gh1I!P98qg(be_#@Nghl%;<-b z|BV{aT~6s}X=(W&<-uJ(fpvJLY#&uWAt@x((%D&p$Da!Pq;m#--u(;FoXb@V$6sn(^IECg13KAn8P{@nKH4HRx;%4ZA_HqP7_w2^Pm5xA=?E zwXU;BnSO8Q@`-hBRAF%?Z)s_%hq9WKR9_EeXlUpoV7!&(XEZ~HHd0KdRwz2Ilws=L%?~AGW?DRBA?Xzw*g@uL9&CP%gX&GU)(ZV9Cm8k!RUiaphMM^{C zc(r;miUsuAKN4x^*RLCNCGX$s8yE;i0P|64-}?-UZ3;eChw=asAu@0{!Sqf~gY8|zMrA<|85kdymZv}8 zvhE7u=%79#F-}1+OWBitFjvVvO25#{)AO#W>41Y=g&9onmm^`c8oR!@81iHf8VO*b z8?)Ey6`iSB$XT!7W=ik8z{SNS`vex=e1eR*jub$&`@j?C)5_ZSXy1OLrKP1KghS-N zD=X7ozr44%*XX&zk*c2!BF#qKHZV8^jWq_2=7l!T37~zRXen{~DrHp`3sk)9zw7&q z)CN=-iQGB}2o63jG)PZNOXJ|+SoTn!oqPvG8;O64!Pv=U-miW(c+3Wv+edzBrhu%46q$AI&!4oHFST`b*GDQB#%kPwUGv%QR_x}kH2bi;?1)ep8XtEqSAFy` zG&fhE-`Z$8lX2co%P@EWzN{<$*uw_KDO*`tNkdJQ(oxXw0IZa{=kj@1`NDpOm`MS# z$`K6RG@zQg+S>EP~C`Gt2|peb&Nq_j@QXus)9moyQ5nU$3V3`%bBQ6{P=3AmfKICcPBnM`1_ zJfRTE;l6M&PV?04n))$$8vxw0#x1gS8tgQP&#trIbmBRH$;hJxu2tt~v31(T&D~uv z0vrH^Y;C!P%S1@2sZoINY1OhLIkR?mcNb>?0c75K+thT-AX%TBo2wB-_W88qcDT2i zmv>Q8vg|CINZyjJc*6$^!jH+x$@X@8pr#Hr;O`vzg`h8AW7(|ymI|3Q$SikxBpWjL zP7^F17#mXyYR~#keW8M&3ba;`+{QpWo2|vV{YMN_q4AZJjt|eQHGTfT++?ClPS6p_ zoi@>Hn!%QnD4~@3^S!{h(U0pEE*#A`=SX`dT#8aDsb8%y0Z(n88N`*q8@3Df)-MN? zu?w@=%v^QT|Hwgze3p`aKI#|detv!vb>7THM0dL9z3b6~4osoR<|1%-0=;vA!Ho6+ zrJScbXR%Y<^}U*I==Nca@P=>ZB@|&nG)IlQv#SdrWZ}z~8x|H8HZ~`PrGfyj_I7k| z?_7-ouElAgp`k%mRZ%)b+^{I)VleJ3ZnEMgu`^#|fra7#VPNQftn0qLgqvhO%Sr`NhXP1o;SH@BAsj3$ zdB+*A+icH9wvb4qzP`SxDeD==tDBpfz%+eCK zfB;rpFWI>FN0fj&%yP!;7>>i^RnTi?mPp8L)6YEho9K+qZ3OZEdm4g9rED z9IonV-dawLePAzxFD||w8QK2yqnrF`Wo6|^9bFBLm#wY%Q8FJdueX=i!0OQ&Zh3k6 zaBt)A;DCjN<@e6c{=q?YRh7Di#!wwfVWSb{L{n8GWa8pdLL%v=UA#{%AW%4&;p*?| z>B+;!wz#y^>_4kwmwEIEb^gk7d&)38G$P{TpZdF}-;C^7roU>+ZGbIw8&5Owic)c!TF?kzt15&-u3LfdL5>mEUh4sg6~& zw*Jnx(3xp;XVlU?#nZ7~a#91X6O@qhk=V?NBz4tq46f~>5pu3o)rn9iS+ntI99w5GB$F(ri( zl97?2qNY~Y)cn+WcXnc8Vt6=Zl*|!GM4;i@wRG)&H+f;OUxyo{wihp~t*z^4ehdu_ z<>lqo*w(EtbnuPZTUuG&2Z6=PIls(#@IX~vedhgpB_*XLGI?*aU&zzbQyhUvO;1n0 zMc%}?ySqC+zv=JoT~%3G-_*3Wy6Vt)Wu+aTBGNB*DL8n`Mi{Ju7>SZyzDtw{ruoD| zx{$!~8tLZt_0C3zr=K4aYuL|^aby{DbMyMoKYqL+Z>#gCXJ=>U=H`}{pUoa@58Jqg zMwi9J#HfXFad8C%1Xx&%Ha9DUhVCveduSBuXlgn-JO4e{U2_j_X=!P&li`i}G9=%c zpP%2@*qD{YX5TAz$;oL>2uVdto6=0J+Yq` z@v@FCrxq?xcquW&ZT(v8&dJG{nz9iR65`|I6U-1-=L`!AV@YW892La8aP5x29`y(1 z>?}Z*9 zWFO@A(?Bi_b|@4|hTF8YfgYEYb;Z&WTa}ue%)rc?`=b&bZrjR)7SiI^iNv_NE`DtB zh3-{URBUYp+mS-oYye0K3JQosB4}t(6#9rl-RPqJuN@J)Qqt1CpvCx9{PGG5!EXKm z0klwMP0cn&i-UuMKIr}AWH<%`+PAg2xw)m~6y)IO=<0I{0!NnN_6-UOGOpX)+yo6x zb3dlx&6_vvx5(*B3dc5&Q)D$X9866a3$2}O{M3SO-8ytiWYs+iG&bxVY_oKSX&zm= zbV)%`(G87GO--GfpVvM7p=f7Odb#uXU~Ok-$Lx{H-OXMeaA2+-B+TIY^-pti1;gJw z+}%$>ItSm+($dm0GBTQ)n)>>#m6X7P03GQgmXlMX=otd%Es$1N zrKK^$-^!G0YimKN>fyM~P8}Ye2kYxMo8x=Y+IJ7EgXN2(k3mi`fq}mOT=A(+2#iCP zTr22E6(uE*Z)2X*SUA9nZLJfV%m9DacC8<8&%&X8NNA`4KR+VPL3n5PU!2eN_%HH? z4h{|kG;hP{C>TRDoXyOb-Q2vq?5 zQyW>3!iEC+Nq0tUtbq@mU9cGvNnwxP4LRmo&Bz@oUgcz2hD?q7qD%fSi5->!8=hI@F#S3*TPcMtl7 zqG6L7i=M(`n3IhErK?5FWoG4^)1M(E~WFsqyvj5F3wyK~;N>wx6dD zcfqwoL&sM_Fo`6^Z{t6wrltTyq_qYemVQ?A(7!ylFDuRq9?{X!=g!pumRJ;JIblSi zdS_?b0EfxS%F4(*B@%gUzgvbs3;6Qo3lfQx&#ja($^@yUq@>)TRXHBXF?_zZveJRs zM1LdO-;$_Z2r$-vY;-O^MR}Tge>VznWmoRL)x8F%QkJV$R=2#oj5IzeGv8j$HYcbm zE01`+CxCGjaI=^Hn0{9vaT zN|eug^oW&(1+7E)MS$FhNP*RXfyAt=tdLIMGrg0Cr%vf3%u(E&z7O;BjS1Y2v>*}r z4<7=hWoBV1Q^r}r6YE7&dNsngmf{$BxxE;$jigxNudw3`y5RC-o+!8%OGxaczBqSoIGX>&q|hYt;-g-(82tIBM>)STwIbY z1cWad8kWL9qtI~U@5C$j_oeZH5-q0n;Ux9gTD8K~=f3u5{QUXziJi8hf&vbY$7g3Z z;TY}Pp0+O3J$vTwYx-)m|r=myZM9br*~+u=Wg|#O31g zCQ&$JWFunubd<2L@YV|yzIfHo-+S;h(?t|2&PCrGmSJ6|=I7^?&iDrfu?fn_$mHPhXU?2yoblsMargC= zZpV2L=UxQ40U661dPlI}W5_BhlJinjQK5m1OiZu|fmxgh-7yIZ3k!XHeRSCN$Um0# z$6axZfTIVZrzz)OhB8j^aB+=$H76w{#mCcdapl(5%6(V_1`rUgLC;fKoMD2*A_<;JfymW;N7oXqK3XK6XPk)a_4Wo2Ocva|?s zE19jWt$?pAEG*8X#go~MIJw!96IgZj;pfg-I65BgZ+-=Z1m0|Yef`VPr|6Tv6%}GT zu)>&E-uDbc#aLx|qn!DZu@b_@W?v(aJ(oNH4}p6VilbHmA(oGSrd5F;eV9%$>!)Zf zL00be_V(agw>IX8_u)oBc>tQOm||4G*)i6hTVpum2G*kgTkIur|8}5{&+7N_^7_c* zqwq>|Js4HzHlSHRAizmMpQoNVf>3{k9m6cy@Y+)fCKJevB8JJ9fCGHzvSkO^Wungwahw18) zR#$x_Z>B819|qby_7I3Q;79-2Rx^;0M**ENR_ExjPVJa1lP5ktJ{oFj1!_Uaz*SKt zC2K=N!wVO>dwZ#G(_!JXEd2Kbw$|G=1i@rs!(h>oxRwcQ1QtuNcrWNSo%(K>TH@4U zX@q(~7jb-ioJdq(VZvJ%3MW4nJ?lho>~m(CqfDs0oJ0I{RgoHSMu-#16e`NWYDLsL z99wNHLOE@X9>vB#cp>!SQ~aeTGgUd}TIJ{DAR_nDXRdLe{rwAzi;MH}B&OlUmpRdQ%-HRP zcYi;GJ(*v|Ni4AFqF}kWr~F3>=q#k?f4|j#jWH*XmzTFNT58t6QcM=jt+8bjV3-rj z9=xFdhEYF%e}HgG3W}w>+9u`~FJ3e@rms+tl9EzV;R#@yw z;+RCzWoW}qzBA=u9+{TGqrf4Mu(@j-sPN}R1RWO;@HdLcjiZ)d8{JE{8qhr^}LFNE|{<8=+Nhz+R`pTS~7k literal 4093 zcmXX}byQT{7QY}ZIl_R1!bm73g0u(>De)1GbV#GLq=b?pA&BG<;xN?EH6UF|h)6Ra zpdt<-($e+L_uf0R)~tK~ID4J5_pfe@{y!RYH0(4G1kv5oR5gSkk}Kf(E)^;Gf8x1t z0fHDl+*4IX1!S+~Jk`HXnCaEiG$|mJdZ=7jhY@C?)nO*b*1PM&g+^;+-_@l~)|(Wi zJYGW;Ub8ch@cV-*%EL||MJ7tH6a}YD<$h2Rp2d_`m`_N1(l!D=Vqib zBVXuHalKsklbEl6{rB(RH8nM0Pr8VCz0=U!)8l;sUS3{4zSjM3K{QdMcz0LVKWl4h z#I3EZrY1SG&fc&7OHx@mxw*ON>Am*ir6ncxZZj0n>jC2Q^t6|k*V309tRe2+y?a^( zqwE54V6p)(%e%%dcE!iXml{`&uKZPrre|Sgl|X;iQ#|$g-WFmas-~r-CFMSwk&|<} z*6{tUobTg+fP*hN@}yzhA|h)O#?}gce@tv_Febv2P8IssMXlR785xIXXDuE)VBz8# zT-c)BcaH2&sZvh&!Bti=4BHH5N*;Y3Dr3~6o{1-n;Zid*X`tohWj0Pu3;bi25)>=# zB@T`_8gN{#f;R)io}M0cRn-q4J}@&gql}GNSy&E_j($rBBx!oIY^mGYB9i-ke0|-V zovCPO*txh`pPdFif3E0vi9Wj9wpwRdJVgLXZ^nV{4%o3VrvE8?~~qpn^#9aeEOREva~Pc!(iAI=cpoAtRknR6Lt% z4cZ5DAXHlGVMoS|xsFU4pYWv*Jb1nm7!YuBu#i|$QNgDB;>C-mrY3d{4z$i9uTwnw zQ4<-&cI65^9o^~CYNamm4gZxZSD56;C@EK6Jnr-OMFuEHlsSJ`U0nr*8KCze$Mu0N zn!ImNf@;Ks1bST|(RA$sLlUULeGb7$)!EsptE)>I_U^wcbZALKP0jMXC(pHO-Jw^J zn5x!R%UVZQ*UvLE9N3ujbYolFJXOTj{(i6LWJX4zHUz=re9umv!s8qS({DHWZ+sKT z4bFRTnUgd4c)9{8j)W z$@%>3G}EY{pnxXo=X`gxgM$M#H8r>x7K@dYm34D-gCJvL<0zyuMxR#3Yjv_5??Py5 zZkCpo_Lkv>M zcBVsouXI-dV8Z82$oudcjCqaRIu@gcy^_ev&d$!l0!Uu*h?Ivnx!=adMjTCRxq8#I#(uslYJPqmB`7H_ zE-o)0G?J%w$#2N9mQ~c^diuaM1j6wCegCzu#9zP2pyG;(gv3M*w`Zrj1mD$3%Vxj9 z&=@49xTNG$e}B>d(ae%l@!82XaR7poKN_5 z|1W7@v8s4X4;=Z2aVuP|&%UPFe`9Zd-(^CGIrjYQSPzFPaXCBPw}v{Fmy4CS12%tz z86EHK`PGG%R@jKK3B$E(As$XnPF3;(!yBnuJdwe7pRbG-%+1X`Rsl2K_@=O{VVRtG z_sDsyP?tm6J@{Y~vwm6kQ~tl51VEmgm;h2VK=qtE($v&cBY|^7ID@e?dWz|%WT!}3 zZLPPDPo29$lIHk6R*yfq-@eAkLG$1B(#Qc!*V(yPs{k1VD6=~j2&9;ml@$tYZ-4IQ zR{mA>Ix{^3!Ph{HXaD0u+x!zLZ$C6f)H2tnC7IU}h`_V)SB&CMh9 zQ+x^v3LzmON_HvX;o;*hK5z<#t^DOULR}%8o<8BOaH|3jx-K!ZpVbQEJ7QanFFaqVqw zb+)OD(s%5dNwE9@8v?>`@%7X!y6fxfq+uOY-Ir-92${Ht1ed6&C}4xvQ?+(CWcNm- zFnRZQVdNAP>^3qgo&Vch{^Q3(R@U^eFp|F`o6at_W@=+tjYI?jq2qTZ#qj?!Nt*d? zGxeuCLy9Kq95(c7m$C-WK%)l5VD+&T+aG@0UKv=$e-=!rAqNr)%#XW%L_Nc3WPEI_ z_R$zW_B1y}M+{$ueQU-xBf%CAxQB0O=>7N+LmG>=AtUWXOE?uS6p^SRn4-H)TLQMi zE>P-siWb2mtE#K3TUvtUG=LXoT9-{R(L~KOc=WQNIXRWbWR7OSE!982y^a-XJUE^>1?Gvvki02CNr@+wnxFbsmo>dYtR@%BQ zE~~LDLivU(E|sm0PXu&C`NWfzoE>olPK{W{tcRx)d4{++)|*n%l#8!ngUn&CO($IF z5o)!jg`UdJAA<6$9`fHv@*?GFMpaHXFb_H&o=L;7&(H)i*GpVsv_Xy3w-prO9^{*giiq4IhjekXDQhB%5c? zp5gI$GrGE_XvbvOWdX*n2^SfDl^q^q8=HA^k5+P?;O$>A(a{=qcGn`S+S=M`YGBBW ztSrFE?X$D9iV9IkDJV!jQcOX?QW#!}D#_2!fAaF zT5^GhtpG-3f#JVa2H;ohp73@5)hJ2#h{oJ<0N;uDYG zNmdJ_!qEEMk(NK~U4BbyBDHiz#oU*wc}I=Mk#x7w`dTO>qe3A@IUww)Azf|mNV0!SXa_M?rNzbXJ?D|2 zil?Wiw|DJ)Idx{lyRY3b)@hf5|Wz18G(7qWr18yGOb;eMMxIsvxQ($d<_j#iK2 zaj3^CDiLN>x9{93!;jyxxuB<~=NoaaK$V}FN>`F6^;I!}Q$N=6s`Jew2Pdc6X;+#k zBqB-5?W@n;AJbiy1SCfP+yf*2N9Bgvbaq*w<^rhKUphA z=Q?BNW2E4WL8WXa^WZ$5u|^AbUth^ErM|&I zE)I_4!=+rnw58AJWHcHC(;Kju?VTMG2>6fk6IeM#(_F~jv=ay!I2;Z$wjwDh$=J0v z(@>P3Ux&wID5B}PkY~=I>dy8ycVtdZ4is8aB3LdSDF*WB(eCQ~rd?ImFcA@vf*ij*DbBBt$|cM-C4xo3aoni`un%Gx1V@>n*%JEHH9)3 z=I29DS9iB{z>sZ&5oP8LB6ZEqQsQ$l@DAop-4Y#9!buOe!U9Os^W^P`t3q za~+{6eQ+|Qk#Xg`Vcq3Vb$`tYk+~_(j?|IDSgY=Y1|?miV8-bnLju!kdPcy*@|o?zni#a9SAIlf1tEWqP_1kDnMZv@|7OT_SWj zsKJ#)V&h)D%3;!ylJ9u2?J{43*umV0_3l6!8<7kFzv*yN^P({TJKYs#flR}GMa0kgDqHZ|{aQ6&LsYv62&;9IA}6Mo|wtpcaS^8bN>4}{MJkplaif%M@FW& zRR3$s)7qk+omn>&!aw3ZrX-|+t2tZe z=g4>=`1qo9_<<3Z{;(`26iq&9N4`b0^r- zb6Dw_2q#wg5MNb?S|T88Zb4Aipy>7MVnzNkp}*GF$`4fV1&xffQjPd_KjhC;b<)3!X;89Q$hgAC$A>DaODzsAD=%-pm+x73 zxIJ+5`}6aV+xWnsAdpo6t{=G-{mG{Gvy+jR*U->dEn#@6iikp@H`Q{%QN68rkVqt$ zQr+SM5VABhqCv)}r^)EOi{S=`v*xPz6rhvSU;5|VI0&NurmP^VNQDDs zhVTn!c$&ejsBk}BiQl}TY02!N0Ri)#bg%f+`!WW*^7lBHQ3!{j!i^*zo|#yf)ZO|e zIw}rX2CXdAm1#uC#6`^P@vS0OWbj$^t-ey}n|86wLz^jUzWm4X~MpKqk)mfQfctScc)3G zby?vI3?AAg_sl)W|FOF2$PpV}_~=m(k>MOY_8cuz7>ypT@e<&AR8-n0nk|Kt z8#k1>83K04yfid4JUl#*NMs_v@v8zlqOTWrXk?^RpSMce8VW%n%nOtlW zbA-b8!NHUH%$Oq6x`4g)iScohV43vXTx&D4-^99dl{vMot*=KY zpvA;0%gY^XY%uET+Z!9P1=^p9wY9Z>Ha8Cs4@Fest#&REDP><~WMsU1hlGM+WBb7T z*RJ17(&fonFQE|2H+Xr4MMM;pN<3GFTU#+D`hV9azWQv=5}uium{3qqz(bZtDxDfa zC~PJ|D5$<1EZ)r5@%=O1maUptQBmRP<+Zf9Ncl_-Cd{`goMw@@zI$xXW${QbLX5!Ki%hv=Xj7|g1zmz+$)1k9@69P>+8FE^(s7MwAQD; zzFwwCW9GBhVnC1#s-IlS=MOBVC6f?|3fJQP(btzxB+4PCbJGHzM@K6nES;UTOij~z z<^~4`!OFMz`DtWd&dyp%A$umA5wMNjT}?GL1q7$Gbl~>l06gT!;9y*v<ytrd=r?Hr2etrfSZsW1YN`T9eo@ivhWGgRcnrHVKR^G@_BJ3T z8w*Q*US4=q6b$;H&ueP>D>*s&`*&@2c6N?faWq;kw_ga227y=LxcEkGXJ-dc6+BN~ zUVeA&*Ichvxga~i2Atgbe6)4BCV?ZJc7 z$X~yHz3ViYRz(A=8BE`#CIgwi3K^|OG#E`ky1ki*w)#h{S)7 zvOYpcqtCt~A|mk(W_x>ke-D<5UEM5ob#<$&s{>AscA=p5_I4nY`B(`USos5t7HaM6 zbtreM$L`EV}fh@ZKQqvOao=mOuI_~ z0UqHDPX{@qqN0+g^B99^&Ab;A6&>C8R1QEGuwC<=6hS*bl95ll)bn%&voJ=QFx)5S zE6E#HKo26B1jau+ls7dsH8L_XG`t+I($&^R(Bc-pd;tn-nX+9!7)Oxc^QV&8P2v&^ym*>pD2e3#G9{$|#B9P@km(9zWdHZ?KqzJt zZe>+eB(z!b*eYD&o7vpwWh}_cgUhG1XJ!%KY}RHJY;4ro(4U%^m`F-W`u*Ds?7lPFB0Mv5s<*cnXpObK ztRmmF|7#wuVY}W}?!Nom^t0F5>fSfX^0zN8MsTha9L;ywHq_C#jpkJ!?fGnu=w!6X z?C#-qlg8H+y`^^Q1ZMu%U3BtU&_pYBbaw|F9c*`c>fKibh0xBfATg1t!YW?D2iw20 zvg2q{JYU|$8p*d3o)|UDqUsD5k+1_c{SPr` zWQ3{xcrR=>l!cw<<_}j%U&Ug964eKRCo7lg@a|Owh5qXO{lNr6qoZ>)tj;bzn?2MeB_%-VXI-n@B~z6$U8+Wtl9-v8m|(J?>N5(M z`0cJ5Lr`RsVU_E(l&%+%k#1gIPLChUdCfVCxBWYSkjoL)Yu3Ji%1JCJ*j!)#vps59@K@l#H|$AUP$BL?3{hMwe6o!*jXEp{d+bE znR0uitYSYu#8Z&^j$#P;<`WGvcUr|!i%xGK9+i$`hWh$&C|x@r6hmOzwDWa%;@cDW zfdeED{yjUp^LO73lCiSN(c=C)5yt+#AAn}XX}s3<;X_%1*59L}L_XZ?!h%Fe$u08S$^mx_ zSATlW+#tHeaGtW0R+3_^8jpgbr)qki*R<>%e#KQf8dtmLV>qjQw;${4>zkOoOH3RD z5Ng3*MZkeQgMt7*0s~LN!{JapK|ZXv&|AtRffDCP!6HX+-nxgCiXy|Mlv;I7Zg@{o zc6FW(E_zgDcHDVx0fCr^2r`IOI^eBJwjmCeDI#Y76LImP%i@n4=r^@~`>qZSD?sW1 z4NjHJ_L>|KR@4ye|K+V3W7va0RNZL)6?_gXo-3Q zg}BNJ`yn(4OK1tTR#pC$x9N0g}SQdr2e> z3?`|wIyH3+7?$2*JS21PUdvkvH-_R5HhmdIMf|`nWM@-A7){MzWw!K^O#AzDX??sz zpp9Ouqsl5O90<709|w0+KE6VaB~r7-)fZyjA)9x7#^oLL>KnO_UwUc`z>NsW$-;Qvf32g@MX z*`*CY%rm@JWZ~v-1QwGN$t5N7r)-O^-51r+!H23-n&4 zBZG|ZoLpvzslxUCAs%J=hz8mzyb%OG*G!OEoOKm659o6bIJtE$uElMvR-c1@k5;*X zipvqpU1ZQ)HY(qJLgjzFKeqw8o!D4MN5@kmVrZDh3zOxfJ1@z{%)%o3%l_wwE4ObS zw#VOuhX{*`>SD2Nk26Tqx-TDESY&2q_74nfE4`(owMe>y7mZiB7S}fQR-PqAR#p}S z5V)onFJ8=({%d`smP!By5;V=qerei+Xk)QhPft&}h^*@B%*x2%K%?m#B8!WifW5c1&5wzpjm5CCun_teKp)M>$Ou|oH7?M_(!-yEegnw* z;qKbf!a|$XkfNeuLP7!{k(_{=WuD%^XZ$WOq?HaMy2i$LN-Aq=YCxNFC0^yaFR#jv z(33BJHFqp=xk{feSfk(Mk;MBA#cw;L#KZfDi z?J9B@xhx0{@Le`GHlRaLRgH{~$AaRarGXCRYW?>-VqiJ(jHF#)t8Fj(uc@gBegXyiboi;9Xe6^VM6 z;@YUspT8j>kf_)=KMp+L$Fww47ncpoJGJh|jfqC9bzFb>bK#2)-XAAULIfT~@(shgFPgOqUn*4k>* z?5iXVKFF+h2-LkdC_S6X4$5>(OG}Tpax$8)DFNsnaIdD-?hCyHc^Vp;#e~h!yu7@z z8n0i~9!p@-x2X+!{6DFrsEbmfsU5(^)!-?XjGL)lDG4N)2x#G^G87~2?d@6F*hy9PS=vQ)t)(j;@HMX_20{qjkFsGr9Go5dQfZ-^g z+CDj=p%m)7^Fta5L5quvkL~PQx~}D#nVF@7SF5Wt1?}=5Cm`+gaM%#-R=;AAI{1Qc zxU(`)pmzq^^9wLHpDeLx>9tnuj9RGBQN(c4ZPgZ-H&mgiX=vyo6i~&dxbHjvEs1SB z@#!P;l09`*Y+8>-fF@7qsNls21u@4_R9qX6p;b1fwytIMN-V}%{H+4$qu@kO+Gu9l zoDQJXp36UDU%%!|ksvl&d3kx++S+0;;XJyJ!ec`^_7ONLhlNIxZ_K3vGyiQ+n^=V5J7x>FJoMsVJ01 zq0YdvyRe8zt#B-{4k`o3U0PR{I$~#gpBO(JN5KM(PfgJd;0qBZg02y?XxzO!6{>te&9iw0#ALsyx7tP>E}68RK>)^&}cOM zJcjwBx&|`yHa)%H<;B_bw9#Vk4|mDML{Jk1X&359N=tjSm@_0s7lNWxKj`ITXOnG) z@Pj{jqdMQ>Rf0lIW$>9HXCix+4d`;=l&V)rJ-0TgD!n-m|PBjfMs<#o8T z*rt-iG>5@puvm2PAD^2yZ#F1uY7YP2nmG%SOB*C3BU?K>o0ynjVPPSP$d&Z4*`BSv z36mp$+$D1zCW}2Qlt!e9cl@h3Zr(jF^cQd6nj+;+>2 zs~yvc3>`|pj}M`6i9O3WWPp#)abF@MC^WuT(HLKul?sAONYE)z zg3C-#2fKoIzCVDVoDpoh|Ka)XEj4yMC8cX|%60YiMU%hQ*Vp6X;w~>Q88|kLQPtIM z0RaJlfo%$<-*ESpUcZE^+S%E8d5J(>U%!@>m61fkuR{uyOcaD}y9juz=i!DHBO~LQ z{BV{C7b~kG4@xfh9Etg;i_?DkbSWW$j6k8ubx|td$R7C(iBH#Kgo)p;y5wDufa6yLa!B z((xN`-&U>085=q~SKyTio2WTWSELL+BZ{~<->S~Y$biLTWbFg@Ap-ng*L8Gt!~0h! z?()#aYiVkdkdROkoGr(|Y;0^O2~t$qX=!N{3u_u0kjvdsTho2B{;X%D~8CpNE z?umZ>{Q149_r=B7R&S?;CYLhm-{tB&sOacuPA;zg{(i zT_VrR3xC>p8XB4?^z&L1q*O;UZjwQALJ9sR%-7RXSV+jh*%^#ki@C4wNvVDbJ~Zom zd~tRd|LPSukh!_}ny0_Dbs+-2cX$}Mzw*$?$OwUe^0YGtpZWXyQ&CYt5Jk)_N=h9A zgY>kt)!kh;J3G#_!8e+A>gumLI)cs27_&5w4-ZAe#j7eRwzs!~E>49~RF4i1mHNHx z?202JBU@Tp>g($_iSt4XWdn`|CMJYoU67a41xm}EsD&?b8X_~C=k-c8O4bY9dUf9V}XHoGm!`5(M| zR1~NDuC=vwZEX#8-x&1vz)yxDF(WUJnTd%E;^yWq&@1)v@qxl5+_0GGX+7@S_~CGr zdW*TMx%v0eJn6`Y2nZs(QG`az2@4;5Mcrpj8NgsfrKJN0Q#t%DVoJJPzkd<}lQKL! zd{4jlqdKOVM?7c5N^l3;QJyi`aXP81cw@u8$-3`{f^*NeV{J2)2p zOvYQcCObbFT))&I#QzMY8h}wzQ4ynkX=Z9VP9CLrmy&4Q<%rYmaYI7`x7#ltB$C_d zo-X%oFkmH{*4Ea%v`%LS>%G0b9il=5Wvr~M`SPLp>FMm5L*yz`pCbvM@EYmrrYx(P zHabp?pW;R7!aYHGxJ z+7bL4CH83B3%Ot+BTE5s{bgOiD@uVBkSX*$vanI)Q>IRiDDyxwr%@ z+h@OhqlVl8SGRcm#D}n*p;tdXN1mSg+1lEQlCqi34-DAvd~Y%5pTS~7!2JNk@Y0gT z^yJC-Q(rcdfYOEB_heYcuviwTYuPnI}w#8Z;Rp#WF1qMn7+=HM~(8Yg81*6%`d1H~8mdcVa=hEVkE%I_`Z?PDX~f?~Xa3TByr+DVUCmN}*6^ zy!l^qg`PExyq}(!&;^8x#bT$Yqp|m&ne!kf_>puVND{JX|$x(#_MkF%BZaQz{h>RA05nubYfjG>1c%6Q)3#XKEz0_cS zd|c37@4eoyt~VKY;XTQHTC=G*W|UkKm|BCIJ~{R z$zOUfmsV6ftDpN@mE=G3Qt@s~&*1Rzm#=V6+(&g4t}W7@3x4={Zx!kxF;C4m6} z6fYyHs;Y1}91u^Sg5fpQY&$zUd3kws0+!njBDu#dEJ@X3o zJ^UT6vU^^AzT!t~T+Xzvs*KOnmyxVrGM*gX(2Bf!`25jzoQBoWvV6+Q{FnS5r)Q^rq!m#!d?iOQ_NB~)0n(JJM%7PXb3rTmAk@+J4= z1AMxFgwhGO$T+N?z;-*+uB;mJBFl>o3+@SNqK7|1!Ndujocn;KfHff`By4VOcAKkv zjvFtO|9f-`g5SUI1g6BZg$Wv;n4n^2mbLj3ySL}wK>Kzq8HgnbiH&fUmX=m!Wu;0o zOCFF?Kugg#VV8T$N{#rA5tIaR$;nUK{e-4jx~Q2bB!bV6(AWuvf-2&u?z%c*0RaK$ zkA?^-64eZdv>OyRF(!K$x93B*_ zYy))U#fy^oc+!6|&%?v>bzp!9($UeWaa%%PTwKJ{2^bj~;z2+)6cxKG&6@pWu)iit zMn*>BlvgH89s`S#43pp4-mWl0Xz5s3SZHY_ZtAza`RUU4rJ%h0eoT)pnva{CexJ&* z)6DR{?7l|}3k!hzcb4~;Rq%y`gl4Lr{yaR>kM+&X ztgd?DBU=}&3P7pd?+k4 zb7pV3$3b*HmWmBDr~btlV6C*&R0<|ZD@VukwZU6#Y(>D+<>cfL-nda^-cpA~TULf; zkN@BGz0(|u^vBv&keNPtQm7(%+t=6kSmpiu_eU79#6*BL4UHkSG)_EVY7`tDH{YwJ zRa91bNHXPVkByFEKY6gd9eYu0f>RGuWmoK^AW-;d;HamU+SvFTupR_Ciw7QVjBL$R zbET+~lasSk4~~u|X_sVXW&-{`|MSNQnG|Apc79%5QUd1nWNppzwDF^Rd(o{{z7!wy zy2Qs00#;qnuEVzRRNW>YU`|8FN?*8MNw3bhs`RH!i}y~M`rqu)EgnI1HT7DaVv6t; zUWZhlIKt=`cUIe4Ta#F1&w)rQMUy=NrXP&7&n~u7hZ|@yhCxtB2)H+ar)VS+`MuF8 zb5rHfqeleYg!K%hA6aSRQ49ZOXuJSe5CmKY4O+k2m$+4`5A&@od9;h|U}R<{ha>}z zxKZlfNTjj`zex?8mvy zuI9g51y+)JP?b+4$}X2nY*p9)0$UpKFAW6IzNE8B!Y((u3)XF~KtE!77SX}d zuc@X=EQ{=6^qcpamzS3v92~$LtEs92m(*9N6oZeCAK)0RT|!4gGq~<~l%H(EYh<=K zWrFZ_a2XMBqSsNs|h?#1`4Ido(gR7HRxY10(}K&UuySHQ!IRwoh_WD34|01Q!KQqp99DF zY9-~n!xW|Hf4aB4+!KQ$`CVRCUS9s;!#bu^pEbq4KZzNF#JEnn1;0^-f1K<74tS71 zrM*nQ)6|&zw&(&C!`5c=3`rC#A0K&ge~eVZRB=fM+}>g5*a#zoNyX?}bIjVQ%-F%L zH0EG&ra;cdu-qc2JZmy=LCIcg*i;IiD3`^_x@C_GiN1(5v zp`n9AsUvoSoKgHX4UN_tK|JWk>S|h6)*VJh4G@!+SyAd7X@g!H!@3MJy;kn-?tXr! z%}XKDNSqFYP*RHAY)Qz=vjBM|dn=mk&NuxTOx@$6#8=9!baZqr=9VTV+>}H{)s}x( zdgGTu{_w%!VcI1_&+6LS+t=2f8H6Gb2wh!WOUwMu&Q1`?H92jCv+muycYJ&dDt#t= zr-J|(_xBU_AS$v^$9;`o86MUI+QUQtV#mcQxc%kuXixfzG!2>mN&>k4y4;hJZh#TWYe`W6-#FD?}WM_@8WrYjqw+4gof zAbaN!u3y{7Ca`L>YtYHkraiKVKe8JD?NQP4zTdjc2fzW2=AnJMDLFY#wzh03s^jG^ z(cenCbWRp)tb6`ZwUQDZ1g5{-s8aF7*udc8^3N`?UDZ!JM+XN>%gb$RO{nA6W@~Lr zwDS~WT!A(NR_C{9Jpy3VFVQYcW-g`CaY{nK1+#{`yA`3ZB>x<6qMV#I=I=;Rdpo=1 z^WRQK`u}(AMGcyqX_>(<=Oa*#Gos==)Nug+scC7(Rpw93%!XF??L|#NtZ;W1gbE4@ z!qh*^&&}aMK%w=`%rpvhhzKGKc-B2zJUl$4eRqI5<3ob<3FqhM0|Nv1jjLjnS@rcN zL1N<2$lxXf0bIgvBpa2L_2Bu}+lEo+hP`(6cgXq{+k8AD+dLe5*OD&H!--1 z88o&(lCa5Pw#W$&oBDK_P{b-L8$6o(04x!^VO-3q-1X?_b}1mgxDPS&K95yDd;@PL zN9Lbk*T2~8XNx(FPi!*45nydaj~PS z$`zpXuOE>{qZ3Tx6+BjlTRF6{S~uU3Mngm6=!-gQN<&jq+21~xmj7Z}Oy}7~4xk>3 zjsWkODhpt(WX1l)95yxymw6=MX+Zib`+j0vMKc_W7@si->KfEpXd49?hqrVdh6F{% z6S=gd6ho1CN2G6XaL@uX)?f2*cd0XQN%-ruwzuJrxA)=>Wr|NPGrx+Y%CR7d7`^Fl z{~b+A0&OraVigrd_P(M4aX~idv?jj5!Zxe(;ZT=gtfnIe2M5SpxTxNxcS3F=0nhaK z>5qsLZ_tqR{{3?j92E3YaryG^pJb*7;7#D0@lZjs1tWaT^T9daePawcL7Z|#{(of; zT1rcaJMeKvt$$`ij0`6*--O4C77XK!aMCX_40yzZgg%Q~Pp6b;qF=o9URYl(oJ*V+ zI-Q%i^7#jZyO~2ClDX#mfVNq1pr$)8NayKOH&@rHfB@_*pl+A5R^SapTbm;CbJyxV zC>SYak=dg6rz*JCetm6>SL2=a&rzm}ZQNhyeUW$)!5`t)+#+%W2NFScwhJ{cE*?jZ h@$z(q5%yhOlgKa{4kK+&056G<+Cy#SDn+Y^{{b5g2Cx7C diff --git a/collects/redex/tests/bmps-macosx/reduction-relation-with-computed-labels-and-hiding.png b/collects/redex/tests/bmps-macosx/reduction-relation-with-computed-labels-and-hiding.png index 67c9db965d059926180bdf76ebf85fc5a93638fb..d79440039a8a2a289ce81ca84129281663ab2e32 100644 GIT binary patch literal 659 zcmV;E0&M+>P)$I(P%WTjTwzbv)PO>X0cd6M3N-k-`_hNj(WXLYS8I)09Y)RR4VmZOfVQU zo6QD;frvmv@9*z#Z*Kt9m7Y$ge-EoxtFkl$!1KJ_Zr|^Ta~!wz+*Yd<3We-;`^CjY zG#aIq1U}l$?Nf+|GY{PU^Gr5f2>_8uq}%Q8tNO}|D`BZl`~7~cRx1dC$Ky$- z(|Wx=olet-I<0iw!x_`M<|2w>uh)~u!{Kl;nb1;mIRv!%9VixyvONGn5YEodnnSeBSHz0@$)?sS5)@M1?}Z>2x+4 z4Yhp~!2k>f1DDJ7^75j#j8cvO@H~HddaAa`2K*NnaZ`SzzltB}ui}7zd541m7!HT2 tR0_cD?X4(^YAgMlZ`;Pd9Y4}v#VaVGi+)T<#L5Wp|@2PF4hM~lEkv?!@~o^FaYrM^i-)-4&@T% z&fX{ZORgY<(jqG+i0JK`Iqcr_B!%@yJ#aBO4k|aWiR;vYomzS4%y?!K& z007VPnM?)%ipAn=HoJ(>^U8wX@4vgdyS=?-7$zQ%KR!M-8jWl=`yQcW`IpPlGclXZ z=JWY}%=5e`ig@@;d^7)mkB)@W%MA?q);waUTDa1K#o{IcT@BS420Iqwf)ALhIegFUf M07*qoM6N<$g6+E_?EnA( diff --git a/collects/redex/tests/bmps-macosx/reduction-relation-with-computed-labels.png b/collects/redex/tests/bmps-macosx/reduction-relation-with-computed-labels.png index a87e9f4c7603e73576224f4ab3a01cbeb5972a35..7893398a721d69527fbb56f80688277009157e43 100644 GIT binary patch literal 4596 zcmZ`-cQ{;I`#tIvaz!T$Gl+0qZM3LEv=Ic+qKi=zq7%I&O7!SNyJnE+1fxWW79r{= z5oKJWj2;Zp{Z78;_viQRdFIS{p0oGNe)qfH^{zFs`nt$JsoALk0QmEPrkVlxc>=y| zs7S%9R(byK2b3snq#AJj`}I%zyEFixFMFVN-^f32CqKZF@q1>!o*;?+joiqGey*M* zkfw1;4p;x>@V_?!cQteNU(+T=>P+Z*X_)|4{2M==QEwPRVsS2`(B-4Q|-RH?e9`;42+xH@>RP%A#|@r|3nmCAFOHvW7EG! zrgP7d2fjTh#x}dG>@N+Yeg8JQ{-pMhbH6c&gBY8cnb|982r9b^RW~#|{7$bh^o+QH zckS-(zN=TD;J0lG0FeFw1?wkIV7bGe|HvW|i7P8B_qmwh3h&FyNyCqi{WctLK@r6U zWim;2z?;<6WdgzZ$rI%Z+H9S*R^KgGSJ#fKvn{KSeoLv<&+p87$UvN&*1Nk^L`6j< zB3%1Wjys#2XC@u1^vizYX#j^G>(%=iYeK#3_qW#q-1sfM}IPxVtGZyN5^4y zNWYz(-BU^S!qI-uywP=z+qe7r`sgoR7dtM;id4N$B7Vqtx*lv&!+Yt^k$Vpty2E_l zS5@()4Uk5J&vdOHl97?QJbU(f`K^>oaBy(%XToqaU7&#h!=q03#g5w&j&w(C(F>hn z(Ek0lHU;sV`I#Bb8Ovr5+mSq3FNM%zU%vZB1Ov76eO%OlJuyJsFY;GM8w$GxS*h*_u3PQM2=RM%s4wc6B~XV z9VvRPXxiJ`o12?^c+}QfTUq4~J8BcJB>J>?QamKR%O#0_naAblTNxTM7LM|#4FDc{ z`1Xs73szBUQ!_IXWov6|y{-Wi@8?uLZE4q;Hw6VF_TpJWW;~Va9x{%Ojtsd(y;2pu zH-i~}n32bRpPel)FPD~*qIZZ;4!6yYi=zhSJHxKejNk7cIzKO1_o$nC%V@WFG&Fn4GpyS998d6GQ$Qks@^BzkxBa0 zZ^r1gNEqZ){!&&!3Q#Pl?0KJZlkTg(A^~!Tlai7s!|RKOd?F40%NH=!i5HHpd$l-EiGWAU4h3Okh;}aNLy8ItGDJ^t>gxyl^sd9$q3!p^ z<31z%fqyD0Ty|y~LqkK~zJ2>@jnEs*C@(KRnkOsa%*zuE)wyd(ObmkS=F9o+%u1mw zRDykgFGE9ll221(V;|`2zv(?$6+pD~ zKvBjeC+Q2JNfL@*W51mc)N=FkAn5EjZ^CWavc58N+I{(qM5;XI3Z%9|I|n5u(*pM5 z-v8Z#wGBVKo5!@V5&TBddr`2Zxj*xh)Q?Sp?bD0+1`GRFd6PecL=9BaD zZ&Opl*>F|Ko03E>XnwP>rndIs(Gl~sc5*WQmRhd%l_p(J3PSyFE+{9^+S&>hhDI{i zpTOzqDOd`mqBgQ=+a8xHqe>W%`}p@U*v zgMH|3q=@t*=xxYx>hX^R(i1uEAp#E6Ow~&a%8UdPH6|t|?CMPG>grI6;F1v#EJNAw zwY9aPq9S^FdXVltJw0)kKlk^`s;jN*P*KhfetySbRVr+72(Y>}CoigwPTqdHaHClZ-hhK7bZ zE{`oJ0$(ZLqzemhB6hv{14Z+g?)6d^vZ&rvh%0%0ZLL((S-=KKdpG_3oSsS>(V#&Nqx`zF~tr0Gx)g zxW^^B?Ge5>D9m|X6t-1Y-)AF+?Jh7^Z1B=6+u327nwmN~t}4yybqf&-_5HSa6i?=2 zd3k+()Le9}Kc2O=U#{<&Py`4!NM%6o8tiWCDh#kv*-I7>GZs1|-u-Pet=Dk*tbe09 z`f(n~(L)v3Q{awY0Q!q(Cufq1E@EJD$nq$NKtXYilkjwA0~hW*Wbqb$cN5?;Pg_+w00|)6LClI4W{Llk9CZ-iel*w`OjU+Meail%@ijb#iw>rx1+mmo?1@z7_sY z$I%1BuNBDA>lrB6BFgq{q>SasImKE?OKR@L3z+s8TAJih;=)b*M<`WWb z0;a7#8>J6(xe&pG?QKhaeK5o}|9w>V3?6?4Hv2j3^K;@YZ)KSm@^&pTS+yr^t>Ra+ zQ$gxcxhM?DC)^kR_)&3yj*2`+q;y5BVAI9r#X&3jn>$uaoHD#E6;1O!hq2PN!!yr^ zIH>O1NKcbzbyZm|An5d#olR`ZG~TflFZ6}iZly@#)%%eRy`KhVNKw33=ZSqe~#40N*BO}fj85nxm>C6BxZ|}6! zR8SNVe9q=uyrY6j>`6TQ{J0{8fbN}8qDRxufg<1B$Ue`^X*frd+w0hb@6E=OLKndw z5;xu_g!KZSv~>?R-@nTG6eI4t zVc*0dRV0aWa(O-%J|rfD@0TtJDvL+`U)U%Cyu2#Q$6y!Q1r^b1dlm)JfQ2ipUePy6 zX^2dgCQnNDl}l7c-M}k`&qg0T!9=v5b_RCbd(;xJv3O3jM0f>St7evlNJ6Bhs1zA?stnzX}Jv}`hZ*3$p#^bTO8IS~#Ww?DiCo_`;0uidrDxgqq zy@lJbF%*jlplzPh4oh&u8>8@ z;MOJs-fXZhOm^@FFf-2*@_eAM)1N22L_4b^>>8n<(1yYM_+IY>7A(ECv0Oqupwqy4 zh{m?+Nhk_7zHd8^(}vOIjSl7=xf`CrEfr(hy>@xLRe2d=jXsw%FO*cMuXY41BqP-8 zny~FD*UF}qPhI`bmTkJ18~Jt9vyNq zcf0~1CLy7%t83lj_#!T64N$h8fGu@BPTyLsN+6ggLeIPy@r$h`Jgfez$sgykOW?Qn8#o9tGH!+JqvP!N?`FpL;&%g0 zOlIc?^A&y1{tYTA4qi5AjrHP*`ySYv{Z1Lmx&via5^X{DvHn~xy{Db+&yc}jexbDsugLc8@k80 z`dzx4ySY`DmO5%^MB_k8t6*jR3ahbJgGJxF1L@!JIRmSOnuey#=$VO0=1lsZr0|=c zK<^0p|Io{$Zy!F0b0xpnoquDx9;^I?Rp;Tu;e~~K0iA5Iu8|SlI$CZzGLpNNy86b( zC7>5yS}HP)0lmmS=Z=yH1iq__o0k_;TdV({d0qV*eK;HrR0rR`f6rG6v#vvc0&QLN zkO1oA-Q8W#oAqjGkfUaPW(5#ISHHEj#hbw!4P{I2cX|Gtj~d*?#wkhx+#f6`Fi=ib zmYJD3BQq1lhV|PqPya*(zkn^tjI1BZ%gIp+zo#LEp9ox{MIybzS$zLrUf`a68g<*~xuIO@S4ub5n#h_c7n}b3^h@WCGp-3cBPp@x;{uQi*ri1Bg z&OK-VDDg>?$ruP#G`KR&T^EXVF6hMFY@WBXy$Wdu< z=E#2e($vhX&Uc}cRnk&eMC9o3FtLEL{OiB@`OJ~rfULZ{r?)rhQ!q(PJg+Y%wM7z}l7TXVCyrRAgWa8(FoMP+_&PTIl4 zQ4Uy&#BK`Gqs3?22TJ7F8H8mL< z8*6B27#J8}&~pP=?Bl)VxZGS$V7B8i!VX1}#Hedxf*Tr=2IojiOY`&J4P#E|kyBD) zTX1C<)6V0KJCxKJ92?8fEmKrfBzk(6|Ff)-wKXSzUg(TG-FMwX_uoZoTeSvl?5*^r zq@={13j-q~BTl})&vNG;P*8}Y_VVTK&)5|NIM zP69n&<@g4l$vXH|@Ca;dZ0a>ar+)p~+SrJTi!;twN|lN@JKXr1#4IxWNRz)jGcV8J zP$MHFBhgTwF(xJ^ATaR9#KfIs?!LXEB3@yY*e_3sfEO#?O8LD=R(5tQgpU;F<^+sP zOngPwB_}823u%Z24Br5+Yinz(tEG317$`ZP^+SkAmjk1}rkYy4Y-XgQW>SVd)LhmT zliKZ_+a0_^x|~8n@^p1|_01bGKqY+NB{=v~I~>OELXszyY-(j%%w6)4-(QG@O&A^f zCFcJ`**KatMj#L<)S9f(6P>HsL`|);z^%>Akf5MMtVKQac%?5*AKHkc+F#S9;TkK3 z2nlJG+KHS8QlFPZTE2uTBgGi5X2D50&7Vx3pn>K`N1IvVa2i_LpC7D+MxorNfkL`; zV|a<*xXblXAwX79G4=WLcE6>Vq@@0R0=73&01N_q@v>6=0bZiJI6rZ?zh6Lbd1Xb8 zW+kBIi-ph=bZi78BSyQ$;LjR4ARV7sUXu zcXiXwdxjre@NY!K4$jWnHLKxqsT`{Ja=dOmLC17F zJ`M>DJvhCHjg9r~JdN*mqC_NIv@i-$i3e;GaI`>>TH*aFFfX1S9^i4_Pz$(KW@l&D*UO6|K723c7PzH-(c-Tk5DB#*2DrGm+Cq2l1aGpu4FfT3XlN+j z#Q~OqmX;RMT2D`J;C;gT_wVU>)!m((7MGSZ*#cAw5)%`h`(Ds)t|fD9`>7P7m*8jZHLwg!P86x8@%V0>zCR~Hu6*4Iz!c9ODfl2TQ*o);HjsE^(x5OiudxVdp4 zx4f9;FE2AQ#{8k|P)l(7YrB>J z*Q<+De4~ZLE0FlhYHM#TG%_TXJQGb3WMOluivRzhzc))6N0tO)`uQY9M*!~t;`c+R}P9ac)pQR7z}(Gbi6MD zd`^09XofO5;)c@TH6FJriqe|spxdiEVppJ335S%)5X7N(|}{gz;&nH#IC zAr~k9d#x;E;Zb_tjZN{De*L3{>+_U@exh-*O;*3bv#2 z@^TPvi;GUm%9zXZV-yMnQB@^?T)Dc+1gWg7l#rB6f2JXF_2NFW_wBshY@LAT_Gu@yB1iUU0S4`~( ze3D7~%$zy*U0tX0t=HunNt>Ns{fuDNAVI=!LqxWgF0=Sx>&_I@WZRP0PZl~)v6y_0 zptGd+If9p6@XWI)5l$+Pyt#5|IYxWmHVX@FJ@GeRRu9O?$lToA%Hu*JBHHiWUQ#d4 z&(Ht&Un?7%0k?*Zj*cYbNL5@yLIOxs^v@2|X(rc?Rx>XWX>Gs%NLm>x!~C9#kX3(V zSj*?IzQN2EuZ#FnM)bO9yk15gKbuzaPQtm;B+uK|ZKK5*9%#FjzDxYpT%syidqobKWmk1#`*7k_*&fE^qnzWXZ(IuZ~?LshbcAcSKS3&H+RF|8x9s+R^ zFFin_wETb%q9mkF4m7TFZFJq>r@DoAQTDf05Tau&nxH=3vAP|Y-A{oytRlD`r=-jW zh5VJ=dG{^;C7zUuEadVSIz-bq7jCoY0x^rz-IBcaU6U5>jH@=h8r^L%kB1Qh@W^K| z^$$>wDbg(;<>CTWZjg|WY!fA?{HV*A=Q9`i$?pxpS&`oiWlRf zm*w6%{7{*I=)yn^0og=TB|w;*{5^G~VqYjZPtP$OUaQm5F34$I=|&$(8gHqon66r@ z!VOWwen)lYjqe8c04KD&`P}R}4RV=HshAHMbpfjR`HshW%_pEdk;@$f)lK>+)rNX) zb;W9X zH)2oPt-D{3_Y#u}cU}jaL+bp(Z28l0H*4u!GrDNvNP(eQOHunTYYW(jsQwI*-T4k` zTH5WMov4eGy)@{R*glhCTu@Q5x9eqT<+}x0=~mq(?D3^o^j*KR84FC8DqU$yYj*ah z1GazHIZef~#^$%>Cw{c>_>!Ad$z~2pKf$&c*H|hlsXy8)uruz;WaeP+xt86Ry&K!7 zQI3cDxrhk^VzuvsKYnCdh%?B;;qsMnQ&T6P8uR*D0}2guIQ;zTd{;+8uy73&mT%vB zSXoUC7eda1i;lsux5pS-w9p>jaJa%rsTEq}xJ?KYPTfA`+ui+*SMNuyxva6NQzg<- zJoR9{DScc(4VYam_#{$UJa|wqr*wIl)?WM*J@HT$Sad(@1<^*IT+G;NM<6KtaD#y* zxz=BnfV*y#ll#w10s<|9 zf$@*-q)2_E4TyjnT#@L-!``7iM_k=EJmh*qOF;WGKi?U3d6t#MQkvMe((&kMU|`@~ zt%8oRacV{e(-LlOY^)UYMuZ*uVw|$9>^*(`y~9IcYOqs>?#^pm9Qz9j3I+rO$T)UN z$xAOmuUY*>*HLb}CFrEvovZCp<7j7ZgAh-OZby52#i3M7T~Q`U@we|>Jl*O1FVe@q z5gIYm|0Z@iW43%k6>~pd*U*g33}3vTqxD(aGANYbaJXL9f%=l|j;@xexaE0bs~3T1Mv)n?JaB9vepXYFl!r@`8OcJN%1gl=7E(Zo2R2Lpm2ds8^+}N~ zpo-5Q`g?Q)+JZv0V2OmD^iTuJSntm^wzi)d8$qM&2r}r(UhINL{N0FACkY9Oot>Sp z$snVGem#O26z62R_jy1gX^ud!^QP+Zce>9*-PqXK*A^H32m`NfniPFk79fRLM%Gh1sMBi5S zW@cs*Uv2%Y1-+?#=RcshgY{#vUZ7b4nL$KEgd^T(>LXDH14Rjkso#xVP&)4H@bZo` pks_x!s+p@8$^iU6=pL^4%$PI!n1UYbgFj3FeVzN-H87``{{dJOhLivR diff --git a/collects/redex/tests/bmps-macosx/reduction-relation.png b/collects/redex/tests/bmps-macosx/reduction-relation.png index 1da77851c26e875dbfd20794e8aa37abe62f8493..2272cb4df5409711c17ecbff8ec81f38968ebd7c 100644 GIT binary patch literal 1812 zcmV+v2kZEWP)q0YgHN{#bVG}jXKxBxD7#D)^doRvjV&@!= zye8J(_x;@Xdmg{v=XcHn{NOwcgb>i;cDrL^V`F1u>1F>BF#M0t=c}!)^?JSJu%e+5T4Ym4xLq9#GngWT2qB-($K`T+dwauGAzKIp0)gDz+}YXLNUkY* z;swFqKy-pYAh2P>hLMqx;P#;*PG@H)04SA8$`X_oGFPr#(P%W0U3L`33qs#Auv)D# zF)@Ka0FMbF&hg{NWinY@T-?me47mis;`jSoT3XhwUHj?NC%s<3W5hOR2ml_BN2k+OR#plGg2u*1@(D<=FqzClhYlS$a6qHca5$WgA3vt2rvpG@V&c%y z5ZT_=)^_2-g>&c5#mC1x91c85DbC8ulFQ}q-@gZdUAuOzTeprz{3{@Y7z{>e6M|qK zk0&%HgaGj5$&=*dWQjylTwHwr{(W)@vIPM0^71Se%f5a4f*CHCJ25dqkU5>sl9G}$ zXU^QYb7y#XSfkO7Mn~a0O;=SE-x>q7Xtueu>|deg4mWVTbxekj~_qqm=FR$ zU0q#CNeP3&P$(28lgVH(5K53O0N`@D1_uX2Gn12(X=!N$Z%a!HkH_P1IA_nEy?*_A z@K+wC7y$TuzRhNvoSYmT9hFEV^kP`(@TU1Z2JOUtZQQt#&1O5DPCO=r{r&yDy}hNS zr2vqUl9HdFuhnV;fk0>pf&~D&y1L|YIhV^dnM?x%19;NmaAam?61Mkxy{lKRE+{Bq zu~=rad2ViwMhpO}R;?NzA8%-AICkt=&{$k9mrA9Yo12TIPV~e}!q0Y&jg3uBO@#|1 zA)Li%H2VGi2#Z8dyd*Ht-=~_zVzFASLZL7|K7Ogr&VL~YA-mn4mzM_siHV6^E_ctK zJ$k(!Z>Ll$EiEl=YHG^K$-x(Hw|jYB$qyes)YsRqU%y_hR^yAickeFG)-(V@NG_Kb z6cpfJWPZQDs;Y|3W?L*4gpgD!#d{ZAEHes)qPDg+bn$y(0>Ha>?@pgSy?OIy0AMni zYPFif;rM*M-~7)18=7C+%MTL(_U_$#>((s{!wL%v#bR+xOw7fL7k~GK{h?q0@ZiA% zrBZqC-o2choW#V$;^N}BZ{N~*=I7_1K7E>+nrbqco;`cEbLY;{(NRjJ(P$KjL^_=g z01O60=;I_MpFe-rYPDLewz|4{v3C?*FaStOO1gdfw%u;;>guYfsCfDErBo^RyLRo%moIT~ag?K*P{4^WWo(9 z{xq1=)6+_&QYaJ(g+e^FV#NxPNVMR2Po6+f5;{>RDk=&m3msIjSge0^56cNA5D2z! z->y=r#>U0~AP@-Xbh_8CU+3rN)7Z!p2$##H*Xs$R3!s`PP%6U>D*iMuCX?CJ)a3X3 z)6&vXQc_l~Tv=IJSzTRy^ypDa!;2R$L?V&j@6XK4Jbd`DTCK(~3;>#&n-3m5`26{E zf<7T3AtNKByu2Kjg;N$471{0flP6C$Ha5E5ZVrbNg_~Uhm;kVK>(=h>?vas^Z{NNN z1Ogt9M`Mu5WE~wH2?+@RaO1{}`T2P^n+*V`PMzZO`FuW~py%;;ot>SbA2CX0a&q$E z;NbN1bW&2%Qr%lLz=ErcjEvmeTynGCym>P;G=vbs7e1d4Zx#Sx7=||s09-DY$K%P$ z$|CPUIFG_984N~fv!F$w?IVz0000oL+}q~%Y&ZxemM7X&pii_t5Wy=zWAKS-{X1TXYj(~ zVIYLyFE9+_a5(<>$B!S;(b3V-(GUjYT7sWHe}-8b33E|k5B)-Oia*=$-d9$Yiw*>xpL*FPoE41!uzJC3R5PJ0J(cZm#>9yV6 z-IbMf?%ZhrjuF+DxKp`igG)Y;joR4Rj+^Con6nEn0z0)c?RU;qF)1^} z9*<{ma8NFnhcIETBR1GOi(E+U&f2wWIUJ75jA4LJo%`Gcywa_S3~J3Bik zCx`fy@%en^<>ed>$7;0_hC-nrn&l6E87h^ks;Y_{{9;%D@b>N7lP6EEU%wszSS(g) zX(^Y>#W3tQzp4QMfc#zd*WaB50K0eZzIpQ|lgZ4@&6UYyQBhIn&!7MGOZgAN1c3YZ z@2l17yLa#I*s+7p=jZ3=zj^Z}blJ?z%#$Zi5)%{6X7kghPq%K}Iyg8;*GwjpR4Uc$ z^#EWr8p-n)ozI^?>vTGuPFGP;v49;dCQJZ`kB`4~>z2deXm4*XDJgmJ;)Oz?pifm~ zf=%QUf(_Yp0#5C}9j47@d+^`^LWslR?A*EY>eZ`XzI=&^i3#{G3kvj!oKCdu*$WuF;&HlH0h#X9@SiE`j zW{pNOG&BSNIF9S}`d6=BWo2cBuB1=oZnxWDFi_@r`jAc6f=%te9VUy#s;{s2`Fu%9 zNeKxFOP4M!D=Vw0s5pH1aIl)^&!0=BQlHP4nwom>;K9<;QYMoL01XWd`}gmE_Usv1 zj*E*+Nl7U#E+(9ST3%kB!{Io7{CHhm-T3%8m&=XJX8$!T0NA*3V@F5Fz`($_Z{NgX zu|OaQU87VgTU%S>;^F|{`t|EGGc&|7?e%)o($Xm9 zl%ph|#$YhWtr;C1wOA}xt95E>iU=04$NBU36dH`4o}S6cNdRE8*~A0SO`A6Hc)W-% r%Wk(14-b=Xnw*@xV#SJx-jvQCDjvs}SOm{T00000NkvXXu0mjf7chxx diff --git a/collects/redex/tests/bmps-macosx/rr-hidden.png b/collects/redex/tests/bmps-macosx/rr-hidden.png index 46e14cf70397c41c828ae06d48432c0ef290fe3d..6cb65603c888fd9675aa47cc7177297fbbb29e5d 100644 GIT binary patch delta 368 zcmV-$0gwKQ1BwHXBYyw}VoOIv0RI600RN!9r;`8x0Y6DZK~zYI?bSW5fy@U#h&aHG<78QO zU-x}a051Swzu$AtWm&H4I*w!C_bEyp1i^B-93Le~I-k!3C;t7N$l?YhI4#quFl{OT O0000HEGAB93Dk>nN_ON(d1}5t$VLH~_3xD^*pWdoE*aD&n_D&wuqzAR=Sz4dPi|C?10T zDek4s^Ehuy_I@e(Qt{)LvfMW@rn>L@-=4dK2iKJVpss7zbphabJmz`+6yK>lP2I#uR07v+qS92MN!;tH_NhU#4u#M>pI7A+P0-BFd~lP-EMce zT!!)eekTx10N{C^5JFLu>-8E%k?;EysSbibmgQ;6IWNnSAmabuiHr{nLNnj=4iF9i O0000 zbXP$Tw5t|H5p9aZS_l!8$w;3fxG5qM!4Nc}k;43>{2b4m|3dH|UGv_qcAw20-skW; z^PKaZ8NlBWP17cmDISj(bQy*@K0XeI!=LK6x3{maum6ls0001FGMV-D^>{oEMa5>b z?RI;0b#+0P#bTMwW`RKPvADXr%H#3g-`|UqOW{8~Jz1^R{~-WC)3ipTSzKJ?@puJU z+uPf9b#)GhV_{(-7K?3cY(%5c>FMd+-CcqpT3T8Z3dPROjzAzl2vt;6m`tYU=Vzr- z8486?PEM3crBo^{lB7ib^769R>oph*!^6V>P%%G0Z!j2yLSa`|SHblx7E4V{4Tr-a z2qKkAMIsTMPPewUCK8GGe11<)Pknv8&1U2AcnBe}Sj=Lv+-~>V+uOjvKsX$(tgP(q z?Jbh0EPSa{s?+HP2M4)aE-(xukw_jM9=_`Dv9YmCCZp5ooKEN5+??C(CP{L0b8}>5 zB#}tu=cLnVjYi}1`Sg0d!{J~U24lRnwdHU)ir=4d@n>gemzI_=#)RMRe|&swZf?%) zSvH$JIy!1>Y;?I?7K=qLmq(*fv)N2h6vmjMD4M3dUhl-jL|a=MNs@PWcL0z|rL0z~ z-|tT*lLCRj=kw+29*;*Zmw!BypW}CQbex@?0RUWHUN$r|eA>Cu(NVQpeR_I|G0tYQ zG)>bqowJh3WPVyYoz4xi*(^dRlgZ@k2%$tGv9hvK@MM01Pm-iWBEcBL;o;%0k&H&8 zLZSGwSN=eeNMvtsFBl9Kbbo?xv)TB3KE{}6Z*LC-0tlgx?GX$HJswYyJN;V;g+i4| zRa;wI(EY?W8jTkh7h0{h6n-caYHDf%0HU?EmCNM@0)f0|x7)kByQ`|ITrSuB{r$Jo z{7#?v*VoqoAQp>7B2g*WmzNirOa=f1o6Xj0wKq360C0YO-r3nn)3i(`>+kQMnVBI7 zqAW3TD#$k&41Ill2L}gV{YCy9J~=rF0Dv)$#bQH4L#1?fDN?J|`}_MUl`54={WXN5 zD79Lh8$<5lbUKYjV;NrX`$7mIgvQ6m|C$gC2B)T`@}EZ*#<)CPRf4Xru531&Ua#kH cIHlA617e{9;K@$Hq5uE@07*qoM6N<$g45Q(TmS$7 literal 944 zcmV;h15f;kP)YD6?l8alP2{3(=0l3lo97gL&&T5h?P3vxjTS6GKKiO^aZn^vo7 ztuafpwIpXXbJ$kH?Ah_W7kgV`?|R>D@AvNceV^aw`Td^r^y>ihMIRp@=+A->s#L1i z*Vlxu%jGf}jo*S+tM%#WDG4(jxXEOS!!ZB=03Z^HEH5uZ2*IDlX0r_j1DDH9=-%Dk zJv=;ojVvuK;W!=&g_1DSfj>SzYBZYP=>Px-;rRIY{QNwQ<3ADW>+8kE#YUrXW@aWB z46dxK1OkDnsj024EeyjdD=V|IvbguXWrMkJfaXOv1x3?`VEhi@@VzIcUrY1@C z>A)8j7Tj*PQmGsn8NmPmBuO?lHWn2X{X9mkR+pETb2yyp>S~k8#OL$na=FD~(Q36k z9&d1PkRXWN-Q9tK0UXEk^71w}H^bp@XJ;pl<2^k+b#-+~dPpDM*VnhPu@MS|Foe+T z?5sp0NqEx1!9hnyhgz*}Zf@3UwZp^1I-O1|7Vqrrw70kC9x?)Fu~@CGt!ry*n8)L}zrU}jr~m*&qtTTsQ3xS~FlN2KzsI-5$66#3 zVHhSFjmClu!@Rw{EiNu5oH-eXYcv`@pAQZX55KiRl4M(3Tf!p#Mt;A4dwZLv>4a{^ z;pgY)xw*MmZEda3=VKTq{`F~^b~>HOpLG)D=jThM(!#>Rgzh&uNs>C9PN7hw41a!p zE-Nd;s;a88v$K6ZUo2`c7`nT=IUJ7NZg)5wsrHgs-{5Am830gHQc_S*kTTQj^$LYT zjLl{%6bg&Qa&~qm5{V#$LZMJ1kxWldV;GjH1`@)RN@ah4|Nj1dS65d$ zgF{0@2%$hA5PNV8!zBMPNkKp1GMQ{|Z%-?l9>YkS{D}=b8~Z%NF;?^o6Qy<*1rHx&>Y4f S+EAqc0000h@K~#90?VM>`Q^yv-Cp!TlLS#u;q976hF`yQt3S~=upd#YJ0|W&@ z6cn@-+xST7L#whVXr%>S6&ENiRf!g>v?$t&8y3*G1PaOzghCL)5+G!IA1;j;l1N&k z(%%24$;_E^&g7oV%)N7N5K^fWz`#rdP|3;3%GwqzSaA9BWwBVie*O9@SFVV~Vly){ zEiEmnRC?;vsnx4jFI>3L*w`2VP*YQL@#4jRfPjvUj+T~|fPerj7CUd=yw^7ln129B z)y+XcK`U3TM4?bnfj}St06IE492^|jY_?2{Mx%v?hr77An3|eG1$e@SdF3Dh09-CN zI5?O}rA9|bpF4LhHa1puA7f)RNK$e!4HZ(MxIddjBIJlsoz}3}NqboRr!61(zD=TZPq(~$>d-g1uOlGs$ zrKP1b8m+0RNpp_Dy#1i>-n~0x#tb5n2z~bS^vuuC*POl0n>UAqgveDI85t??42@p8 zbSaC)N=r*yvt~_AO^xQff|(GYc|4whfr0F^iHV6u?U6_%5{Wc^c@GbdoSYnQZ*R@H z1T#@Uo12^G=H`mUViXDm0I034)u_FL2M?B%l*m;^L_~y!hANcr?Ch+otJA1UFcSr| zpP%3M?b}mRQxg&rs;a7Ta&jyzEMD48EEfMcdv0!SrlzKHm3DS^3Wcv;z3SuRlbM;x zX0y>~G?hyIb4FqQ9w4o(td1W)e(2C40)Y?}6%`#FjmP6v_u+E685tP>faAxHH#aw{ zWsgRq1&(2C6qc8l&zUnvC=}Y+*)3bP?BkC=Mj~JGNEqgC4_Y7)czSxawzduo3}|a> zr=_LY+uN(|V`yl|U@#aAhUVPz^76WK=MGfP%*@oBA(#mSvZtqK`t<2677L5TayXpq z>}+>;cUkkbYuD=Q>!ngDR2Uu}R;Z<`tBb?oG&VN!`FyDGy8MUv2Z4}ErN@pP%gD&6 ztE(dtiBVBeDzXJ&VBR1I_z)jvq5$8uz)Tp>Z`y&s%$2G)?E#D;+~>;ID7#YQmV{?k zmdNYD`uSI)f{Jju8^xyZyWITA0vI3ok=7RG@;p8 zpGX-;mQRo;T}KNqQgj@xg~c9-+xAI#R2AoSuTIP(Ibw-KtuEsnujcsv`p@jg4Wnyb z2)+|1P8b*%Cz=Cm3s8(Q9hqPRshloArgts zpFbZH6H``J*3{IrbLUPLi$$SOpjHNhF*dn&$BrHG@$m|Wce3pK8oDo3zHsaM;WNck zO-LWC4xMU3+FO|a^W7RJYidel%;UD!^lwfe5C|LwtFNoOGc*Ev38#{Mx3K(z-Bink z4vq&;72$DOOW$?#a+)_N5F{P>a!@ejU}?Q!>2jGlWqJSroaUxa^Yip|b(=fd{}UGJ zKHEvfRpAc}GLPi6aNBVhtW+vZjoCsXPEjT-6p7-pQXQ>rYJaOoA`!g){(T!Zn;9Ab z03;GgTG5FswZ9tZ=?R8~8JiL;j7LZRf?7^unm9{|94ru~+K>4O3R9*2V@UkFwt5*Z#I z&SJ4vty)E)P&gdUy?giU?Cc~GiLS0LB;)7jhrwW6U0qXBQUCzCxw*Z)y}Nep0sz?C z+gDUnY}l~D(9qD|-yeFrmBC=h35*U_)fv{~&(wyfsJWB2aU_lxy)$1d5etTeQ%y(! zfDcxMK5lDGiHrdNOe2vGC+vX4ez;lr{qm%zI-}D+`!;zG9*0YbjOia7NR8QodGVG*nSO=i#h}s3>?*|7 z)ipUeIW{(y$z-~^y3*-%Ws(YF;EzXF7Dgtu4RtQIvqmK4dWMIG(`Yn4pI=f^5)u+p zR8-{U<>l$=DJO=(U_>Gj0D!~c`1|{Zg@pkCl9H03RwNRM!C;`WLIF9HWmv15somVs zK8-|{ee`vHH!6MiayJhEz_*uwTIJyb)k~$)+J^cct8V_@^$deXlV6<1=Gx3;hOdXp zL_Jm8Uln>H{rvTGbN~R_T3VZzum0w8*?-nVDpWEsG}Q34h11-`X&!lLM^{^${kUPa zmG%86jSWv*Mhm;x+C$S!q@TZz79Id#q;DWQgS^JB-MMCD0VENp(C0Z{uCDTRc~_bL zD)cKupGZ+D!AFlCQ7DwrGn7IU#=tZZxw)fVX|P&aS~@y9=I7^6nlx$CrcGgC zVQ4g3MYe#gt!-6R6%>mAfY#PlGMTKF08pM`t!}0^kwD<`cseE{DUJvP!o}A9`u%(J z?Pgu7zWr6=$WLWYLB5f`evl{K%+TnUdo|VdoY6`QbjN#trb3S)L0?v$LYOQV7AjMM zKp=Fq@X+)Ru_bUd#n=P@uy)bnae4v)h0${#ChHFfhE&L_t6yDED3rIicX@fanVH#& z6)V7PRkxK2V}Q%+HW)QuD0mdLcJ11PgoK9=ACk#r6bgkxp`fjpR4NsV#n6N*5{aOK zudgqiPWSNeShj3gU0ofU%?=C{8J7{d4l38TsF#mB8WnoJV14(_%n?7oJbNn0Q|Tgz$Ki+sg1)Yvjrqt< zePC!vB318Z2tr?1_ijVIgOxP^Kq8S8{CMH$M@*<`@+4hef1lxGeU%DcJ?`%ArKP2@ zv9a3P+A754W8jba#(;GXv0?>OUszZu6bcIp3aC_S zVPWC$@NjW)abRFzKtRCq<;$s5>f*(V_wCzPR8-X7-kz72H+}ka3kwTpXJD-lOS4Og>GND?rP z;hNv-x_W!jDAca?8+Eks3ia^%`hU7}D={d{d)uZ(&aM}4U0?a0Hx#%9KVG=;;NIY{ zfZf>8(cO(fqj#_0gva3yCnRqDe7{I6UNDQ+*!HxC-~Z{l4U_PSuWsA3&I84TeFFot zt*mEKrWO8l;Y#hV7j9i&^v?W@Oz4* z-`&^uzK>zY0kw`=$5f+PmsV#Y4JV#!%eM@1| zE(1M1)t&f5gDu>S>89qWzxL!L2ALV}TGuPS6 z>G_{fP5czW7r%n)dQN8#&u6aln{o#R05B*Jv|5=A3=Hu3d>5BL7CJQ(SyI0~p7`&u z(baGJiIloHTHC;p`o_8cq%k-+xV^pod8De3T%>}(Ly92G+s9m+nKy6VeC28<{x$&S bAH)9v>U+A;SU>`E00000NkvXXu0mjfr5!t( literal 3307 zcmV

5Q;P)D-$rnKtASBAx^2-+$lSQIVd zmf7WAVzk%967@R9vK-a>D<(*Q}5il!{hM+0s`*cyT{}43=9lVD3m}TxOnlRkB^U& zlar2)4gi2krQW)A%iG(#wY9aWsma^hTS-Z2;>3ynTpV(~b`+$a_VMvqym&DJfq)w7 z>goW1wzf7BiBwirCKPjUa9Fi!6`4#nFff1`BYsrNks}rb06=?tyRWaWrKM$1P|%et zS3*KUq+g?>qhn%XBK8yv1`}z>k@Hzl;Pd$|E-sCYjS&$MJv}|&efQnnyLZ2|S90Wt zqHyinwd(5X%*;$*U*EK}Gzx_xyBBw1VIg4gr_Vm7Gxl;_1_;=H}*jJRUlpIdf)maNzP~i(bd(3!{LO-y1KfuGp4MpY-3|Hbom)GW+WvgiGAqG`F{g3X3Uu5 z$B*-PJUAQ<04Oajm7THD($cW7Fp*AEQ_~YCPKcH7=;)x)XtMK1&L{%m;o-4u+qUTF z=*^oq7Z(>NB_)j=JNBcO@p!xu7}M9+A3U)D&3p~!{{8!|uCDR%@nvOY2n52?(sBeA z<$N_Ln3|fVq@)}^d{|vwJuomZC@2VxMoYh@y}dmyE)D>Yl9JNU&@gmknwpvm2Qm2N zo|l(5e*Ab2hht-764ITj|$m zX=&}+wQJX|T{7~?+1dH_?c30^_Ta&TTrO8hNl8YwG}z9LDTV zUtiy=SFeUHFGtR2WT=_?{P}ZRTie9MM45UcM~)6L_e5#kt4m)yiLwxj&qI?-R_?a1Eys{(n!5xvFVZ8nS z{R>4~j~&9RiC>%jM09XCLmj=3iupLt!k|!Go|sHUA(20C*z&z!U~$EB88|47h?9xK zUHu+nyt3nJ!JlO{F9!C!PrjEgUz(YjEnd8s$z*Qbx)q1RojZ390C3~R4OdrJC{z}U z6&xH)AQ1fg{Gh8^TU-78{pZb_7aAJc(b2(RFk)h29336g)6=!Jwe$1yMFeCQTT^=* zoxw2GH;{$$DK@0Jly7CB`5&O0$>a}nhUbgN8#K@R@E;#M)Zc&iH!?DsKYxCGeZ8`> za%5!Wv17-qt*rq78X6jF)~taltqKbZFI>2=W5*6-W8>YscN2-k(9qDNq$DgBJ9qBf z#Kgp%J9jE8D?fSiL{(KaK0e;e%uGaJ&z?O4&2zcj>({Rb2M1?oXV=x$?cTjRD=W*; z&=9h{G>ftpd33IsI4e`9wV?*uIsgDZpC6Nc<{tG4PEC!?>5E$* zHdaR$0I>JBV|S^Kw;VmF08;<}ESm28Eoqz-f5gTs#jaQi3JSu)!aO`YA|fIR3JNxD z+Vm*)m{`fd2|zvcD*#}!we7}VVp!~6G_t>Z`GZ-i)vH%KIy(0D_F^y?O-;>=j0`(F zyX@@j@bGX*fI^`_D^COhp{AyW!C;h^mmfKD1OR|UB8!WQ;c&Q}ogEsD_VDlk0F;!J zhzN){Dy3q2=w;Uscd3tKf;U2K_sJ9v>8R-!K0RLIKytbuzU%)y5fU%zb(Xj21 z*o~t6tA!8dQKkU^D7N-CMy76CL)z(Y5;ku~AP}$VT>tiDJou^2SE?M>%_Gbayi+zJ4QN=r7;)4v{l2msLXx+5s| z!1>51G!nHhU>$?SiVohW_~CwcN&3actB62IvMUw}g%TMV84?l_5fMS5P~6(UsRE8?D{1KUS?}+OC%DnUcIWWuI}aKm7bm+5fQ=X^9SdLl9Cda%caq1 zCMG6(_wF5d3J!-0e*{3Rz+l8yOb@s0x}mMrSWjPgIEU;Q7_)!Dw3z^a^LKKV%;;Ax z5C}?N&~l24UUj}!L?8&7S_73#u&|C;6$rKQ>R2h}r05Con6HLW0RSkYP@xN!oV%T~ zXJvp`CCuL5>gLAE`nt;c{=GM<%F1Q6)%IrQ<+U}{&5Z+v$<}tz114aOCkBlM0BCFA z1fc)5p8u?L_X>Zgt%uiin?Sx(@^}u}QIh{s^h-jlT}imPxv^NRii!$DLqiJ-3+cjQ z6TnzczoEUA48&zB0Km`BFEusQ!onghE-o`OGb$>|-Q8W10V^vjDwQg%!hZYqt;n}7 zu>vY8Dk6HsR!k4K>>978-rn^F^R6rb27{5U?F!4EPO%}~ep39~_Wu8tsI*hsSe%cu zn}L?jpUj413U;u+c8|e~+JsTJJKwoA2 zX3raOfBrm~OomQzxm@nM`4^~7B9R0F!S?Oj>2x}S!AMR{ zR#8!bep>|+6DuHM5vrI*qtRt$Wfc__!hWdiT7;!bmr9D(-i%0VtRL93+;#Su?CbYS zpG>oVKQe3X=vXt?YmBxo38g0P)<`J!-CFc>rvg;!J8P*o+{*g=0J zQz8NmAAvs_s%lTGtDrWY&ri#}IsM)E7^|Yv#poV^&QHY2$tgEC7lXk_uP2d|05#1` zb|z-RL(yj{9*_6&@maonIRL=V&rg_G6%`dlMMYRFwzjsGMx!+~HC?=Tan`I^v9YoK z{{E*w?=vvakn*MCxm5A2@UJO4QH7PHQ9M?@uOas$)y5X}UQ4{n8SPF^01y zO-Z`^$FrIj51*GqH+A)F&u`2v0RX?}-YO_BWpg;xDq3eZ9RWw|4_Jpmqs8j!Vsz&| zei*)NrOTG}?vtk6di2-g>CTg^YybdhIXC|L`x%SPE~~9>>*`cQAP%fqk4B=7Zr&bt z^dOhVn`-A!)7(h!Vf?Uqt%`(O+w!{O=Zv%6Os2h=xs{>u+1#7=s84Pd6}V5P#I4^P z92W(L!_5uGW&NgE4U1 z;Lru=bUIXu%IEV(QZfDE8nOGf(6f8@<32W}+QVWswzrz;kAaWq=`|ERTrRh=q0UH` zfce-43W(SAuIASrMEx-+B=S>SYVCa8+5OhsVC-O*D(he3)YJ!#Ok{}D1OPy4YO0Hi zOaC5H39I>Z2cl>K+$#nE>_|H7I$^T&`1gxVqr8^t!}v?8Dmv(N*9nuqlsj?&04#QI zv#B1F$?WOr5e^-PTcHyDdrJ7Sl>@u~?aNNXVjR&@o~B=%^4c0-U*Fc&*7s>Td_>X| pjQXlSIsZN;SXvhq6@7NK{{t-}^HI6FurB}r002ovPDHLkV1n+YRPF!( diff --git a/collects/redex/tests/bmps-macosx/var-not-in.png b/collects/redex/tests/bmps-macosx/var-not-in.png index 0b27baf53813efe057991c7bc89f91a0ce69bf4b..78df3d9573b29fd508ad2204176eea11ee574312 100644 GIT binary patch literal 4606 zcmW+)1ys{t8~%Yc5Ctg*C=F5~(m7yEQo2DJX=%_=1BJl|5s{FPZmCg{`UmDvdLXDE zp>%f%`dz=fbMAJ|cJA-J@B6&Z^Ss09>8M?yWTu25=!%9q$^e4M+`wlx7&+LLIca>s z+eLdVH5Bys-z&GhBpHIP)oGxVjhzC~D+4D^ z5IQ^ao0_h(30}nh74^Vi{^IfYzP`S#EpONS)Ko?}IS|atsLR)xnV6beS{m!?X)Xvc z#`%lT4`j)R`7PYPc{4k&HR!sKMLiz^(NR(1UMSc3L8P-LP1vfux_WbFX6uWojRqZ# z@bl?Yaw#b(XXnNBi6)!Yz(>UAH#bXFXga~8q@DIS2v)KS+yi{j7^P<_2l6x@K#8w56AOhcJ#xh>y2! zd%|HVCeP}1yfa^@si2@xj&EtPFg3l7p)kF@1bT2|)c@BeBk%iqM>+7F8SzB8Z7ZaOk@?sMxFD->dbw=FDjF^3<`n)7D&wFVoZ*p=aHLRr%3z}YG`uubZb_{b)d}o@7bY^wzl@S&%*_3axyXioJ?>y)si7Q&4acl z`s_5h_F7t(>(sCjcIlm$(t2+K;FOUjC$q}4#9aXt3=9qF5Ea!{t&(0-ZRzRhv9XjF zE=0MG6kppPtvlSD&OwCAei1YNHZ?UhF(KzXkVTdP0RQ^+>;3(GUS3`(d~q;GYfb)K z7lu;C+8X<`sA%4vvQQ~pPfu@V`^n>tNixXM*?HpY*BFAmpPwH<#>|YZv~7fDSti z4fVzD-rm)oB(Cmf9Himl+4*@1=?N_MqNU|TOG^t`3X7!2*7mk}qsO;8=RrrouCA`j zl$2Fgt=L!)G6I2kw#s_0D>^bVE$#F)L`+N!#vv;rDVf^n*VfQr%tt>qI%;NVX=-fz zWpwoG#00fMzN?E%WMt&lamdQ&o^UuEKDW3yqR)y5NiQCJG|^c5&0`NvB9Ukr7y?#C z`O$J8KWxqZ_teWF^SCuPFHia2y?a_(po?}c&d<+}l<1o3!HXrhE@BT~A4-LYh={Z; zQjL)K&w-FG(IGBUVC@R0uZW7Aj=$gv$x;YT?V6o@kNNv!f1wia(N#9Y$3Sj;P7s}>_GEA2|QEo6-2!-t^9uOc=4`f?P47v|g)^(3WA`bq9W6(2meVF{uF^Y?(68hx$B^cMjv}O%ArK4 zb`K8+dwW?F!{ooSD6`>4Y@Tn`h8*u4Vm@s>nx`Blkup4HCy1I?Dd~N@&3ys0B{Tjqx7jo^i;zP z(5=%zmbt$EU60!x45Ff+8L}y_J=f^Y|3$v-w~&$Hw;{MUDl^?frcMridK+ z+T>-Ur$+XL5AX{ee?}a07UuyyR57%bM;_iZtVW?wdYJBbo1SnDO9-Oly)Pmzj#8)(rXvyMs<;!5XS<>o z2eK!IhshupcXvO3e~{ga5GV{tIS$3?ijl@)0YaKQf6&6tPlq06S66#Id2$4x3mB4& zXO%LWTgYEEoEKyQ-0WH1O=Z9~L;pZ}1Lej_F_QC+f}4XwSxakm?o;xWD_0H<4opl; zQc_ZAkcx`$)6?OwJUm`BXYg@gAgh?ueFFnpdgww3?3>@kQZq7EmX@9zteN}y z?dImPm(Tndo}Tt{bF;9tjEfCE+>j6z?bKyrW_}}&rbW6qIEVq3=uNw0^Uhn@)Kp4F zh6x$NN$AGWWoKpW?CuUL#0uNwcf5NCheYf;BXhz|mVXlBfB+mG9DF>RY<*0PJlY?( z(S0q-13GSSadmaIV2FzrM@2;yc08Y!m6g@tKJMo3ez?D%Bz(TX)59ZVt|v()`l_p& z+sW~9UPTQaZ&72bY;A4r>$~%{)}hI3`YK1?z<{K<_+*Wp3L4#vG6k0>g}ekZ8cp*r zO~L(uV}NjIX=-u{XgExfNcklt#9!O&k*i~snX&JZ#x2%dXAE>bawR17a!@YKYzlEQ0`=)>mq2T-ub9#Xp}WHFm%;? zsWAN|r+s#MDzBh0yXul#Fl@b&Z45B2a6%Ix>_@*;K-f3!X(gQPqsmBYAw0HRV_~b)R=&w8h3kb%tz5c387!vk)b1H#Wxwxo^3<821u`-w?Q&3nqIx%sX z1IU_OzzTi9r26c$mE`j~SVIeo^89>XAnvZ3q;wTn^2?XfHwJ)c$=n#&UmeHsigreO zsK91Z1Wkd;j#t|xj&t+!3Y*m^StL*)9c0(gN#k>MoV$BvGUW_W1<|Ci<}Wjp~zxG5JX zRO>YM)?D$=5m%%)K#-@W=aW#dnVF?GH8tV!I{@&rt6LF+fj>v0QK3FQccZ(m#SzrQ zNtns@;Oo?EpkhWQCR6V*7{DDURCnraKpdd-XJ==OjEsPefqtp$>Z&D+$jG1%+(oEV zDou@y*cXBKq`RdPNwWdC;qxp0BV+j|ThJyqD}uYFv+L5A5~}YL6X5Ll4Gvd5;tk|G zmtjsw$<~&=%sTMsh11vJ;cIYsX=y2(kr8VLx6VmQvU772s8o*{fDJYG)A%Zc4mEd0 z{}&5K%qZ>BuTR9s#XX}5^!HcN7|Cg4#QV+zmhT0&cXV`gzBesL?y={_WV21!F^@)Z zX=%(P6EIlu0@eiT)Gqu;-2{=q27$9S@KiLm$@oo+CwVR zqNAlns;C$m7;tiO>hYxYhVIPal9TC9wv^+JVW2|gmaaiRE7&b0A|oFrjg6V`@D#PQ z$hPsavnwepM-c4i=jOJKPhY)y1&+U;AzqfBk2EzM|NNQq(^i^++tUqbg!?fkRk|^a+ma zXZX3i%tTNB>dhNrddlqVY%&OqMn^?OQL`aXitTs!_+GSQxmE5k#^uPPMbSHskdmDp zM`r&UX&+8c7khismoE*@gFv=FLQo{qPE{3KRpklTP>&B#D_9;bE;ThZ>KYo`dwX-f z&7v(4!16p#NFdzV8mqLtarKh!TFi`Zv;TuD>W+?%Ktc5NlYp6`VhZT{d%8PVSXkJf zDYXfF>h@29m{VWwH_k75LX5x`gN_%wdpGH%OVD5}rRim4RG2+;Gy9KOz5?U>_o+e! z55JTfb8v7}m{vD7G|YQT zgLt&zFb=F8-^$+pe%>=Mu6!gC3sO>m_OVEL&S=hQ=ZC{ItMc;m4SZGTVCOR> zAIW;pK>8o&eWmn{_C|DZ%<`r%YX=vXo_XJY6P&#K5T;^zbCdXN1626}IoXsku4im> zvbnCLL`{g1NFV^WMC(W2pQC64JaZ^+7bpk#CHSKD+ZyP8bZ~G%0=z&qVFl>cd+g@I z!q~(_@W!MJ1i6iljL?N<2?z>;nP_BBj9o@X23*O`&JLKGg#Ry6$0&OO+S$1zCx6he06uqjceMNz5KFeUi+@kBuL7dXJUl%aVdo1MMP>i>=;-Rp zF~0q)mm=d$#4GgzEBFnIbN9r38=`=M#w_zY4vu6>c}=wkkB^N>-o1P6c7kDvB6|HC z@@QwiH(+%v@7LMyL&cyy*v;Kz(4~n)cP}q$Dys9)gLmF!T{R4XCJ+Ql!bndaX=etE zLL6adXQ$Kjk_LHO-rKiA?(VB#hs}OWU;+39?am$vD2tVq^~k>Cfya*)iQBgm%=~_K zQ$WzR@eqM<4>;(ao}RI>12DR-tgNUdvhsvEkWWAO{i5`au<)Oyg2a%}&@W((jtbqr z4XnUy=5!nIWx$ZQ0BRBt0E9L^I?BGdB;)eE-WANvJXIHd=8pL&Y~McHTOI*m0G0@} zQ(#~qNN{P`=2UxZZ0tniqvRz@o8K>%k|`zbu7i9m#~-%@tb(|s8NXLlR2Ul>adL6_ z6va1C@In79f2iC7o!`w8TTZoGg&4d6W5;o%RxiTLL?MD~&%fKHxkj6b7R29

Hh%D CbNMC! literal 5086 zcmX|FcQ}=Q*gy7>bx2nB$c_-Qcjhr7gtF2gGP8c!*<=>k8QClQSVhRn7P5{V%Fc-Q z?!DgYef~Jtxz2T-=lgu``*VNBH(U>Wo9q(9B?JONrlGE4fI#3_!gppQE_|k&-(f}| zF6U{eC>naEZKeCj7_MKmWzs9Z8n^hAD55%EI(gmxYYWCeka#_?_MJ|g*0YB-g@@B2 zmx>?fxYl94b--_X$3$w~M9P+D4=BqRACbPrICWA&Y^?nGpP3l-I1!iEt*6`4 zSFT*SbLWnhmKL!KRB;EcqocV-cY9~&8#}n$v(3dppU1~(gpODG-x-(RUteFxLHzN3 zX=j%o6N5H2{l47$21;gec5>SpWl#KgqV)6*|3EEL}@<>TY?9(>~b!pFzw*N>)0 z4h|)Gd0eJYuByhyseu8snwnabt*)*v8ciP5u4imag!oWYB!B4DtsWEb z@bJ)KQB6$W#>TkfZES2{iyR*H0j;M3Os+wpgZR5|Hn4+o|23p_H#IG-)AuS>&IEKprlhkH=g7Bj6?u88tf(xO!}0O) zqN1Vz0qn09pCh!Ys%lj(ylr~A#fukpwY7&?;-&)Q$9t=$0yLPV=aLTw^eK4_)ckd4 z71uU40K^ft5kF+}M%Gi-@fhVcd_}snkZ?1f4}eR*P`hT@st>S9#K$J5g-!v$HGl zLnlq~LX@DXe*0_sXmkwJGqy`qT-?LMW46+UDCJCEo~ZF%QqoPobKerh%6MP7i{0g3 ze&e#G9nYXC&Ny}0U}|dWhqtk@g9RVBcnwx_Njs zHZ-syhlhr6T=8)g{rpa2HNjR^<{(BlavmX&P|h>@wQsj2+FnVQN#LK69CFk@_V zv@b>U(c9*v_;>?7Jyb%Ed4mgAA6r6?C($?hOWww2W~T$`(w;${J!@-^D^;;vczAd{ zwjzu$Z)v}OKR;^>r{=wIR7bA(y1@`n*E!)Jpl8qV9j&dE@(enkj!#TTh>Kf?9PICZ ziJ}+v&17I;_+SWa-uSKapMa*8R&-PpPoi#%Er;q?+D;#)U}|22T+8F7$V7u&_2boD z947oXz0aOLJ#j1ZRjD`Me(ipGa#C@X(NjuFs$=Tc*4AI8S2n(Kt>xvhSrvLb4)*p} zQ!=bIM-Ex-6=iD#@JL?fN z7uj3sCm|zCV*TAOF=vkP)aR^z|6W;NzcMGsx_g;CASx;fCe8Pywss$sjF_RpYcD@E zv@2ATs&I9p{K541@04zM!y_ZrHeKXqX44I>tJ^=CXg!DqGh~%@f7*;>GT8lu)C>u^Z*N-1RzD-F^NQ9-`3Xl=@UCUJ8u7AZ?CJnJCmp#X;8brYS`=4)JCtpmDcl<-r-@F;arW2<3T@5 zxwB&33>i}$o&L_wyp|Ra(O4HoDK{QIKFtoazCL9_PogEN_sCK)~Tbqn75VC0eSWxh2y7n1h9R^Jmwe&TKzqYp4SI%#&$OvZg{{8z?Q&aZiB?0%K zGR(}(CMIC)-48dv!ya#= zIK{-=X6l`}bu%zf-#`Kqa|?@XMX7Xjo`HnJ zTVhrhqr(31(WB2@^nh#N?!DdJ&CN|xGO`A9M_^F6%FCUeJmH;kVXL2MJ#q} zbMv}+y+13mCA#%Ryvxt=QYaAg7+QDf(xr;~p!Os_5k|##`%^><8X6jEYiSUAMn)m5 z-Bk~Jq3yv++0D&=VNi~JU%I({#9(A1JEdG#wC~(W2=nje*zv?fMUg&xwgv8qCi0=9 z#5A4b4;RTj>|q@8*}4{S$B=YIY=U>tQUjY~XosPY-A?F+MH@1;suh@6DSD z5FbkX@W@C!gpBVW)XIA%6*o7rO+^%b&%nU7gr0Ab>FA@qy`W`u$UyrbwUZn$`;=rt5vA_H@C zbGy5{!HU5rH8r(m2$vfw{t6|20~nje#*;76SBKJo#0W@e=An;7ac|!ug^sqSiLh)r zD6e!@d}(B0`3~~&k5)g>;~`-SW8>S`68@f@ZO^s(K||oFeSO;aid0lo^FMbMJ4yb0 zw+C;isj1XavvY(#_w@7>ri*H6kpm2okwuS=8s51x0(weBNT`Iv&(H5kt$F))L4JOI zQ&STL!(je`(lAY&2gg3&B1+wP9z7#kZiH8q`# zqw}^i1T)yzx7is!Q9>3ySlQnvb>Cgm~;>i{rtqyG2^Cva%JVt{`$xpK{Goi zCl(Znm7Dv;`I(m+ImkEy@mA8Aoxxex*qHXbP)b^QC^MOtkB@<#K3w44!dBKi87||R z=@@ufF0Et`3CF3A#6pBzl?SB%Ou3CnikzGrP!TDia!IlYp#k{0sRmbYkeg)|O&(iQ zAuBdP&M4wOHnu?G9Xc+2Hs&l_J;BO$O~NrM2p7OVZZ0l?MhnZ!%iG)c4Gl+UXJ@CU zPfrf)`I1s$&fmUW1E09GgkPgF^#>$BJiKSAC&5%88Jt6P_1^dDM}B_~jI;H^%B64J zx+RzSz{n`Cyj-ZtgpY$GC_|E(-@oh2muuqUG%O)F|E*i;5%;L6eA1|IYU1YN+WKD2 zEi3!?Tehv7#%zX$OqO$#MC2hGHdAQQi&JVu%MZVzD!_txds1FqDGj6>fHRHUJg8 zyRL=?czB(xywl6obY2>-Y^eUL?l_Uz(fE!#NdlD4&> z_o|!fG5-r!6ft+D@A0m`zklx=q3Z7rL_|c0HsCM_48}%A1b$5xCMG=D?MVEZ5@sgQ^qCl>TPe|C2Z)+#S(%D&(FW%6U zLoVWI5)Q{RmZ-Rx#zP<7r2g(;yVmqRW@jtv>krM%&4HoljJP8IcRyj0B4{lquc^rg z)CjmBM9H+-`vANf1W^K~onznqH3IF=DSd}q)6&w?zyud(d%BVrlt_F%?Gk_WaN$dM zNt%NE{KX|D_y|vLZ)otR8gC>iA6sCz9VY`C_x{G(nhBWbs}hdd z>gs?Bh`tajd=EG25tgGL^nK+r=Pxysm0b^N4~vZrodp&*(9j?zN5TYx0|=+1Pn?;V z0e{!*a|9wNCjRdt|ES|%x(YW52?;?A3JXKp+y8X`Ij-@+K*0J6i~LJ-Gqaz+e*HsU z#6_TEh-Hv-*82GPU3l~Kzmx&pKk?h;2Nbv#AJ{nfQ!U<`wB+ij(K|UkU09UBbcn0@ z_?&{ZgSN6G-aeW=~cQk7^2tEa~3{sSz zk8l6rKu|#7>C>kGes#{_BBNpe%A5Fj2o!)Za4T>$af@-_(cP;N(rJi zYje|qgoLENti@~3j)*7}TvxkUTwL6@P>RLXOg}JsRNnMguaY3@ow0A2 zhe}FHtgWrpVwssPU%pIBdvq}I;JwHi`!YZ#DKYUHI!zLC+0v4&g@r}Euv)=LGX|3g zxmQdKZXu(6S}gs1RuSQA;~Qrn{jDdf*scWDTTh$!w2UKMwM?7g+I zp@hn9Y)sY6dleFrZB0eP+sS8L7pxEKW<^9s_QE-g>M$I=5Fx^XulYwNKCa>B(u`tilFSdPO)5LZG-y;LtYLzhp`|S&s;*giCt3|oE zLR8qnxU}c(Kv+~(R;CKKwXwl7o-2RQ>S$#Zmze1G=l23syz-g3HW5zx=K`Xf*4E6= z3#2-h-*`w_@EOobxL}gW$jF5I?W(z6CYXWeG)0gnkA|!-53T=CwGf zvVy~Cp%)+YgpG;9N@BuY$UQ%eW$WnP Date: Wed, 1 Dec 2010 13:10:54 -0600 Subject: [PATCH 249/255] Deletes incorrect comment. --- collects/redex/private/rg.rkt | 20 ++++++++------------ 1 file changed, 8 insertions(+), 12 deletions(-) diff --git a/collects/redex/private/rg.rkt b/collects/redex/private/rg.rkt index f0124eea40..94d1812096 100644 --- a/collects/redex/private/rg.rkt +++ b/collects/redex/private/rg.rkt @@ -284,18 +284,14 @@ ; ; Patterns like (in-hole C_1 p) require constructing both an unfilled context ; (exposed via the C_1 binding) and a filled context (exposed as the result). - ; These terms can be constructed by fist generating the unfilled context then - ; constructing the filled one from it, via something like `plug', but - ; 1. the repeated plugging required for patterns like - ; (in-hole (in-hole (in-hole C_1 C_2) C_3) C_4) - ; can be expensive (since it grows with the size of the output, not the - ; size of the pattern), and - ; 2. care must be taken to avoid filling holes generated within `in-hole' patterns - ; (and to avoid exposing the dreaded `the-not-hole'). - ; Instead, generators construct the filled and unfilled contexts simultaneously, - ; taking multiple fillers as input (one of which can be `hole') and producing - ; multiple terms as output. As an optimization, generators produce singleton - ; lists when the constructed term contained no fillable position. + ; These terms can be constructed by first generating the unfilled context then + ; constructing the filled one from it, via something like `plug', but care must + ; be taken to avoid filling holes generated within `in-hole' patterns (and to + ; avoid exposing the dreaded `the-not-hole' term). Instead, generators construct + ; the filled and unfilled contexts simultaneously, taking multiple fillers as + ; input (one of which can be `hole') and producing multiple terms as output. + ; As an optimization, generators produce singleton lists when the constructed term + ; contained no fillable position. (let recur ([pat pat]) (match pat [`number (unfilled-generator/attempts (λ (a) ((next-number-decision) a)))] From 6fd3eea815657ebbd0e284bbc032bfd47843c156 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Wed, 1 Dec 2010 13:12:20 -0600 Subject: [PATCH 250/255] Disables randomized tests (of the randomized tests). The runtime is too long and variable to work well in DrDr. --- collects/redex/examples/delim-cont/randomized-tests-test.rkt | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/collects/redex/examples/delim-cont/randomized-tests-test.rkt b/collects/redex/examples/delim-cont/randomized-tests-test.rkt index a55b39a6bf..54c6193087 100644 --- a/collects/redex/examples/delim-cont/randomized-tests-test.rkt +++ b/collects/redex/examples/delim-cont/randomized-tests-test.rkt @@ -142,6 +142,4 @@ (let ([test-number 1]) (redex-check grammar p (transformation-preserves-meaning? (term p)) #:prepare fix-prog - #:source :-> . kw-args))) - -(time (test-transformation/randomized #:attempts 1 #:attempt-size (const 3))) \ No newline at end of file + #:source :-> . kw-args))) \ No newline at end of file From fad4771167437bc86947baa4fa4f5e7a97808254 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Thu, 2 Dec 2010 10:44:47 -0600 Subject: [PATCH 251/255] Fixes a bug in the cap on REPL history --- collects/drracket/private/rep.rkt | 12 ++---------- 1 file changed, 2 insertions(+), 10 deletions(-) diff --git a/collects/drracket/private/rep.rkt b/collects/drracket/private/rep.rkt index ccc32f1945..72b11845f3 100644 --- a/collects/drracket/private/rep.rkt +++ b/collects/drracket/private/rep.rkt @@ -1769,18 +1769,10 @@ TODO (define/private (get-previous-exprs) (append global-previous-exprs local-previous-exprs)) (define/private (add-to-previous-exprs snips) - (let* ([new-previous-exprs - (let* ([trimmed-previous-exprs (trim-previous-exprs local-previous-exprs)]) - (let loop ([l trimmed-previous-exprs]) - (if (null? l) - (list snips) - (cons (car l) (loop (cdr l))))))]) - (set! local-previous-exprs new-previous-exprs))) + (set! local-previous-exprs (append local-previous-exprs (list snips)))) (define/private (trim-previous-exprs lst) - (if ((length lst). >= . console-max-save-previous-exprs) - (cdr lst) - lst)) + (take-right lst (min (length lst) console-max-save-previous-exprs))) (define/private (save-interaction-in-history start end) (split-snip start) From ab82bc04eb3d7a658c110befdb95636dba8d4c12 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Thu, 2 Dec 2010 11:19:46 -0600 Subject: [PATCH 252/255] Cleans up REPL history preference for (some?) old versions --- collects/drracket/private/main.rkt | 28 +++++++++++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) diff --git a/collects/drracket/private/main.rkt b/collects/drracket/private/main.rkt index b8bfe6096a..1f02f3335e 100644 --- a/collects/drracket/private/main.rkt +++ b/collects/drracket/private/main.rkt @@ -6,8 +6,10 @@ mred framework mzlib/class - mzlib/list + racket/list racket/path + racket/file + racket/dict browser/external setup/plt-installer) @@ -453,6 +455,30 @@ (run-installer filename) #f)) +;; trim old console-previous-exprs preferences to compenstate +;; for a bug that let it grow without bound +(let* ([max-len 30] + [trim (λ (exprs save) + (when (list? exprs) + (let ([len (length exprs)]) + (when (> len max-len) + (save (drop exprs (- len max-len)))))))]) + (let ([framework-prefs (get-preference 'plt:framework-prefs)]) + (when (and (list? framework-prefs) + (andmap pair? framework-prefs)) + (let ([exprs-pref (assq 'drscheme:console-previous-exprs framework-prefs)]) + (when exprs-pref + (trim (second exprs-pref) + (λ (trimmed) + (put-preferences (list 'plt:framework-prefs) + (list (dict-set framework-prefs 'drscheme:console-previous-exprs (list trimmed))) + void))))))) + (trim (get-preference 'plt:framework-pref:drscheme:console-previous-exprs) + (λ (trimmed) + (put-preferences (list 'plt:framework-pref:drscheme:console-previous-exprs) + (list trimmed) + void)))) + (drracket:tools:load/invoke-all-tools (λ () (void)) (λ () From 5bb45d787f42255cfcf459a2e7756a6cf77f93e5 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Thu, 2 Dec 2010 14:18:26 -0600 Subject: [PATCH 253/255] Caps REPL history using string length rather than entry count --- collects/drracket/private/rep.rkt | 51 +++++++++++++++++++------------ 1 file changed, 32 insertions(+), 19 deletions(-) diff --git a/collects/drracket/private/rep.rkt b/collects/drracket/private/rep.rkt index 72b11845f3..a71ee27ba5 100644 --- a/collects/drracket/private/rep.rkt +++ b/collects/drracket/private/rep.rkt @@ -437,7 +437,6 @@ TODO (define-struct sexp (left right prompt)) - (define console-max-save-previous-exprs 30) (let* ([list-of? (λ (p?) (λ (l) (and (list? l) @@ -449,25 +448,24 @@ TODO 'drracket:console-previous-exprs null list-of-lists-of-snip/strings?)) - (let ([marshall - (λ (lls) - (map (λ (ls) - (list - (apply - string-append - (reverse - (map (λ (s) - (cond - [(is-a? s string-snip%) - (send s get-text 0 (send s get-count))] - [(string? s) s] - [else "'non-string-snip"])) - ls))))) - lls))] - [unmarshall (λ (x) x)]) + (define (marshall-previous-exprs lls) + (map (λ (ls) + (list + (apply + string-append + (reverse + (map (λ (s) + (cond + [(is-a? s string-snip%) + (send s get-text 0 (send s get-count))] + [(string? s) s] + [else "'non-string-snip"])) + ls))))) + lls)) + (let ([unmarshall (λ (x) x)]) (preferences:set-un/marshall 'drracket:console-previous-exprs - marshall unmarshall)) + marshall-previous-exprs unmarshall)) (define color? ((get-display-depth) . > . 8)) @@ -1771,8 +1769,23 @@ TODO (define/private (add-to-previous-exprs snips) (set! local-previous-exprs (append local-previous-exprs (list snips)))) + ; list-of-lists-of-snip/strings? -> list-of-lists-of-snip/strings? (define/private (trim-previous-exprs lst) - (take-right lst (min (length lst) console-max-save-previous-exprs))) + (define max-size 10000) + (define (expr-size expr) + (for/fold ([s 0]) ([e expr]) (+ s (string-length e)))) + (define within-bound + (let loop ([marshalled (reverse (marshall-previous-exprs lst))] + [keep 0] + [sum 0]) + (if (empty? marshalled) + keep + (let* ([size (expr-size (first marshalled))] + [w/another (+ size sum)]) + (if (> w/another max-size) + keep + (loop (rest marshalled) (add1 keep) w/another)))))) + (take-right lst within-bound)) (define/private (save-interaction-in-history start end) (split-snip start) From fbd7bdff5454465e2df0f99defdb64a304c1a135 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Thu, 2 Dec 2010 15:56:08 -0600 Subject: [PATCH 254/255] Adds an indicator that shows when framework prefs are being written. Performance grinds to a halt when the preference file is too large or written too often. Hopefully the indicator will help us identify this phenonmenon. --- collects/framework/preferences.rkt | 93 +++++++++++++++++++++------- collects/framework/private/frame.rkt | 61 +++++++++++++++++- 2 files changed, 127 insertions(+), 27 deletions(-) diff --git a/collects/framework/preferences.rkt b/collects/framework/preferences.rkt index 9c74cff455..ad4a248277 100644 --- a/collects/framework/preferences.rkt +++ b/collects/framework/preferences.rkt @@ -132,31 +132,58 @@ the state transitions / contracts are: ;; set : symbol any -> void ;; updates the preference ;; exported - (define (multi-set ps values) - (for-each - (λ (p value) - (cond - [(pref-default-set? p) - (let ([default (hash-ref defaults p)]) - (unless ((default-checker default) value) - (error 'preferences:set - "tried to set preference ~e to ~e but it does not meet test from `preferences:set-default'" - p value)) - (check-callbacks p value) - (hash-set! preferences p value))] - [(not (pref-default-set? p)) - (raise-unknown-preference-error - 'preferences:set "tried to set the preference ~e to ~e, but no default is set" - p - value)])) - ps values) - ((preferences:low-level-put-preferences) - (map add-pref-prefix ps) - (map (λ (p value) (marshall-pref p value)) - ps - values)) - (void)) + (dynamic-wind + (λ () + (call-pref-save-callbacks #t)) + (λ () + (for-each + (λ (p value) + (cond + [(pref-default-set? p) + (let ([default (hash-ref defaults p)]) + (unless ((default-checker default) value) + (error 'preferences:set + "tried to set preference ~e to ~e but it does not meet test from `preferences:set-default'" + p value)) + (check-callbacks p value) + (hash-set! preferences p value))] + [(not (pref-default-set? p)) + (raise-unknown-preference-error + 'preferences:set "tried to set the preference ~e to ~e, but no default is set" + p + value)])) + ps values) + ((preferences:low-level-put-preferences) + (map add-pref-prefix ps) + (map (λ (p value) (marshall-pref p value)) + ps + values)) + (void)) + (λ () + (call-pref-save-callbacks #f)))) + +(define pref-save-callbacks '()) + +(define (preferences:register-save-callback f) + (define key (gensym)) + (set! pref-save-callbacks (cons (list key f) pref-save-callbacks)) + key) + +(define (preferences:unregister-save-callback k) + (set! pref-save-callbacks + (let loop ([callbacks pref-save-callbacks]) + (cond + [(null? callbacks) '()] + [else + (let ([cb (car callbacks)]) + (if (eq? (list-ref cb 0) k) + (cdr callbacks) + (cons cb (loop (cdr callbacks)))))])))) + +(define (call-pref-save-callbacks b) + (for ([cb (in-list pref-save-callbacks)]) + ((list-ref cb 1) b))) (define (raise-unknown-preference-error sym fmt . args) (raise (exn:make-unknown-preference @@ -437,6 +464,24 @@ the state transitions / contracts are: @{@scheme[(preferences:restore-defaults)] restores the users' configuration to the default preferences.}) + (proc-doc/names + preferences:register-save-callback + (-> (-> boolean? any) symbol?) + (callback) + @{Registers @racket[callback] to run twice for each call to @racket[preferences:set]---once + before the preferences file is written, with @racket[#t], and once after it is written, with + @racket[#f}. Registration returns a key for use with @racket{preferences:unregister-save-callback}. + Caveats: + @itemize{@item{The callback occurs on whichever thread happened to call @racket[preferences:set].} + @item{Pre- and post-write notifications are not necessarily paired; unregistration + may cancel the post-write notification before it occurs.}}}) + + (proc-doc/names + preferences:unregister-save-callback + (-> symbol? void?) + (key) + @{Unregisters the save callback associated with @racket{key}.}) + (proc-doc/names exn:make-unknown-preference (string? continuation-mark-set? . -> . exn:unknown-preference?) diff --git a/collects/framework/private/frame.rkt b/collects/framework/private/frame.rkt index 0e9fa3d2d9..c42b2d8954 100644 --- a/collects/framework/private/frame.rkt +++ b/collects/framework/private/frame.rkt @@ -560,6 +560,7 @@ (λ (l) (if (memq outer-info-panel l) (begin (unregister-collecting-blit gc-canvas) + (unregister-pref-save-callback) (list rest-panel)) l)))] [else @@ -569,6 +570,7 @@ l (begin (register-gc-blit) + (register-pref-save-callback) (list rest-panel outer-info-panel)))))])) [define close-panel-callback @@ -580,6 +582,7 @@ (define/augment (on-close) (unregister-collecting-blit gc-canvas) + (unregister-pref-save-callback) (close-panel-callback) (memory-cleanup) (inner (void) on-close)) @@ -637,6 +640,12 @@ [(<= n 99) (format "0~a" n)] [else (number->string n)])) + (define pref-save-canvas #f) + (when checkout-or-nightly? + (set! pref-save-canvas (new pref-save-canvas% [parent (get-info-panel)]))) + + [define lock-canvas (make-object lock-canvas% (get-info-panel))] + ; only for checkouts and nightly build users (when show-memory-text? (let* ([panel (new horizontal-panel% @@ -657,7 +666,6 @@ (set! memory-canvases (remq ec memory-canvases)))) (send panel stretchable-width #f))) - [define lock-canvas (make-object lock-canvas% (get-info-panel))] [define gc-canvas (make-object bday-click-canvas% (get-info-panel) '(border))] (define/private (register-gc-blit) (let ([onb (icon:get-gc-on-bitmap)] @@ -670,6 +678,25 @@ (send onb get-height) onb offb)))) + (define pref-save-callback-registration #f) + (inherit get-eventspace) + (define/private (register-pref-save-callback) + (when pref-save-canvas + (set! pref-save-callback-registration + (preferences:register-save-callback + (λ (start?) + (cond + [(eq? (current-thread) (eventspace-handler-thread (get-eventspace))) + (send pref-save-canvas set-on? start?)] + [else + (queue-callback + (λ () + (send pref-save-canvas set-on? start?)))])))))) + (define/private (unregister-pref-save-callback) + (when pref-save-callback-registration + (preferences:unregister-save-callback pref-save-callback-registration))) + (register-pref-save-callback) + (unless (preferences:get 'framework:show-status-line) (send super-root change-children (λ (l) @@ -2415,14 +2442,16 @@ (define/override (get-editor%) (text:searching-mixin (super get-editor%))) (super-new))) -(define memory-canvases '()) -(define show-memory-text? +(define checkout-or-nightly? (or (with-handlers ([exn:fail:filesystem? (λ (x) #f)]) (directory-exists? (collection-path "repo-time-stamp"))) (with-handlers ([exn:fail:filesystem? (λ (x) #f)]) (let ([fw (collection-path "framework")]) (directory-exists? (build-path fw 'up 'up ".git")))))) +(define memory-canvases '()) +(define show-memory-text? checkout-or-nightly?) + (define bday-click-canvas% (class canvas% (define/override (on-event evt) @@ -2434,6 +2463,32 @@ [else (super on-event evt)])) (super-new))) +(define pref-save-canvas% + (class canvas% + (define on? #f) + (define indicator "P") + (define/override (on-paint) + (cond + [on? + (let-values ([(cw ch) (get-client-size)]) + (send (get-dc) draw-text indicator + (- (/ cw 2) (/ indicator-width 2)) + (- (/ ch 2) (/ indicator-height 2))))])) + (define/public (set-on? new-on?) + (set! on? new-on?) + (send (get-dc) erase) + (on-paint) + (flush)) + + (inherit get-dc flush get-client-size min-width) + (super-new [stretchable-width #f] + [style '(transparent)]) + + (define-values (indicator-width indicator-height) + (let-values ([(tw th _1 _2) (send (get-dc) get-text-extent indicator)]) + (values tw th))) + (min-width (+ (inexact->exact (ceiling indicator-width)) 4)))) + (define basic% (register-group-mixin (basic-mixin frame%))) (define size-pref% (size-pref-mixin basic%)) (define info% (info-mixin basic%)) From 5f0430a5abcae4ae69612923e755759a05174a54 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Thu, 2 Dec 2010 19:26:24 -0600 Subject: [PATCH 255/255] Fixes doc typos --- collects/framework/preferences.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/framework/preferences.rkt b/collects/framework/preferences.rkt index ad4a248277..8f5fd3d034 100644 --- a/collects/framework/preferences.rkt +++ b/collects/framework/preferences.rkt @@ -470,7 +470,7 @@ the state transitions / contracts are: (callback) @{Registers @racket[callback] to run twice for each call to @racket[preferences:set]---once before the preferences file is written, with @racket[#t], and once after it is written, with - @racket[#f}. Registration returns a key for use with @racket{preferences:unregister-save-callback}. + @racket[#f]. Registration returns a key for use with @racket[preferences:unregister-save-callback]. Caveats: @itemize{@item{The callback occurs on whichever thread happened to call @racket[preferences:set].} @item{Pre- and post-write notifications are not necessarily paired; unregistration @@ -480,7 +480,7 @@ the state transitions / contracts are: preferences:unregister-save-callback (-> symbol? void?) (key) - @{Unregisters the save callback associated with @racket{key}.}) + @{Unregisters the save callback associated with @racket[key].}) (proc-doc/names exn:make-unknown-preference