From 3407b2e73f94b87cff05b75eb91f2837d0a11877 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 19 Oct 2012 13:32:03 -0600 Subject: [PATCH 001/221] more clean-up for `even?'/`odd?' change Along the same lines as 44078a1f01. --- src/racket/src/number.c | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/racket/src/number.c b/src/racket/src/number.c index d7f26ac72c..fec2172089 100644 --- a/src/racket/src/number.c +++ b/src/racket/src/number.c @@ -1497,9 +1497,7 @@ Scheme_Object *odd_p_error(int argc, Scheme_Object *argv[]) Scheme_Object * scheme_odd_p (int argc, Scheme_Object *argv[]) -#ifdef MZ_USE_FUTURES XFORM_SKIP_PROC -#endif { Scheme_Object *v = argv[0]; @@ -1533,9 +1531,7 @@ Scheme_Object *even_p_error(int argc, Scheme_Object *argv[]) Scheme_Object * scheme_even_p (int argc, Scheme_Object *argv[]) -#ifdef MZ_USE_FUTURES XFORM_SKIP_PROC -#endif { Scheme_Object *v = argv[0]; From 70fee17ef9cde98e868ddb67f91706d64c28c0f9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 20 Oct 2012 09:34:37 -0600 Subject: [PATCH 002/221] fix mismanagement of temporary print buffer Closes PR 13199 Merge to v5.3.1 --- src/racket/src/print.c | 27 ++++++++++++++++++++------- 1 file changed, 20 insertions(+), 7 deletions(-) diff --git a/src/racket/src/print.c b/src/racket/src/print.c index 6f6a5d0efb..ef6ceb1459 100644 --- a/src/racket/src/print.c +++ b/src/racket/src/print.c @@ -124,7 +124,7 @@ static void print_vector(Scheme_Object *vec, int notdisplay, int compact, static void print_char(Scheme_Object *chobj, int notdisplay, PrintParams *pp); static char *print_to_string(Scheme_Object *obj, intptr_t * volatile len, int write, Scheme_Object *port, intptr_t maxl, - Scheme_Object *qq_depth); + Scheme_Object *qq_depth, int *_release_to_quick); static void custom_write_struct(Scheme_Object *s, Scheme_Hash_Table *ht, Scheme_Marshal_Tables *mt, @@ -384,7 +384,7 @@ static void *print_to_string_k(void) p->ku.k.p2 = NULL; p->ku.k.p3 = NULL; - return (void *)print_to_string(obj, len, iswrite, NULL, maxl, qq_depth); + return (void *)print_to_string(obj, len, iswrite, NULL, maxl, qq_depth, NULL); } char *scheme_write_to_string_w_max(Scheme_Object *obj, intptr_t *len, intptr_t maxl) @@ -956,7 +956,7 @@ static char * print_to_string(Scheme_Object *obj, intptr_t * volatile len, int write, Scheme_Object *port, intptr_t maxl, - Scheme_Object *qq_depth) + Scheme_Object *qq_depth, int *_release_to_quick) { Scheme_Hash_Table *ht; Scheme_Hash_Table *uq_ht; @@ -1111,8 +1111,14 @@ print_to_string(Scheme_Object *obj, params.inspector = NULL; - if (port && !quick_print_buffer) - quick_print_buffer = ca; + if (_release_to_quick) { + *_release_to_quick = 0; + if (params.print_buffer != ca) { + if (!quick_print_buffer) + quick_print_buffer = ca; + } else + *_release_to_quick = 1; + } return params.print_buffer; } @@ -1124,6 +1130,7 @@ print_to_port(char *name, Scheme_Object *obj, Scheme_Object *port, int notdispla Scheme_Output_Port *op; char *str; intptr_t len; + int rel; op = scheme_output_port_record(port); if (op->closed) @@ -1131,9 +1138,12 @@ print_to_port(char *name, Scheme_Object *obj, Scheme_Object *port, int notdispla " port: %V", name, port); - str = print_to_string(obj, &len, notdisplay, port, maxl, qq_depth); + str = print_to_string(obj, &len, notdisplay, port, maxl, qq_depth, &rel); scheme_write_byte_string(str, len, port); + + if (rel && !quick_print_buffer) + quick_print_buffer = str; } static void print_this_string(PrintParams *pp, const char *str, int offset, int autolen) @@ -2850,10 +2860,13 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, if (pp->print_syntax) { intptr_t slen; char *str; + int rel; print_utf8_string(pp, " ", 0, 1); str = print_to_string(scheme_syntax_to_datum((Scheme_Object *)stx, 0, NULL), - &slen, 1, NULL, pp->print_syntax, NULL); + &slen, 1, NULL, pp->print_syntax, NULL, &rel); print_utf8_string(pp, str, 0, slen); + if (rel && !quick_print_buffer) + quick_print_buffer = str; } print_utf8_string(pp, ">", 0, 1); } else { From 71a59cf653761c6134bee4a6c6229492bff738fa Mon Sep 17 00:00:00 2001 From: Stephen Bloch Date: Sat, 20 Oct 2012 13:31:00 -0400 Subject: [PATCH 003/221] Changed "right" error messages to match new actual error messages. --- .../tests/tiles-error-tests.rkt | 32 +++++++++---------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/collects/picturing-programs/tests/tiles-error-tests.rkt b/collects/picturing-programs/tests/tiles-error-tests.rkt index f5f98274ac..a488f15014 100644 --- a/collects/picturing-programs/tests/tiles-error-tests.rkt +++ b/collects/picturing-programs/tests/tiles-error-tests.rkt @@ -4,34 +4,34 @@ (require picturing-programs) (check-error (reflect-horiz 17) - "reflect-horiz: expected as first argument, given: 17") + "reflect-horiz: expected as first argument, given 17") (check-error (reflect-vert "hello") - "reflect-vert: expected as first argument, given: \"hello\"") + "reflect-vert: expected as first argument, given \"hello\"") (check-error (reflect-main-diag true) - "reflect-main-diag: expected as first argument, given: true") + "reflect-main-diag: expected as first argument, given true") (check-error (reflect-other-diag false) - "reflect-other-diag: expected as first argument, given: false") + "reflect-other-diag: expected as first argument, given false") (check-error (flip-main 'blue) - "flip-main: expected as first argument, given: 'blue") + "flip-main: expected as first argument, given 'blue") (check-error (flip-other "snark") - "flip-other: expected as first argument, given: \"snark\"") + "flip-other: expected as first argument, given \"snark\"") (check-error (crop-left pic:hacker 50) - "crop-left: expected as second argument, given: 50") + "crop-left: expected as second argument, given 50") (check-error (crop-right pic:bloch 100) - "crop-right: expected as second argument, given: 100") + "crop-right: expected as second argument, given 100") (check-error (crop-top pic:book 56) - "crop-top: expected as second argument, given: 56") + "crop-top: expected as second argument, given 56") (check-error (crop-bottom pic:hacker 56) - "crop-bottom: expected as second argument, given: 56") + "crop-bottom: expected as second argument, given 56") (check-error (crop-left pic:hacker -3) - "crop-left: expected as second argument, given: -3") + "crop-left: expected as second argument, given -3") (check-error (crop-top pic:book 3.2) - "crop-top: expected as second argument, given: 3.2") + "crop-top: expected as second argument, given 3.2") (check-error (crop-bottom pic:book pic:book) - "crop-bottom: expected as second argument, given: #") + "crop-bottom: expected as second argument, given #") (check-error (rotate-cw 17) - "rotate-cw: expected as first argument, given: 17") + "rotate-cw: expected as first argument, given 17") (check-error (rotate-ccw true) - "rotate-ccw: expected as first argument, given: true") + "rotate-ccw: expected as first argument, given true") (check-error (rotate-180 "goodbye") - "rotate-180: expected as first argument, given: \"goodbye\"") + "rotate-180: expected as first argument, given \"goodbye\"") From 6283ce733d1c8fbc326795adaeec895ed1dba7cd Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 19 Oct 2012 18:03:33 -0400 Subject: [PATCH 004/221] add test for unsolved db crash --- collects/meta/props | 1 + collects/tests/db/programs/sl-gc-crash.rkt | 64 ++++++++++++++++++++++ 2 files changed, 65 insertions(+) create mode 100644 collects/tests/db/programs/sl-gc-crash.rkt diff --git a/collects/meta/props b/collects/meta/props index f002d64de9..f731dac699 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1010,6 +1010,7 @@ path/s is either such a string or a list of them. "collects/tests/data" responsible (ryanc) "collects/tests/datalog" responsible (jay) "collects/tests/db" responsible (ryanc) +"collects/tests/db/programs/sl-gc-crash.rkt" drdr:command-line #f "collects/tests/db/programs/web-test.rkt" drdr:command-line #f "collects/tests/deinprogramm" responsible (sperber) "collects/tests/drracket" responsible (robby) drdr:random #t diff --git a/collects/tests/db/programs/sl-gc-crash.rkt b/collects/tests/db/programs/sl-gc-crash.rkt new file mode 100644 index 0000000000..18db92e8a6 --- /dev/null +++ b/collects/tests/db/programs/sl-gc-crash.rkt @@ -0,0 +1,64 @@ +#lang racket +(require ffi/unsafe/define + ffi/unsafe) + +#| +Open this program in DrRacket. +Click Run and then eval (collect-garbage) in the interaction area. +Repeat a few times, and eventually DrRacket will crash with a +segmentation fault. + +No crash in 5.1, 5.1.1 +Crashes in 5.2, 5.2.1, 5.3, 5.3.1.1 + +git bisect says introduced here: 2ada6d0e89a763f3b8523a87e580b1ffb25430eb +|# + +;; NOTE: make sure file exists by running "touch $filename" +(define filename #"/tmp/my.db") + +;; set NEXT-STMT? for another variation of the test, which does actually +;; seem to invoke the proper function, unlike sqlite3_close (???) +(define NEXT-STMT? #f) + +(define-ffi-definer define-sqlite + (ffi-lib "libsqlite3" '("0" #f))) + +(define-cpointer-type _sqlite3_database) +(define-cpointer-type _sqlite3_statement) + +(define SQLITE_OPEN_READWRITE #x00000002) + +(define-sqlite sqlite3_open_v2 + (_fun (filename flags) :: + (filename : _bytes) + (db : (_ptr o _sqlite3_database)) + (flags : _int) + (vfs : _pointer = #f) + -> (result : _int) + -> (values db result))) + +(define-sqlite sqlite3_close + (_fun _sqlite3_database + -> _int)) + +(define-sqlite sqlite3_next_stmt + (_fun _sqlite3_database _sqlite3_statement/null -> _sqlite3_statement/null)) + +(define c% + (class object% + (super-new) + + (define-values (db status) + (sqlite3_open_v2 filename SQLITE_OPEN_READWRITE)) + + (unless (zero? status) + (eprintf "open got ~s\n" status)) + + (define/public (finalize!) + (when NEXT-STMT? (sqlite3_next_stmt db #f)) + (sqlite3_close db)) + )) + +(define p (new c%)) +(register-finalizer p (lambda (v) (send v finalize!))) From d77803b68707894b01c2cd95e0c45533a2240f46 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Sat, 20 Oct 2012 19:40:32 -0600 Subject: [PATCH 005/221] Adding in id-cookie library after 19th use in a Web app --- collects/web-server/http/id-cookie.rkt | 78 ++++++++++++++++++++++ collects/web-server/scribblings/http.scrbl | 78 +++++++++++++++++++++- 2 files changed, 154 insertions(+), 2 deletions(-) create mode 100644 collects/web-server/http/id-cookie.rkt diff --git a/collects/web-server/http/id-cookie.rkt b/collects/web-server/http/id-cookie.rkt new file mode 100644 index 0000000000..53a8c35179 --- /dev/null +++ b/collects/web-server/http/id-cookie.rkt @@ -0,0 +1,78 @@ +#lang racket/base +(require unstable/bytes + net/base64 + net/cookie + racket/match + racket/file + racket/contract + web-server/http + web-server/stuffers/hmac-sha1) + +(define (substring* s st en) + (substring s st (+ (string-length s) en))) + +(define (mac key v) + (substring* + (bytes->string/utf-8 + (base64-encode (HMAC-SHA1 key (write/bytes v)))) + 0 -3)) + +(define (make-secret-salt/file secret-salt-path) + (unless (file-exists? secret-salt-path) + (with-output-to-file secret-salt-path + (λ () + (for ([i (in-range 128)]) + (write-byte (random 256)))))) + (file->bytes secret-salt-path)) + +(define (id-cookie? name c) + (and (client-cookie? c) + (string=? (client-cookie-name c) name))) + +(define (make-id-cookie name key data) + (define authored (current-seconds)) + (define digest + (mac key (list authored data))) + (make-cookie name + (format "~a&~a&~a" + digest authored data))) + +(define (valid-id-cookie? name key timeout c) + (and (id-cookie? name c) + (with-handlers ([exn:fail? (lambda (x) #f)]) + (match (client-cookie-value c) + [(regexp #rx"^(.+)&(.+)&(.*)$" (list _ digest authored-s data)) + (define authored (string->number authored-s)) + (define re-digest (mac key (list authored data))) + (and (string=? digest re-digest) + (<= authored timeout) + data)] + [cv + #f])))) + +(define (request-id-cookie + name + key + #:timeout [timeout +inf.0] + req) + (define cookies (request-cookies req)) + (for/or ([c (in-list cookies)]) + (valid-id-cookie? name key timeout c))) + +(define (logout-id-cookie name) + (make-cookie name "invalid format")) + +(provide + (contract-out + [make-secret-salt/file + (-> path-string? + bytes?)] + [logout-id-cookie + (-> cookie-name? cookie?)] + [request-id-cookie + (->* (cookie-name? bytes? request?) + (#:timeout number?) + (or/c false/c cookie-value?))] + [make-id-cookie + (-> cookie-name? bytes? cookie-value? + cookie?)])) diff --git a/collects/web-server/scribblings/http.scrbl b/collects/web-server/scribblings/http.scrbl index a5c61aab43..88737ebb41 100644 --- a/collects/web-server/scribblings/http.scrbl +++ b/collects/web-server/scribblings/http.scrbl @@ -265,9 +265,83 @@ transmission that the server @bold{will not catch}.} `(html (head (title "Cookie Example")) (body (h1 "You're cookie'd!")))))) ] +} - @warning{When using cookies, make sure you follow the advice of the @link["http://cookies.lcs.mit.edu/"]{MIT Cookie Eaters}, - or you will be susceptible to dangerous attacks.} +@; ------------------------------------------------------------ +@section[#:tag "id-cookie"]{Authenticated Cookies} + +@(require (for-label web-server/http/id-cookie)) +@defmodule[web-server/http/id-cookie]{ + +Cookies are useful for storing information of user's browsers and +particularly useful for storing identifying information for +authentication, sessions, etc. However, there are inherent +difficulties when using cookies as authenticators, because cookie data +is fully controlled by the user, and thus cannot be trusted. + +This module provides functions for creating and verifying +authenticated cookies that are intrinsically timestamped. It is based +on the algorithm proposed by the +@link["http://cookies.lcs.mit.edu/"]{MIT Cookie Eaters}: if you store +the data @racket[_data] at thime @racket[_authored-seconds], then the +user will receive @litchar{digest&authored-seconds&data}, where +@racket[_digest] is an HMAC-SHA1 digest of @racket[_authored-seconds] +and @racket[_data], using an arbitrary secret key. When you receive a +cookie, it will reverify this digest and check that the cookie's +@racket[_authored-seconds] is not after a timeout period, and only +then return the cookie data to the program. + +The interface represents the secret key as a byte string. The best way +to generate this is by using random bytes from something like OpenSSL +or +@tt{/dev/random}. @link["http://www.madboa.com/geek/openssl/#random-generate"]{This +FAQ} lists a few options. A convenient purely Racket-based option is +available (@racket[make-secret-salt/file]), but it will not have as +good entropy, if you care about that sort of thing. + + @defproc[(make-id-cookie + [name cookie-name?] + [secret-salt bytes?] + [value cookie-value?]) + cookie?]{ + Generates an authenticated cookie named @racket[name] containing @racket[value], signed with @racket[secret-salt]. + } + + @defproc[(request-id-cookie + [name cookie-name?] + [secret-salt bytes?] + [request request?] + [#:timeout timeout +inf.0]) + (or/c false/c cookie-value?)]{ + Extracts the first authenticated cookie named @racket[name] that was previously signed with @racket[secret-salt] before @racket[timeout] from @racket[request]. If no valid cookie is available, returns @racket[#f]. + } + + @defproc[(logout-id-cookie + [name cookie-name?]) + cookie?]{ + Generates a cookie named @racket[name] that is not validly authenticated. + + This will cause non-malicious browsers to overwrite a previously set +cookie. If you use authenticated cookies for login information, you +could send this to cause a "logout". However, malicious browsers do +not need to respect such an overwrite. Therefore, this is not an +effective way to implement timeouts or protect users on +public (i.e. possibly compromised) computers. The only way to securely +logout on the compromised computer is to have server-side state +keeping track of which cookies (sessions, etc.) are invalid. Depending +on your application, it may be better to track live sessions or dead +sessions, or never set cookies to begin with and just use +continuations, which you can revoke with @racket[send/finish]. + } + + @defproc[(make-secret-salt/file + [secret-salt-path path-string?]) + bytes?]{ + + Extracts the bytes from @racket[secret-salt-path]. If +@racket[secret-salt-path] does not exist, then it is created and +initialized with 128 random bytes. + } } @; ------------------------------------------------------------ From 9708a01a0aaa1ff9e639494596c34ef89d00ff29 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 21 Oct 2012 07:43:54 -0600 Subject: [PATCH 006/221] ffi/unsafe: defend against some finalization bugs Turn use of a finalized ffi callout into a reported error, instead of a crash. Clarify the existence of the finalizer in the docs. Fix error logging of the finalizer thread. Merge to v5.3.1 --- collects/ffi/unsafe.rkt | 1 + collects/scribblings/foreign/types.scrbl | 5 ++++ collects/tests/racket/ffi-call-final.rkt | 32 ++++++++++++++++++++++++ src/foreign/foreign.c | 12 +++++++-- src/foreign/foreign.rktc | 12 +++++++-- 5 files changed, 58 insertions(+), 4 deletions(-) create mode 100644 collects/tests/racket/ffi-call-final.rkt diff --git a/collects/ffi/unsafe.rkt b/collects/ffi/unsafe.rkt index 43a6b225ae..37ffc7c12b 100644 --- a/collects/ffi/unsafe.rkt +++ b/collects/ffi/unsafe.rkt @@ -1702,6 +1702,7 @@ (cweh (lambda (exn) (log-message logger + 'error (if (exn? exn) (exn-message exn) (format "~s" exn)) diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index 1ea8ebdaea..a13870cce1 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -485,6 +485,11 @@ For @tech{callouts} to foreign functions with the generated type: that values managed by the Racket garbage collector might be moved in memory by the garbage collector.} + @item{A @tech{callout} object is finalized internally. Beware + of trying to use a @tech{callout} object that is reachable + only from a finalized object, since the two objects + might be finalized in either order.} + ] For @tech{callbacks} to Racket functions with the generated type: diff --git a/collects/tests/racket/ffi-call-final.rkt b/collects/tests/racket/ffi-call-final.rkt new file mode 100644 index 0000000000..4993ee27f8 --- /dev/null +++ b/collects/tests/racket/ffi-call-final.rkt @@ -0,0 +1,32 @@ +#lang racket/base + +;; Check for a good effort at error reporting on an attempt to +;; use a foreign function that is finalized already. + +(define src + '(module m racket/base + (require ffi/unsafe) + (for ([i 10]) + (for ([i 10]) + (define m (get-ffi-obj 'fabs #f (_fun _double -> _double))) + ;; Since `m' is accessible only via the finalized value, it + ;; can be finalized before `(list m)': + (register-finalizer (list m) (lambda (p) ((car p) 10.0)))) + (collect-garbage)))) + +(define l (make-logger)) +(define r (make-log-receiver l 'error)) + +(parameterize ([current-namespace (make-base-namespace)] + [current-logger l]) + (eval src) + (namespace-require ''m)) + +;; Print logged errors, of which there are likely to be +;; some (although it's not guaranteed) if the finalizer +;; thread is logging correctly: +(let loop () + (define m (sync/timeout 0 r)) + (when m + (printf "~s\n" m) + (loop))) diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index d55c77d98d..ba085986ec 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -3055,7 +3055,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) #ifdef MZ_USE_PLACES int orig_place = SCHEME_TRUEP(SCHEME_VEC_ELS(data)[7]); #endif - int nargs = cif->nargs; + int nargs /* = cif->nargs, after checking cif */; /* When the foreign function is called, we need an array (ivals) of nargs * ForeignAny objects to store the actual C values that are created, and we * need another array (avalues) for the pointers to these values (this is @@ -3082,6 +3082,13 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) if (orig_place && (scheme_current_place_id == 0)) orig_place = 0; #endif + if (!cif) { + scheme_signal_error("ffi-call: foreign-function reference was already finalized%s%s", + name ? "\n name: " : "", + name ? name : ""); + return NULL; + } + nargs = cif->nargs; if ((nargs <= MAX_QUICK_ARGS)) { ivals = stack_ivals; avalues = stack_avalues; @@ -3151,8 +3158,9 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) } /* see below */ -void free_fficall_data(void *ignored, void *p) +void free_fficall_data(void *data, void *p) { + SCHEME_VEC_ELS(data)[4] = NULL; free(((ffi_cif*)p)->arg_types); free(p); } diff --git a/src/foreign/foreign.rktc b/src/foreign/foreign.rktc index 702db57354..e70e2a423c 100755 --- a/src/foreign/foreign.rktc +++ b/src/foreign/foreign.rktc @@ -2411,7 +2411,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) #ifdef MZ_USE_PLACES int orig_place = SCHEME_TRUEP(SCHEME_VEC_ELS(data)[7]); #endif - int nargs = cif->nargs; + int nargs /* = cif->nargs, after checking cif */; /* When the foreign function is called, we need an array (ivals) of nargs * ForeignAny objects to store the actual C values that are created, and we * need another array (avalues) for the pointers to these values (this is @@ -2438,6 +2438,13 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) if (orig_place && (scheme_current_place_id == 0)) orig_place = 0; #endif + if (!cif) { + scheme_signal_error("ffi-call: foreign-function reference was already finalized%s%s", + name ? "\n name: " : "", + name ? name : ""); + return NULL; + } + nargs = cif->nargs; if ((nargs <= MAX_QUICK_ARGS)) { ivals = stack_ivals; avalues = stack_avalues; @@ -2507,8 +2514,9 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) } /* see below */ -void free_fficall_data(void *ignored, void *p) +void free_fficall_data(void *data, void *p) { + SCHEME_VEC_ELS(data)[4] = NULL; free(((ffi_cif*)p)->arg_types); free(p); } From 9696bd73377f11e0d1097cd3d4a784016410aa20 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 20 Oct 2012 16:21:53 -0500 Subject: [PATCH 007/221] adjust judgment-holds so it generates less code --- collects/redex/private/judgment-form.rkt | 54 ++++++++++++++---------- 1 file changed, 31 insertions(+), 23 deletions(-) diff --git a/collects/redex/private/judgment-form.rkt b/collects/redex/private/judgment-form.rkt index b88f820c17..b863c4c033 100644 --- a/collects/redex/private/judgment-form.rkt +++ b/collects/redex/private/judgment-form.rkt @@ -207,20 +207,27 @@ [(binding-constraint ...) binding-constraints]) #`(begin (void #,(defined-check judgment-proc "judgment form" #:external #'form-name)) - (for/fold ([outputs '()]) ([sub-output #,call]) - (define mtchs - (match-pattern (compile-pattern #,lang `#,output-pattern #t) sub-output)) - (if mtchs - (for/fold ([outputs outputs]) ([mtch mtchs]) - (let ([temp (lookup-binding (mtch-bindings mtch) 'output-name)] ...) - (define mtch-outputs - (and binding-constraint ... - (term-let ([output-name/ellipsis temp] ...) - #,rest-body))) - (if mtch-outputs - (append mtch-outputs outputs) - outputs))) - outputs)))))])))) + (judgment-form-bind-withs/proc + #,lang + `#,output-pattern + #,call + (λ (bindings) + (let ([temp (lookup-binding bindings 'output-name)] ...) + (and binding-constraint ... + (term-let ([output-name/ellipsis temp] ...) + #,rest-body))))))))])))) + +(define (judgment-form-bind-withs/proc lang output-pattern call-output do-something) + (let ([compiled-pattern (compile-pattern lang output-pattern #t)]) + (for/fold ([outputs '()]) ([sub-output call-output]) + (define mtchs (match-pattern compiled-pattern sub-output)) + (if mtchs + (for/fold ([outputs outputs]) ([mtch mtchs]) + (define mtch-outputs (do-something (mtch-bindings mtch))) + (if mtch-outputs + (append mtch-outputs outputs) + outputs)) + outputs)))) (define (combine-where-results/flatten mtchs result) (and mtchs @@ -249,21 +256,22 @@ (define spacers (for/fold ([s '()]) ([m mode]) (case m [(I) s] [(O) (cons '_ s)]))) - (define (assemble inputs outputs) - (let loop ([ms mode] [is inputs] [os outputs]) - (if (null? ms) - '() - (case (car ms) - [(I) (cons (car is) (loop (cdr ms) (cdr is) os))] - [(O) (cons (car os) (loop (cdr ms) is (cdr os)))])))) (define (wrapped . _) (set! outputs (form-proc form-proc input)) (for/list ([output outputs]) - (cons form-name (assemble input output)))) - (apply trace-call form-name wrapped (assemble input spacers)) + (cons form-name (assemble mode input output)))) + (apply trace-call form-name wrapped (assemble mode input spacers)) outputs) (form-proc form-proc input))) +(define (assemble mode inputs outputs) + (let loop ([ms mode] [is inputs] [os outputs]) + (if (null? ms) + '() + (case (car ms) + [(I) (cons (car is) (loop (cdr ms) (cdr is) os))] + [(O) (cons (car os) (loop (cdr ms) is (cdr os)))])))) + (define (verify-name-ok orig-name the-name) (unless (symbol? the-name) (error orig-name "expected a single name, got ~s" the-name))) From 9baefbe7254657fd4b53cad74a9b9a2eb3f1aae4 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 21 Oct 2012 15:18:34 -0500 Subject: [PATCH 008/221] remove bogus case in stlc typing judgment form --- collects/redex/examples/stlc.rkt | 1 - 1 file changed, 1 deletion(-) diff --git a/collects/redex/examples/stlc.rkt b/collects/redex/examples/stlc.rkt index 53a375920c..73c81efaf6 100644 --- a/collects/redex/examples/stlc.rkt +++ b/collects/redex/examples/stlc.rkt @@ -73,7 +73,6 @@ (define-judgment-form λv #:mode (typeof I I O) #:contract (typeof G e t) - [(typeof G 1234 num)] [(typeof G number num)] [(typeof G (+ e_1 e_2) num) (typeof G e_1 num) From 67d52138f9bac4f637a8fa5f567a78c2836bdea6 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 21 Oct 2012 19:54:52 -0500 Subject: [PATCH 009/221] provide language, reduction relation, and typing judgment from stlc.rkt --- collects/redex/examples/stlc.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/redex/examples/stlc.rkt b/collects/redex/examples/stlc.rkt index 73c81efaf6..8eafccbd65 100644 --- a/collects/redex/examples/stlc.rkt +++ b/collects/redex/examples/stlc.rkt @@ -1,5 +1,6 @@ #lang racket (require redex) +(provide λv red typeof) (define-language λv (e (e e ...) (if0 e e e) (+ e e) x v) From 7355c59fb1ff0fb76daf6b54dc0f4f5b4fb1ec58 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 21 Oct 2012 22:59:16 -0500 Subject: [PATCH 010/221] added the ability to extract a derivation from a judgment-form via build-derivation (returns derivation structs) --- collects/redex/private/judgment-form.rkt | 149 +++++++++++++----- collects/redex/private/matcher.rkt | 5 +- .../redex/private/reduction-semantics.rkt | 12 +- collects/redex/reduction-semantics.rkt | 2 + collects/redex/scribblings/ref.scrbl | 14 ++ collects/redex/tests/tl-test.rkt | 86 ++++++++++ 6 files changed, 221 insertions(+), 47 deletions(-) diff --git a/collects/redex/private/judgment-form.rkt b/collects/redex/private/judgment-form.rkt index b863c4c033..5007448281 100644 --- a/collects/redex/private/judgment-form.rkt +++ b/collects/redex/private/judgment-form.rkt @@ -96,7 +96,7 @@ (hash-set extended (syntax-e name) w/ellipses)))) ;; the withs, freshs, and side-conditions come in backwards order -(define-for-syntax (bind-withs orig-name main lang lang-nts stx where-mode body names w/ellipses side-condition-unquoted?) +(define-for-syntax (bind-withs orig-name main lang lang-nts stx where-mode body names w/ellipses side-condition-unquoted? jf-results-id) (with-disappeared-uses (let loop ([stx stx] [to-not-be-in main] @@ -211,19 +211,32 @@ #,lang `#,output-pattern #,call - (λ (bindings) + #,under-ellipsis? + #,jf-results-id + (λ (bindings #,@(if jf-results-id (list jf-results-id) '())) (let ([temp (lookup-binding bindings 'output-name)] ...) (and binding-constraint ... (term-let ([output-name/ellipsis temp] ...) #,rest-body))))))))])))) -(define (judgment-form-bind-withs/proc lang output-pattern call-output do-something) +(define (judgment-form-bind-withs/proc lang output-pattern output under-ellipsis? old-maps do-something) (let ([compiled-pattern (compile-pattern lang output-pattern #t)]) - (for/fold ([outputs '()]) ([sub-output call-output]) - (define mtchs (match-pattern compiled-pattern sub-output)) + (for/fold ([outputs '()]) ([sub-output (in-list output)]) + (define sub-tree (if under-ellipsis? + (map (λ (x) (vector-ref x 0)) sub-output) + (vector-ref sub-output 0))) + (define term (if under-ellipsis? + (map (λ (x) (vector-ref x 1)) sub-output) + (vector-ref sub-output 1))) + (define mtchs (match-pattern compiled-pattern term)) (if mtchs - (for/fold ([outputs outputs]) ([mtch mtchs]) - (define mtch-outputs (do-something (mtch-bindings mtch))) + (for/fold ([outputs outputs]) ([mtch (in-list mtchs)]) + (define mtch-outputs (if old-maps + (do-something (mtch-bindings mtch) + (if under-ellipsis? + (append (reverse sub-tree) old-maps) + (cons sub-tree old-maps))) + (do-something (mtch-bindings mtch)))) (if mtch-outputs (append mtch-outputs outputs) outputs)) @@ -251,18 +264,31 @@ (define (call-judgment-form form-name form-proc mode input) (define traced (current-traced-metafunctions)) - (if (or (eq? 'all traced) (memq form-name traced)) - (let ([outputs #f]) - (define spacers - (for/fold ([s '()]) ([m mode]) - (case m [(I) s] [(O) (cons '_ s)]))) - (define (wrapped . _) - (set! outputs (form-proc form-proc input)) - (for/list ([output outputs]) - (cons form-name (assemble mode input output)))) - (apply trace-call form-name wrapped (assemble mode input spacers)) - outputs) - (form-proc form-proc input))) + (define vecs + (if (or (eq? 'all traced) (memq form-name traced)) + (let ([outputs #f]) + (define spacers + (for/fold ([s '()]) ([m mode]) + (case m [(I) s] [(O) (cons '_ s)]))) + (define (wrapped . _) + (set! outputs (form-proc form-proc input)) + (for/list ([output outputs]) + (cons form-name (assemble mode input (vector-ref output 1))))) + (apply trace-call form-name wrapped (assemble mode input spacers)) + outputs) + (form-proc form-proc input))) + (for/list ([v (in-list vecs)]) + (vector (derivation (cons form-name (assemble mode input (vector-ref v 1))) + (reverse (vector-ref v 0))) + (vector-ref v 1)))) +(struct derivation (term subs) + #:transparent + #:guard (λ (term subs name) + (unless (and (list? subs) + (andmap derivation? subs)) + (error name "expected the second (subs) field to be a list of derivation?s, got: ~e" + subs)) + (values term subs))) (define (assemble mode inputs outputs) (let loop ([ms mode] [is inputs] [os outputs]) @@ -358,7 +384,8 @@ (define definitions #`(begin (define-syntax #,judgment-form-name - (judgment-form '#,judgment-form-name '#,(cdr (syntax->datum mode)) #'judgment-form-runtime-proc #'mk-judgment-form-proc #'#,lang #'judgment-form-lws + (judgment-form '#,judgment-form-name '#,(cdr (syntax->datum mode)) #'judgment-form-runtime-proc + #'mk-judgment-form-proc #'#,lang #'judgment-form-lws '#,rule-names #'judgment-runtime-gen-clauses #'mk-judgment-gen-clauses)) (define mk-judgment-form-proc (compile-judgment-form-proc #,judgment-form-name #,mode #,lang #,clauses #,position-contracts #,orig #,stx #,syn-err-name)) @@ -366,7 +393,9 @@ (define judgment-form-lws (compiled-judgment-form-lws #,clauses)) (define mk-judgment-gen-clauses - (compile-judgment-gen-clauses #,judgment-form-name #,mode #,lang #,clauses #,position-contracts #,orig #,stx #,syn-err-name judgment-runtime-gen-clauses)) + (compile-judgment-gen-clauses #,judgment-form-name #,mode #,lang + #,clauses #,position-contracts #,orig + #,stx #,syn-err-name judgment-runtime-gen-clauses)) (define judgment-runtime-gen-clauses (mk-judgment-gen-clauses #,lang (λ () (judgment-runtime-gen-clauses)))))) (syntax-property (values ;prune-syntax @@ -506,27 +535,57 @@ the-name (list (car others)))) (loop (cdr others))])))) -(define-syntax (judgment-holds stx) +(define-syntax (judgment-holds/derivation stx) (syntax-case stx () - [(j-h judgment) - #`(not (null? #,(syntax/loc stx (j-h judgment #t))))] - [(j-h (form-name . pats) tmpl) + [(_ stx-name derivation? judgment) + #`(not (null? #,(syntax/loc stx (judgment-holds/derivation stx-name derivation? judgment #t))))] + [(_ stx-name derivation? (form-name . pats) tmpl) (judgment-form-id? #'form-name) - (let* ([syn-err-name (syntax-e #'j-h)] + (let* ([syn-err-name (syntax-e #'stx-name)] [lang (judgment-form-lang (lookup-judgment-form-id #'form-name))] [nts (definition-nts lang stx syn-err-name)] - [judgment (syntax-case stx () [(_ judgment _) #'judgment])]) + [judgment (syntax-case stx () [(_ _ _ judgment _) #'judgment])] + [derivation? (syntax-e #'derivation?)] + [id-or-not (if derivation? + (car (generate-temporaries '(jf-derivation-lst))) + #f)] + [main-stx + (bind-withs syn-err-name '() lang nts (list judgment) + 'flatten + (if derivation? + id-or-not + #`(list (term #,#'tmpl #:lang #,lang))) + '() + '() + #f + id-or-not)]) (check-judgment-arity stx judgment) (syntax-property - #`(sort #,(bind-withs syn-err-name '() lang nts (list judgment) - 'flatten #`(list (term #,#'tmpl #:lang #,lang)) '() '() #f) - string<=? - #:key (λ (x) (format "~s" x))) + (if id-or-not + #`(let ([#,id-or-not '()]) + #,main-stx) + #`(sort #,main-stx + string<=? + #:key (λ (x) (format "~s" x)))) 'disappeared-use (syntax-local-introduce #'form-name)))] - [(_ (not-form-name . _) . _) + [(_ stx-name derivation? (not-form-name . _) . _) (not (judgment-form-id? #'form-name)) - (raise-syntax-error #f "expected a judgment form name" stx #'not-form-name)])) + (raise-syntax-error (syntax-e #'stx-name) "expected a judgment form name" #'not-form-name)] + [(_ stx-name . whatever) + (raise-syntax-error (syntax-e #'stx-name) + "bad syntax" + stx)])) + +(define-syntax (judgment-holds stx) + (syntax-case stx () + [(_ args ...) + #'(#%expression (judgment-holds/derivation judgment-holds #f args ...))])) + +(define-syntax (build-derivations stx) + (syntax-case stx () + [(_ jf-expr) + #'(#%expression (judgment-holds/derivation build-derivations #t jf-expr any))])) (define-for-syntax (do-compile-judgment-form-proc name mode-stx clauses contracts nts orig stx syn-error-name) (define mode (cdr (syntax->datum mode-stx))) @@ -539,7 +598,8 @@ (syntax-case clause () [((_ . conc-pats) . prems) (let-values ([(input-pats output-pats) (split-by-mode (syntax->list #'conc-pats) mode)]) - (with-syntax ([(lhs (names ...) (names/ellipses ...)) (rewrite-side-conditions/check-errs nts syn-error-name #t input-pats)]) + (with-syntax ([(lhs (names ...) (names/ellipses ...)) (rewrite-side-conditions/check-errs nts syn-error-name #t input-pats)] + [(jf-derivation-id) (generate-temporaries '(jf-derivation-id))]) (define (contracts-compilation ctcs) (and ctcs (with-syntax ([(ctc ...) ctcs]) @@ -550,16 +610,18 @@ (struct-copy judgment-form (lookup-judgment-form-id name) [proc #'recur]))]) (bind-withs syn-error-name '() #'lang nts (syntax->list #'prems) - 'flatten #`(list (term/nts (#,@output-pats) #,nts)) + 'flatten #`(list (vector jf-derivation-id (term/nts (#,@output-pats) #,nts))) (syntax->list #'(names ...)) (syntax->list #'(names/ellipses ...)) - #f))) + #f + #'jf-derivation-id))) (with-syntax ([(compiled-lhs compiled-input-ctcs compiled-output-ctcs) (generate-temporaries '(compiled-lhs compiled-input-ctcs compiled-output-ctcs))]) #`( ;; pieces of a 'let' expression to be combined: first some bindings - ([compiled-lhs (compile-pattern lang `lhs #t)] + ([jf-derivation-id '()] + [compiled-lhs (compile-pattern lang `lhs #t)] #,@(if (contracts-compilation input-contracts) (list #`[compiled-input-ctcs #,(contracts-compilation input-contracts)]) (list)) @@ -574,8 +636,8 @@ (combine-judgment-rhses compiled-lhs input - (λ (m) - (term-let ([names/ellipses (lookup-binding (mtch-bindings m) 'names)] ...) + (λ (bnds) + (term-let ([names/ellipses (lookup-binding bnds 'names)] ...) #,body)) #,(if (contracts-compilation output-contracts) #`(λ (output) @@ -614,7 +676,7 @@ [mtchs (define output-table (make-hash)) (for ([m (in-list mtchs)]) - (define os (rhs m)) + (define os (rhs (mtch-bindings m))) (when os (for ([x (in-list os)]) (hash-set! output-table x #t)))) @@ -634,7 +696,10 @@ [no-rhss (map (λ (_) '()) clauses)]) #`(generate-lws #t (conc-body ...) #,(lhs-lws clauses) #,rev-premss #,no-rhss #f))])) -(define (check-judgment-form-contract form-name terms contracts mode modes) +(define (check-judgment-form-contract form-name term+trees contracts mode modes) + (define terms (if (eq? mode 'O) + (vector-ref term+trees 1) + term+trees)) (define description (case mode [(I) "input"] @@ -1123,7 +1188,9 @@ (provide define-judgment-form define-extended-judgment-form judgment-holds + build-derivations generate-lws + (struct-out derivation) (for-syntax extract-term-let-binds name-pattern-lws extract-pattern-binds diff --git a/collects/redex/private/matcher.rkt b/collects/redex/private/matcher.rkt index 1e9fd47a48..b0124b05dd 100644 --- a/collects/redex/private/matcher.rkt +++ b/collects/redex/private/matcher.rkt @@ -997,11 +997,12 @@ See match-a-pattern.rkt for more details (error 'convert-matcher "not a unary proc: ~s" boolean-based-matcher)) - (λ (exp hole-info) + (define (match-boolean-to-record-converter exp hole-info) (and (boolean-based-matcher exp) (list (make-mtch empty-bindings (build-flat-context exp) - none))))) + none)))) + match-boolean-to-record-converter) ;; match-named-pat : symbol -> (define (match-named-pat name match-pat mismatch-bind?) diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt index 22ac232524..5649703c66 100644 --- a/collects/redex/private/reduction-semantics.rkt +++ b/collects/redex/private/reduction-semantics.rkt @@ -726,7 +726,8 @@ (term #,to #:lang #,lang))) (syntax->list #'(names ...)) (syntax->list #'(names/ellipses ...)) - #t)) + #t + #f)) (define test-case-body-code ;; this contains some redundant code (bind-withs orig-name @@ -738,7 +739,8 @@ #'#t (syntax->list #'(names ...)) (syntax->list #'(names/ellipses ...)) - #t)) + #t + #f)) (with-syntax ([(lhs-w/extras (w/extras-names ...) (w/extras-names/ellipses ...)) (rw-sc #`(side-condition #,from #,test-case-body-code))] [lhs-source (format "~a:~a:~a" @@ -1232,7 +1234,8 @@ #`(list (term #,rhs #:lang lang)) (syntax->list names) (syntax->list names/ellipses) - #t)) + #t + #f)) (syntax->list #'((stuff ...) ...)) (syntax->list #'(rhs ...)) (syntax->list #'(lhs-names ...)) @@ -1246,7 +1249,8 @@ #`#t (syntax->list names) (syntax->list names/ellipses) - #t)) + #t + #f)) (syntax->list #'((stuff ...) ...)) (syntax->list #'(rhs ...)) (syntax->list #'(lhs-names ...)) diff --git a/collects/redex/reduction-semantics.rkt b/collects/redex/reduction-semantics.rkt index ea2e41dcfe..7fb73dae3b 100644 --- a/collects/redex/reduction-semantics.rkt +++ b/collects/redex/reduction-semantics.rkt @@ -35,6 +35,8 @@ define-judgment-form define-extended-judgment-form judgment-holds + build-derivations + (struct-out derivation) in-domain? caching-enabled? make-coverage diff --git a/collects/redex/scribblings/ref.scrbl b/collects/redex/scribblings/ref.scrbl index 0b6a2c67e3..5fe9349420 100644 --- a/collects/redex/scribblings/ref.scrbl +++ b/collects/redex/scribblings/ref.scrbl @@ -1386,6 +1386,20 @@ each satisfying assignment of pattern variables. See @racket[define-judgment-form] for examples. } +@defform[(build-derivations judgment)]{ + Constructs all of the @racket[derivation] trees + for @racket[judgment]. + +@examples[ +#:eval redex-eval + (build-derivations (even (s (s z))))] +} + +@defstruct[derivation ([term any/c] [subs (listof derivation?)])]{ + Represents a derivation from a judgment form. See also + @racket[build-derivations]. +} + @defidform[I]{ Recognized specially within @racket[define-judgment-form], the @racket[I] keyword is an error elsewhere. diff --git a/collects/redex/tests/tl-test.rkt b/collects/redex/tests/tl-test.rkt index 51d2b131e0..47cc3c3e02 100644 --- a/collects/redex/tests/tl-test.rkt +++ b/collects/redex/tests/tl-test.rkt @@ -2335,6 +2335,92 @@ (test (judgment-holds (J1 1 any) any) '(1)) (test (judgment-holds (J2 1 any) any) '(1)) (test (judgment-holds (J2 4 any) any) '(4))) + + (let () + (define-language L (N ::= z (s N) (t N))) + + (define-judgment-form L + #:mode (J2 I O) + [-------- + (J2 1 1)] + [-------- + (J2 1 2)]) + + (test (build-derivations (J2 1 any)) + (list (derivation '(J2 1 1) '()) + (derivation '(J2 1 2) '()))) + + + + (define-judgment-form L + #:contract (K any any) + #:mode (K I O) + [----------- + (K () z)] + [(K any_1 N) ... + --------------------------- + (K (any_1 ...) (N ...))]) + + + + (test (build-derivations (K (()) any)) + (list (derivation '(K (()) (z)) + (list (derivation '(K () z) + '()))))) + + (test + (build-derivations (K (() ()) any)) + (list (derivation + '(K (() ()) (z z)) + (list + (derivation '(K () z) '()) + (derivation '(K () z) '()))))) + + (define-judgment-form L + #:contract (J any any) + #:mode (J I O) + [-------- + (J () z)] + [(J any_1 N) (J any_2 N) + ---------------------------- + (J (any_1 any_2) (s N))] + [(J any N) + --------------- + (J (any) (s N))]) + + (test (build-derivations + (J ((()) (())) N)) + (list (derivation + '(J ((()) (())) (s (s z))) + (list (derivation + '(J (()) (s z)) + (list + (derivation + '(J () z) + '()))) + (derivation + '(J (()) (s z)) + (list + (derivation + '(J () z) + '()))))))) + + (define-judgment-form L + #:mode (J3 I O) + [(J any_1 any_2) + ------------ + (J3 any_1 any_2)]) + + (test (build-derivations (J3 (()) N)) + (list (derivation + '(J3 (()) (s z)) + (list + (derivation + '(J (()) (s z)) + (list + (derivation + '(J () z) + '())))))))) (parameterize ([current-namespace (make-base-namespace)]) From b61f1789c703b67cd23bc18e7c5f7ab08575075a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 22 Oct 2012 11:49:14 -0500 Subject: [PATCH 011/221] fix bug in detecting the name of the language (encoding problems) Also, Rackety --- collects/drracket/private/module-language.rkt | 48 ++++++++++--------- 1 file changed, 25 insertions(+), 23 deletions(-) diff --git a/collects/drracket/private/module-language.rkt b/collects/drracket/private/module-language.rkt index 4adb99cc4b..da97d9f9e1 100644 --- a/collects/drracket/private/module-language.rkt +++ b/collects/drracket/private/module-language.rkt @@ -145,29 +145,31 @@ (inherit get-language-name) (define/public (get-users-language-name defs-text) - (let* ([defs-port (open-input-text-editor defs-text)] - [read-successfully? - (with-handlers ((exn:fail? (λ (x) #f))) - (read-language defs-port (λ () #f)) - #t)]) - (cond - [read-successfully? - (let* ([str (send defs-text get-text 0 (file-position defs-port))] - [pos (regexp-match-positions #rx"#(?:!|lang )" str)]) - (cond - [(not pos) - (get-language-name)] - [else - ;; newlines can break things (ie the language text won't - ;; be in the right place in the interactions window, which - ;; at least makes the test suites unhappy), so get rid of - ;; them from the name. Otherwise, if there is some weird formatting, - ;; so be it. - (regexp-replace* #rx"[\r\n]+" - (substring str (cdr (car pos)) (string-length str)) - " ")]))] - [else - (get-language-name)]))) + (define defs-port (open-input-text-editor defs-text)) + (port-count-lines! defs-port) + (define read-successfully? + (with-handlers ((exn:fail? (λ (x) #f))) + (read-language defs-port (λ () #f)) + #t)) + (cond + [read-successfully? + (define-values (_line _col port-pos) (port-next-location defs-port)) + (define str (send defs-text get-text 0 (- port-pos 1))) + (define pos (regexp-match-positions #rx"#(?:!|lang )" str)) + (cond + [(not pos) + (get-language-name)] + [else + ;; newlines can break things (ie the language text won't + ;; be in the right place in the interactions window, which + ;; at least makes the test suites unhappy), so get rid of + ;; them from the name. Otherwise, if there is some weird formatting, + ;; so be it. + (regexp-replace* #rx"[\r\n]+" + (substring str (cdr (car pos)) (string-length str)) + " ")])] + [else + (get-language-name)])) (define/override (use-namespace-require/copy?) #f) From 8226899df387629babc5a7bf7ffbcdbac4f237be Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 22 Oct 2012 13:18:52 -0400 Subject: [PATCH 012/221] db: fix finalization bug --- collects/db/private/odbc/connection.rkt | 9 ++- collects/db/private/sqlite3/connection.rkt | 9 ++- collects/tests/db/programs/sl-gc-crash.rkt | 64 ---------------------- 3 files changed, 16 insertions(+), 66 deletions(-) delete mode 100644 collects/tests/db/programs/sl-gc-crash.rkt diff --git a/collects/db/private/odbc/connection.rkt b/collects/db/private/odbc/connection.rkt index 30414008f9..5f23a1c5c2 100644 --- a/collects/db/private/odbc/connection.rkt +++ b/collects/db/private/odbc/connection.rkt @@ -656,7 +656,14 @@ #:on-notice add-notice!))) (super-new) - (register-finalizer this (lambda (obj) (send obj disconnect))))) + (register-finalizer this + (lambda (obj) + ;; Keep a reference to the class to keep all FFI callout objects + ;; (eg, SQLDisconnect) used by its methods from being finalized. + (let ([dont-gc this%]) + (send obj disconnect) + ;; Dummy result to prevent reference from being optimized away + dont-gc))))) ;; ---------------------------------------- diff --git a/collects/db/private/sqlite3/connection.rkt b/collects/db/private/sqlite3/connection.rkt index 5a716249cc..a4d04423fb 100644 --- a/collects/db/private/sqlite3/connection.rkt +++ b/collects/db/private/sqlite3/connection.rkt @@ -316,7 +316,14 @@ ;; ---- (super-new) - (register-finalizer this (lambda (obj) (send obj disconnect))))) + (register-finalizer this + (lambda (obj) + ;; Keep a reference to the class to keep all FFI callout objects + ;; (eg, sqlite3_close) used by its methods from being finalized. + (let ([dont-gc this%]) + (send obj disconnect) + ;; Dummy result to prevent reference from being optimized away + dont-gc))))) ;; ---------------------------------------- diff --git a/collects/tests/db/programs/sl-gc-crash.rkt b/collects/tests/db/programs/sl-gc-crash.rkt deleted file mode 100644 index 18db92e8a6..0000000000 --- a/collects/tests/db/programs/sl-gc-crash.rkt +++ /dev/null @@ -1,64 +0,0 @@ -#lang racket -(require ffi/unsafe/define - ffi/unsafe) - -#| -Open this program in DrRacket. -Click Run and then eval (collect-garbage) in the interaction area. -Repeat a few times, and eventually DrRacket will crash with a -segmentation fault. - -No crash in 5.1, 5.1.1 -Crashes in 5.2, 5.2.1, 5.3, 5.3.1.1 - -git bisect says introduced here: 2ada6d0e89a763f3b8523a87e580b1ffb25430eb -|# - -;; NOTE: make sure file exists by running "touch $filename" -(define filename #"/tmp/my.db") - -;; set NEXT-STMT? for another variation of the test, which does actually -;; seem to invoke the proper function, unlike sqlite3_close (???) -(define NEXT-STMT? #f) - -(define-ffi-definer define-sqlite - (ffi-lib "libsqlite3" '("0" #f))) - -(define-cpointer-type _sqlite3_database) -(define-cpointer-type _sqlite3_statement) - -(define SQLITE_OPEN_READWRITE #x00000002) - -(define-sqlite sqlite3_open_v2 - (_fun (filename flags) :: - (filename : _bytes) - (db : (_ptr o _sqlite3_database)) - (flags : _int) - (vfs : _pointer = #f) - -> (result : _int) - -> (values db result))) - -(define-sqlite sqlite3_close - (_fun _sqlite3_database - -> _int)) - -(define-sqlite sqlite3_next_stmt - (_fun _sqlite3_database _sqlite3_statement/null -> _sqlite3_statement/null)) - -(define c% - (class object% - (super-new) - - (define-values (db status) - (sqlite3_open_v2 filename SQLITE_OPEN_READWRITE)) - - (unless (zero? status) - (eprintf "open got ~s\n" status)) - - (define/public (finalize!) - (when NEXT-STMT? (sqlite3_next_stmt db #f)) - (sqlite3_close db)) - )) - -(define p (new c%)) -(register-finalizer p (lambda (v) (send v finalize!))) From b382e7921086171e50d72bfd8a00371e9ef7ca9c Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 22 Oct 2012 16:54:48 -0400 Subject: [PATCH 013/221] update props for removed file --- collects/meta/props | 1 - 1 file changed, 1 deletion(-) diff --git a/collects/meta/props b/collects/meta/props index f731dac699..f002d64de9 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1010,7 +1010,6 @@ path/s is either such a string or a list of them. "collects/tests/data" responsible (ryanc) "collects/tests/datalog" responsible (jay) "collects/tests/db" responsible (ryanc) -"collects/tests/db/programs/sl-gc-crash.rkt" drdr:command-line #f "collects/tests/db/programs/web-test.rkt" drdr:command-line #f "collects/tests/deinprogramm" responsible (sperber) "collects/tests/drracket" responsible (robby) drdr:random #t From 54c5538fd61ca90b4410faaea6c5799d3ab80c72 Mon Sep 17 00:00:00 2001 From: John Clements Date: Mon, 22 Oct 2012 14:56:36 -0700 Subject: [PATCH 014/221] updated HISTORY Include in 5.3.1 release. --- doc/release-notes/stepper/HISTORY.txt | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/doc/release-notes/stepper/HISTORY.txt b/doc/release-notes/stepper/HISTORY.txt index cc7534f783..2f1c1ca385 100644 --- a/doc/release-notes/stepper/HISTORY.txt +++ b/doc/release-notes/stepper/HISTORY.txt @@ -1,6 +1,10 @@ Stepper ------- +Changes for 5.3.1: + +Addded external interface, for third-party stepper developers. + Changes for 5.3: Minor bug fixes. From f60d57a27f6216a897c3faaa7e97d265f8c9bd30 Mon Sep 17 00:00:00 2001 From: John Clements Date: Mon, 22 Oct 2012 14:57:10 -0700 Subject: [PATCH 015/221] updated manual tests --- collects/tests/stepper/manual-tests.txt | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/collects/tests/stepper/manual-tests.txt b/collects/tests/stepper/manual-tests.txt index 3e61d3575f..1d6f63e0c7 100644 --- a/collects/tests/stepper/manual-tests.txt +++ b/collects/tests/stepper/manual-tests.txt @@ -7,10 +7,9 @@ Make sure that you get a warning when you change the underlying program, and a warning when the program window disappears. Try stepping backward and forward through programs with correct and erroneous -(syntax errors, runtime errors) executions. +(syntax errors, runtime errors) executions, incl. jumping to end. Try programs which print snips (print-convert-test.ss) try programs that contain test cases; make sure that the popups behave sensibly. -Try jumping to the end on a program with an error. From 5f154015617715c8325519120079327b3e9dd6fd Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 22 Oct 2012 17:09:32 -0400 Subject: [PATCH 016/221] macro stepper: fix bug re taking over run button Closes PR 13019 --- collects/macro-debugger/tool.rkt | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/collects/macro-debugger/tool.rkt b/collects/macro-debugger/tool.rkt index 5c48147b03..f5716694d1 100644 --- a/collects/macro-debugger/tool.rkt +++ b/collects/macro-debugger/tool.rkt @@ -269,8 +269,12 @@ (set! user-custodian (current-custodian))) (define (uncaught-exception-raised) ;; =user= - ;; formerly shut down user custodian - (void)) + (set! normal-termination? #t) + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (λ () + (cleanup) + (custodian-shutdown-all user-custodian))))) (define (show-error-report/tab) ;; =drs= (send the-tab turn-on-error-report) (send (send the-tab get-error-report-text) scroll-to-position 0) @@ -294,7 +298,6 @@ (parameterize ([current-eventspace drs-eventspace]) (queue-callback (λ () - (send the-tab syncheck:clear-highlighting) (cleanup) (custodian-shutdown-all user-custodian)))))) From 1137b444ad8393cd01faff18602e3facc3322c89 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 22 Oct 2012 17:26:33 -0400 Subject: [PATCH 017/221] macro-stepper: show errors in provide expansion closes PR 13018 --- collects/macro-debugger/model/reductions.rkt | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/collects/macro-debugger/model/reductions.rkt b/collects/macro-debugger/model/reductions.rkt index fdc88b0c97..f4e17c0fd3 100644 --- a/collects/macro-debugger/model/reductions.rkt +++ b/collects/macro-debugger/model/reductions.rkt @@ -222,12 +222,7 @@ [#:learn (list #'?var)])] [(Wrap p:provide (e1 e2 rs ?1 inners ?2)) - (let ([wrapped-inners - (for/list ([inner (in-list inners)]) - (match inner - [(Wrap deriv (e1 e2)) - (make local-expansion e1 e2 - #f e1 inner #f e2 #f)]))]) + (let ([wrapped-inners (map expr->local-action inners)]) (R [! ?1] [#:pattern ?form] [#:pass1] @@ -668,7 +663,9 @@ [#:do (DEBUG (printf "** module begin pass 2\n"))] [ModulePass ?forms pass2] ;; ignore pass3 for now: only provides - )])) + [#:new-local-context + [#:pattern ?form] + [LocalActions ?form (map expr->local-action (or pass3 null))]])])) ;; ModulePass : (list-of MBRule) -> RST (define (ModulePass mbrules) @@ -796,6 +793,12 @@ (when #f (apply error sym args))) +(define (expr->local-action d) + (match d + [(Wrap deriv (e1 e2)) + (make local-expansion e1 e2 + #f e1 d #f e2 #f)])) + ;; opaque-table ;; Weakly remembers assoc between opaque values and ;; actual syntax, so that actual can be substituted in From 552fe0f755b30ce298aa0be0044eb6ae68209873 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 23 Oct 2012 11:27:08 -0600 Subject: [PATCH 018/221] Test localhost tcp before running echo server test --- collects/tests/net/available.rkt | 83 ++++++++++++++++++++++++++++++++ collects/tests/net/websocket.rkt | 21 ++++---- 2 files changed, 94 insertions(+), 10 deletions(-) create mode 100644 collects/tests/net/available.rkt diff --git a/collects/tests/net/available.rkt b/collects/tests/net/available.rkt new file mode 100644 index 0000000000..9fc245f2c9 --- /dev/null +++ b/collects/tests/net/available.rkt @@ -0,0 +1,83 @@ +#lang racket/base +(require racket/tcp + racket/list + racket/match + racket/port + racket/contract) + +(define to-client #"0") +(define to-server #"1") +(define (tcp-localhost-available?) + (with-handlers + ([exn? (λ (x) #f)]) + (define the-listener + (tcp-listen 0 4 #t #f)) + (define-values (local-host port end-host end-port) + (tcp-addresses the-listener #t)) + (let loop ([listener the-listener] + [sip #f] [sop #f] + [connected? #f] + [cip #f] [cop #f]) + (if (and (not listener) + (not sip) + (not sop) + connected? + (not cip) + (not cop)) + #t + (sync + (if listener + (handle-evt + (tcp-accept-evt listener) + (match-lambda + [(list sip sop) + (tcp-close listener) + (loop #f sip sop connected? cip cop)])) + never-evt) + (if sop + (handle-evt + (write-bytes-avail-evt to-client sop) + (λ (written-bs-n) + (tcp-abandon-port sop) + (loop #f sip #f connected? cip cop))) + never-evt) + (if sip + (handle-evt + (read-bytes-evt 1 sip) + (λ (read-bs) + (unless (bytes=? to-server read-bs) + (error 'wrong)) + (tcp-abandon-port sip) + (loop #f #f sop connected? cip cop))) + never-evt) + (if connected? + never-evt + (handle-evt + always-evt + (λ (_) + (define-values (cip cop) + (tcp-connect "localhost" port)) + (loop listener sip sop #t cip cop)))) + (if cop + (handle-evt + (write-bytes-avail-evt to-server cop) + (λ (written-bs-n) + (tcp-abandon-port cop) + (loop listener sip sop connected? cip #f))) + never-evt) + (if cip + (handle-evt + (read-bytes-evt 1 cip) + (λ (read-bs) + (unless (bytes=? to-client read-bs) + (error 'wrong)) + (tcp-abandon-port cip) + (loop listener sip sop connected? #f cop))) + never-evt)))))) + +(provide + (contract-out + [tcp-localhost-available? (-> boolean?)])) + +(module+ main + (tcp-localhost-available?)) diff --git a/collects/tests/net/websocket.rkt b/collects/tests/net/websocket.rkt index 51373a3351..cc90765581 100644 --- a/collects/tests/net/websocket.rkt +++ b/collects/tests/net/websocket.rkt @@ -6,6 +6,7 @@ racket/async-channel net/url rackunit + tests/net/available tests/eli-tester) (define RANDOM-K 100) @@ -81,14 +82,14 @@ (define p (async-channel-get confirm)) (define conn (ws-connect (string->url (format "ws://localhost:~a" p)))) - (when conn - (test (ws-send! conn r) - (ws-recv conn) => r - (ws-send! conn "a") - (ws-recv conn) => "a" - (ws-close! conn))) + (test (ws-send! conn r) + (ws-recv conn) => r + (ws-send! conn "a") + (ws-recv conn) => "a" + (ws-close! conn)) (test (shutdown!)))] - (test #:failure-prefix "old" - (parameterize ([framing-mode 'old]) (test-echo-server)) - #:failure-prefix "new" - (parameterize ([framing-mode 'new]) (test-echo-server)))))) + (when (tcp-localhost-available?) + (test #:failure-prefix "old" + (parameterize ([framing-mode 'old]) (test-echo-server)) + #:failure-prefix "new" + (parameterize ([framing-mode 'new]) (test-echo-server))))))) From d39780a130923b59169f0f6fe7b046b7ba73b6cf Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 23 Oct 2012 11:28:09 -0600 Subject: [PATCH 019/221] Change thread test to use fake tcp with same structure --- collects/tests/racket/thread.rktl | 33 ++++++++++++++++++++++++++----- 1 file changed, 28 insertions(+), 5 deletions(-) diff --git a/collects/tests/racket/thread.rktl b/collects/tests/racket/thread.rktl index 1f0744802f..3e8d9a1c40 100644 --- a/collects/tests/racket/thread.rktl +++ b/collects/tests/racket/thread.rktl @@ -613,13 +613,36 @@ (test #f semaphore-try-wait? s) (test #f semaphore-try-wait? s2)))) +(struct ftcp-listener (sema sr sw cr cw) + #:property prop:evt + (λ (l) + (handle-evt (semaphore-peek-evt (ftcp-listener-sema l)) + (λ (_) + l)))) +(define (ftcp-listen _0 _1 _2) + (define-values (cr sw) (make-pipe 4098)) + (define-values (sr cw) (make-pipe 4098)) + (ftcp-listener (make-semaphore 0) sr sw cr cw)) +(define (ftcp-addresses l _1) + (values #f l #f #f)) +(define (ftcp-connect h l) + (semaphore-post (ftcp-listener-sema l)) + (values (ftcp-listener-cr l) + (ftcp-listener-cw l))) +(define (ftcp-accept l) + (semaphore-wait (ftcp-listener-sema l)) + (values (ftcp-listener-sr l) + (ftcp-listener-sw l))) +(define (ftcp-close l) + (void)) + (define (listen-port x) - (let-values ([(la lp pa pp) (tcp-addresses x #t)]) + (let-values ([(la lp pa pp) (ftcp-addresses x #t)]) lp)) (let ([s (make-semaphore)] [s-t (make-semaphore)] - [l (tcp-listen 0 5 #t)]) + [l (ftcp-listen 0 5 #t)]) (let ([t (thread (lambda () (sync s-t)))] @@ -668,11 +691,11 @@ (set! t (thread (lambda () (semaphore-wait (make-semaphore))))) - (let-values ([(cr cw) (tcp-connect "localhost" portnum)]) + (let-values ([(cr cw) (ftcp-connect "localhost" portnum)]) (test l sync s t l r) (test l sync s t l r) - (let-values ([(sr sw) (tcp-accept l)]) + (let-values ([(sr sw) (ftcp-accept l)]) (try-all-blocked) (close-output-port w) @@ -720,7 +743,7 @@ (close-output-port cw) (test sr sync s t l sr)))) - (tcp-close l))) + (ftcp-close l))) ;; Test limited pipe output waiting: (let-values ([(r w) (make-pipe 5000)]) From 1b589c1529ae677fd6da82929cd242619705e001 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 23 Oct 2012 11:38:23 -0700 Subject: [PATCH 020/221] fix a JIT problem with inline stuct allocation --- src/racket/src/jitinline.c | 1 + 1 file changed, 1 insertion(+) diff --git a/src/racket/src/jitinline.c b/src/racket/src/jitinline.c index f0bb3ccbab..e835bc0e3b 100644 --- a/src/racket/src/jitinline.c +++ b/src/racket/src/jitinline.c @@ -728,6 +728,7 @@ int scheme_generate_struct_alloc(mz_jit_state *jitter, int num_args, #ifdef CAN_INLINE_ALLOC int i; jit_movr_p(JIT_R0, JIT_R2); + jit_movi_p(JIT_R1, 0); /* clear register that might get saved as a pointer */ inline_struct_alloc(jitter, num_args, inline_slow); /* allocation result is in V1 */ jit_stxi_p((intptr_t)&((Scheme_Structure *)0x0)->stype + OBJHEAD_SIZE, JIT_V1, JIT_R0); From 661f702497e2348c7f01eb42dcf520a6692363da Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 22 Oct 2012 15:16:15 -0500 Subject: [PATCH 021/221] attempted to clean up the derivation support so that no derivation data structure creation happens during just a normal judgment-holds, but this was not entirely successful, so there still is some.... Also, improved the test-util to show stacktraces for errors (when they exist) --- collects/redex/private/judgment-form.rkt | 187 ++++++++++++----------- collects/redex/tests/test-util.rkt | 7 +- 2 files changed, 99 insertions(+), 95 deletions(-) diff --git a/collects/redex/private/judgment-form.rkt b/collects/redex/private/judgment-form.rkt index 5007448281..de8ee6b931 100644 --- a/collects/redex/private/judgment-form.rkt +++ b/collects/redex/private/judgment-form.rkt @@ -31,7 +31,7 @@ (define-struct metafunc-extra-where (lhs rhs)) (define-struct metafunc-extra-fresh (vars)) -(define-for-syntax (judgment-form-id? stx) +(define-for-syntax (judgment-form-id? stx) (and (identifier? stx) (judgment-form? (syntax-local-value stx (λ () #f))))) @@ -196,7 +196,7 @@ (let ([input (quasisyntax/loc premise (term/nts #,input-template #,lang-nts))]) (define (make-traced input) (quasisyntax/loc premise - (call-judgment-form 'form-name #,judgment-proc '#,mode #,input))) + (call-judgment-form 'form-name #,judgment-proc '#,mode #,input #,(if jf-results-id #''() #f)))) (if under-ellipsis? #`(repeated-premise-outputs #,input (λ (x) #,(make-traced #'x))) (make-traced input)))]) @@ -213,10 +213,10 @@ #,call #,under-ellipsis? #,jf-results-id - (λ (bindings #,@(if jf-results-id (list jf-results-id) '())) + (λ (bindings #,(if jf-results-id jf-results-id '_ignored)) (let ([temp (lookup-binding bindings 'output-name)] ...) (and binding-constraint ... - (term-let ([output-name/ellipsis temp] ...) + (term-let ([output-name/ellipsis temp] ...) #,rest-body))))))))])))) (define (judgment-form-bind-withs/proc lang output-pattern output under-ellipsis? old-maps do-something) @@ -231,12 +231,11 @@ (define mtchs (match-pattern compiled-pattern term)) (if mtchs (for/fold ([outputs outputs]) ([mtch (in-list mtchs)]) - (define mtch-outputs (if old-maps - (do-something (mtch-bindings mtch) - (if under-ellipsis? - (append (reverse sub-tree) old-maps) - (cons sub-tree old-maps))) - (do-something (mtch-bindings mtch)))) + (define mtch-outputs (do-something (mtch-bindings mtch) + (and old-maps + (if under-ellipsis? + (append (reverse sub-tree) old-maps) + (cons sub-tree old-maps))))) (if mtch-outputs (append mtch-outputs outputs) outputs)) @@ -262,7 +261,7 @@ (for*/list ([o output] [os (repeated-premise-outputs (cdr inputs) premise)]) (cons o os)))))) -(define (call-judgment-form form-name form-proc mode input) +(define (call-judgment-form form-name form-proc mode input derivation-init) (define traced (current-traced-metafunctions)) (define vecs (if (or (eq? 'all traced) (memq form-name traced)) @@ -271,15 +270,16 @@ (for/fold ([s '()]) ([m mode]) (case m [(I) s] [(O) (cons '_ s)]))) (define (wrapped . _) - (set! outputs (form-proc form-proc input)) + (set! outputs (form-proc form-proc input derivation-init)) (for/list ([output outputs]) (cons form-name (assemble mode input (vector-ref output 1))))) (apply trace-call form-name wrapped (assemble mode input spacers)) outputs) - (form-proc form-proc input))) + (form-proc form-proc input derivation-init))) (for/list ([v (in-list vecs)]) - (vector (derivation (cons form-name (assemble mode input (vector-ref v 1))) - (reverse (vector-ref v 0))) + (define subs (vector-ref v 0)) + (vector (and subs (derivation (cons form-name (assemble mode input (vector-ref v 1))) + (reverse subs))) (vector-ref v 1)))) (struct derivation (term subs) #:transparent @@ -588,87 +588,88 @@ #'(#%expression (judgment-holds/derivation build-derivations #t jf-expr any))])) (define-for-syntax (do-compile-judgment-form-proc name mode-stx clauses contracts nts orig stx syn-error-name) - (define mode (cdr (syntax->datum mode-stx))) - (define-values (input-contracts output-contracts) - (if contracts - (let-values ([(ins outs) (split-by-mode contracts mode)]) - (values ins outs)) - (values #f #f))) - (define (compile-clause clause) - (syntax-case clause () - [((_ . conc-pats) . prems) - (let-values ([(input-pats output-pats) (split-by-mode (syntax->list #'conc-pats) mode)]) - (with-syntax ([(lhs (names ...) (names/ellipses ...)) (rewrite-side-conditions/check-errs nts syn-error-name #t input-pats)] - [(jf-derivation-id) (generate-temporaries '(jf-derivation-id))]) - (define (contracts-compilation ctcs) - (and ctcs - (with-syntax ([(ctc ...) ctcs]) - #`(list (compile-pattern lang `ctc #f) ...)))) - (define body - (parameterize ([judgment-form-pending-expansion - (cons name - (struct-copy judgment-form (lookup-judgment-form-id name) - [proc #'recur]))]) - (bind-withs syn-error-name '() #'lang nts (syntax->list #'prems) - 'flatten #`(list (vector jf-derivation-id (term/nts (#,@output-pats) #,nts))) - (syntax->list #'(names ...)) - (syntax->list #'(names/ellipses ...)) - #f - #'jf-derivation-id))) - (with-syntax ([(compiled-lhs compiled-input-ctcs compiled-output-ctcs) - (generate-temporaries '(compiled-lhs compiled-input-ctcs compiled-output-ctcs))]) - - #`( - ;; pieces of a 'let' expression to be combined: first some bindings - ([jf-derivation-id '()] - [compiled-lhs (compile-pattern lang `lhs #t)] - #,@(if (contracts-compilation input-contracts) - (list #`[compiled-input-ctcs #,(contracts-compilation input-contracts)]) - (list)) - #,@(if (contracts-compilation output-contracts) - (list #`[compiled-output-ctcs #,(contracts-compilation output-contracts)]) - (list))) - ;; and then the body of the let, but expected to be behind a (λ (input) ...). - (begin - #,@(if (contracts-compilation input-contracts) - (list #`(check-judgment-form-contract '#,name input compiled-input-ctcs 'I '#,mode)) - (list)) - (combine-judgment-rhses - compiled-lhs - input - (λ (bnds) - (term-let ([names/ellipses (lookup-binding bnds 'names)] ...) - #,body)) - #,(if (contracts-compilation output-contracts) - #`(λ (output) - (check-judgment-form-contract '#,name output compiled-output-ctcs 'O '#,mode)) - #`void)))))))])) + (with-syntax ([(init-jf-derivation-id) (generate-temporaries '(init-jf-derivation-id))]) + (define mode (cdr (syntax->datum mode-stx))) + (define-values (input-contracts output-contracts) + (if contracts + (let-values ([(ins outs) (split-by-mode contracts mode)]) + (values ins outs)) + (values #f #f))) + (define (compile-clause clause) + (syntax-case clause () + [((_ . conc-pats) . prems) + (let-values ([(input-pats output-pats) (split-by-mode (syntax->list #'conc-pats) mode)]) + (with-syntax ([(lhs (names ...) (names/ellipses ...)) (rewrite-side-conditions/check-errs nts syn-error-name #t input-pats)] + [(jf-derivation-id) (generate-temporaries '(jf-derivation-id))]) + (define (contracts-compilation ctcs) + (and ctcs + (with-syntax ([(ctc ...) ctcs]) + #`(list (compile-pattern lang `ctc #f) ...)))) + (define body + (parameterize ([judgment-form-pending-expansion + (cons name + (struct-copy judgment-form (lookup-judgment-form-id name) + [proc #'recur]))]) + (bind-withs syn-error-name '() #'lang nts (syntax->list #'prems) + 'flatten #`(list (vector jf-derivation-id (term/nts (#,@output-pats) #,nts))) + (syntax->list #'(names ...)) + (syntax->list #'(names/ellipses ...)) + #f + #'jf-derivation-id))) + (with-syntax ([(compiled-lhs compiled-input-ctcs compiled-output-ctcs) + (generate-temporaries '(compiled-lhs compiled-input-ctcs compiled-output-ctcs))]) + + #`( + ;; pieces of a 'let' expression to be combined: first some bindings + ([compiled-lhs (compile-pattern lang `lhs #t)] + #,@(if (contracts-compilation input-contracts) + (list #`[compiled-input-ctcs #,(contracts-compilation input-contracts)]) + (list)) + #,@(if (contracts-compilation output-contracts) + (list #`[compiled-output-ctcs #,(contracts-compilation output-contracts)]) + (list))) + ;; and then the body of the let, but expected to be behind a (λ (input) ...). + (let ([jf-derivation-id init-jf-derivation-id]) + (begin + #,@(if (contracts-compilation input-contracts) + (list #`(check-judgment-form-contract '#,name input compiled-input-ctcs 'I '#,mode)) + (list)) + (combine-judgment-rhses + compiled-lhs + input + (λ (bnds) + (term-let ([names/ellipses (lookup-binding bnds 'names)] ...) + #,body)) + #,(if (contracts-compilation output-contracts) + #`(λ (output) + (check-judgment-form-contract '#,name output compiled-output-ctcs 'O '#,mode)) + #`void))))))))])) - (when (identifier? orig) - (define orig-mode (judgment-form-mode (lookup-judgment-form-id orig))) - (unless (equal? mode orig-mode) - (raise-syntax-error syn-error-name - (format - "mode for extended judgment form does not match original mode; got ~s for the original and ~s for the extension" - `(,(syntax-e orig) ,@orig-mode) - `(,(syntax-e name) ,@mode)) - stx - mode-stx))) - - (with-syntax ([(((clause-proc-binding ...) clause-proc-body) ...) (map compile-clause clauses)]) - (with-syntax ([(clause-proc-body-backwards ...) (reverse (syntax->list #'(clause-proc-body ...)))]) - (if (identifier? orig) - (with-syntax ([orig-mk (judgment-form-mk-proc (lookup-judgment-form-id orig))]) + (when (identifier? orig) + (define orig-mode (judgment-form-mode (lookup-judgment-form-id orig))) + (unless (equal? mode orig-mode) + (raise-syntax-error syn-error-name + (format + "mode for extended judgment form does not match original mode; got ~s for the original and ~s for the extension" + `(,(syntax-e orig) ,@orig-mode) + `(,(syntax-e name) ,@mode)) + stx + mode-stx))) + + (with-syntax ([(((clause-proc-binding ...) clause-proc-body) ...) (map compile-clause clauses)]) + (with-syntax ([(clause-proc-body-backwards ...) (reverse (syntax->list #'(clause-proc-body ...)))]) + (if (identifier? orig) + (with-syntax ([orig-mk (judgment-form-mk-proc (lookup-judgment-form-id orig))]) + #`(λ (lang) + (let (clause-proc-binding ... ...) + (let ([prev (orig-mk lang)]) + (λ (recur input init-jf-derivation-id) + (append (prev recur input init-jf-derivation-id) + clause-proc-body-backwards ...)))))) #`(λ (lang) (let (clause-proc-binding ... ...) - (let ([prev (orig-mk lang)]) - (λ (recur input) - (append (prev recur input) - clause-proc-body-backwards ...)))))) - #`(λ (lang) - (let (clause-proc-binding ... ...) - (λ (recur input) - (append clause-proc-body-backwards ...)))))))) + (λ (recur input init-jf-derivation-id) + (append clause-proc-body-backwards ...))))))))) (define (combine-judgment-rhses compiled-lhs input rhs check-output) (define mtchs (match-pattern compiled-lhs input)) diff --git a/collects/redex/tests/test-util.rkt b/collects/redex/tests/test-util.rkt index 474cc31442..903db2ab20 100644 --- a/collects/redex/tests/test-util.rkt +++ b/collects/redex/tests/test-util.rkt @@ -148,11 +148,14 @@ (unless (and (not (exn? got)) (matches? got expected)) (set! failures (+ 1 failures)) - (eprintf "test: file ~a line ~a:\n got ~s\nexpected ~s\n\n" + (eprintf "test: file ~a line ~a:\n got ~s\nexpected ~s\n" filename line got - expected)))) + expected) + (when (exn:fail? got) + ((error-display-handler) (exn-message got) got)) + (eprintf "\n")))) (define (matches? got expected) (cond From a2c4f6064d4b315372aff3a717ad8a27ae2a0ec1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 24 Oct 2012 06:45:11 -0600 Subject: [PATCH 022/221] fix GC alignment bug Merge to v5.3.1 --- src/racket/gc2/newgc.c | 30 +++++++++++++++++++----------- 1 file changed, 19 insertions(+), 11 deletions(-) diff --git a/src/racket/gc2/newgc.c b/src/racket/gc2/newgc.c index 442185e407..d11f2c884c 100644 --- a/src/racket/gc2/newgc.c +++ b/src/racket/gc2/newgc.c @@ -753,14 +753,17 @@ int GC_is_allocated(void *p) # else # define PREFIX_WSIZE 3 # endif +# define CHECK_ALIGN_MASK 0xF #elif defined(GC_ALIGN_EIGHT) # if defined(SIXTY_FOUR_BIT_INTEGERS) # define PREFIX_WSIZE 0 # else # define PREFIX_WSIZE 1 # endif +# define CHECK_ALIGN_MASK 0x7 #else /* GC_ALIGN_FOUR or byte aligned */ # define PREFIX_WSIZE 0 +# define CHECK_ALIGN_MASK 0x3 #endif #define PREFIX_SIZE (PREFIX_WSIZE * WORD_SIZE) @@ -773,7 +776,8 @@ int GC_is_allocated(void *p) #define MAX_OBJECT_SIZE (APAGE_SIZE - ((PREFIX_WSIZE + 3) * WORD_SIZE)) #define ASSERT_TAG(tag) GC_ASSERT((tag) >= 0 && (tag) <= NUMBER_OF_TAGS) -#define ASSERT_VALID_OBJPTR(objptr) GC_ASSERT(!((intptr_t)(objptr) & (0x3))) +#define ASSERT_VALID_OBJPTR(objptr) GC_ASSERT(!((intptr_t)(objptr) & CHECK_ALIGN_MASK)) +#define ASSERT_VALID_INFOPTR(objptr) GC_ASSERT(!(((intptr_t)(objptr) + sizeof(objhead)) & CHECK_ALIGN_MASK)) /* Generation 0. Generation 0 is a set of very large pages in a list(gc->gen0.pages), plus a set of smaller bigpages in a separate list(gc->gen0.big_pages). @@ -1233,8 +1237,8 @@ inline static void gen0_allocate_and_setup_new_page(NewGC *gc) { if (!gc->gen0.pages) gc->gen0.pages = new_mpage; - GC_gen0_alloc_page_ptr = NUM(new_mpage->addr); - ASSERT_VALID_OBJPTR(GC_gen0_alloc_page_ptr); + GC_gen0_alloc_page_ptr = NUM(new_mpage->addr) + new_mpage->size; + ASSERT_VALID_INFOPTR(GC_gen0_alloc_page_ptr); GC_gen0_alloc_page_end = NUM(new_mpage->addr) + GEN0_ALLOC_SIZE(new_mpage); } @@ -1249,7 +1253,7 @@ inline static uintptr_t allocate_slowpath(NewGC *gc, size_t allocate_size, uintp if(gc->gen0.curr_alloc_page && gc->gen0.curr_alloc_page->next) { gc->gen0.curr_alloc_page = gc->gen0.curr_alloc_page->next; GC_gen0_alloc_page_ptr = NUM(gc->gen0.curr_alloc_page->addr) + gc->gen0.curr_alloc_page->size; - ASSERT_VALID_OBJPTR(GC_gen0_alloc_page_ptr); + ASSERT_VALID_INFOPTR(GC_gen0_alloc_page_ptr); GC_gen0_alloc_page_end = NUM(gc->gen0.curr_alloc_page->addr) + GEN0_ALLOC_SIZE(gc->gen0.curr_alloc_page); } /* WARNING: tries to avoid a collection but @@ -1269,7 +1273,7 @@ inline static uintptr_t allocate_slowpath(NewGC *gc, size_t allocate_size, uintp #endif } newptr = GC_gen0_alloc_page_ptr + allocate_size; - ASSERT_VALID_OBJPTR(newptr); + ASSERT_VALID_INFOPTR(newptr); } while (OVERFLOWS_GEN0(newptr)); @@ -1288,7 +1292,6 @@ inline static void *allocate(const size_t request_size, const int type) /* ensure that allocation will fit in a gen0 page */ newptr = GC_gen0_alloc_page_ptr + allocate_size; - ASSERT_VALID_OBJPTR(newptr); /* SLOW PATH: allocate_size overflows current gen0 page */ if(OVERFLOWS_GEN0(newptr)) { @@ -1302,12 +1305,15 @@ inline static void *allocate(const size_t request_size, const int type) newptr = allocate_slowpath(gc, allocate_size, newptr); } + + ASSERT_VALID_INFOPTR(GC_gen0_alloc_page_ptr); /* actual Allocation */ { objhead *info = (objhead *)PTR(GC_gen0_alloc_page_ptr); GC_gen0_alloc_page_ptr = newptr; + ASSERT_VALID_INFOPTR(GC_gen0_alloc_page_ptr); if (type == PAGE_ATOMIC) memset(info, 0, sizeof(objhead)); /* init objhead */ @@ -1333,7 +1339,6 @@ inline static void *fast_malloc_one_small_tagged(size_t request_size, int dirty) const size_t allocate_size = COMPUTE_ALLOC_SIZE_FOR_OBJECT_SIZE(request_size); newptr = GC_gen0_alloc_page_ptr + allocate_size; - ASSERT_VALID_OBJPTR(newptr); if(OVERFLOWS_GEN0(newptr)) { return GC_malloc_one_tagged(request_size); @@ -1341,6 +1346,7 @@ inline static void *fast_malloc_one_small_tagged(size_t request_size, int dirty) objhead *info = (objhead *)PTR(GC_gen0_alloc_page_ptr); GC_gen0_alloc_page_ptr = newptr; + ASSERT_VALID_INFOPTR(GC_gen0_alloc_page_ptr); if (dirty) memset(info, 0, sizeof(objhead)); /* init objhead */ @@ -1366,7 +1372,6 @@ void *GC_malloc_pair(void *car, void *cdr) const size_t allocate_size = PAIR_SIZE_IN_BYTES; newptr = GC_gen0_alloc_page_ptr + allocate_size; - ASSERT_VALID_OBJPTR(newptr); if(OVERFLOWS_GEN0(newptr)) { NewGC *gc = GC_get_GC(); @@ -1384,6 +1389,7 @@ void *GC_malloc_pair(void *car, void *cdr) else { objhead *info = (objhead *) PTR(GC_gen0_alloc_page_ptr); GC_gen0_alloc_page_ptr = newptr; + ASSERT_VALID_INFOPTR(GC_gen0_alloc_page_ptr); memset(info, 0, sizeof(objhead)); /* init objhead */ @@ -1391,8 +1397,9 @@ void *GC_malloc_pair(void *car, void *cdr) info->size = BYTES_MULTIPLE_OF_WORD_TO_WORDS(allocate_size); /* ALIGN_BYTES_SIZE bumbed us up to the next word boundary */ pair = OBJHEAD_TO_OBJPTR(info); - ASSERT_VALID_OBJPTR(pair); } + + ASSERT_VALID_OBJPTR(pair); /* initialize pair */ { @@ -1711,7 +1718,7 @@ inline static void resize_gen0(NewGC *gc, uintptr_t new_size) /* we're going to allocate onto the first page now */ gc->gen0.curr_alloc_page = gc->gen0.pages; GC_gen0_alloc_page_ptr = NUM(gc->gen0.curr_alloc_page->addr) + gc->gen0.curr_alloc_page->size; - ASSERT_VALID_OBJPTR(GC_gen0_alloc_page_ptr); + ASSERT_VALID_INFOPTR(GC_gen0_alloc_page_ptr); GC_gen0_alloc_page_end = NUM(gc->gen0.curr_alloc_page->addr) + GEN0_ALLOC_SIZE(gc->gen0.curr_alloc_page); /* set the two size variables */ @@ -2602,7 +2609,7 @@ static void wait_if_master_in_progress(NewGC *gc, Log_Master_Info *lmi) { /* MUST CALL WITH cangc lock */ static intptr_t NewGCMasterInfo_find_free_id() { - GC_ASSERT(MASTERGCINFO->live <= MASTERGCINFO->size); + GC_ASSERT(MASTERGCINFO->alive <= MASTERGCINFO->size); if ((MASTERGCINFO->alive + 1) == MASTERGCINFO->size) { MASTERGCINFO->size++; MASTERGCINFO->alive++; @@ -2621,6 +2628,7 @@ static intptr_t NewGCMasterInfo_find_free_id() { } printf("Error in MASTERGCINFO table\n"); abort(); + return 0; } static void NewGCMasterInfo_register_gc(NewGC *newgc) { From 65338f15ec5b05e45c7dbc569a221f89f4b7e9ec Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Wed, 24 Oct 2012 09:08:00 -0400 Subject: [PATCH 023/221] Examples for basic pict constructors & combiners --- collects/scribblings/slideshow/picts.scrbl | 168 ++++++++++++++++++--- 1 file changed, 149 insertions(+), 19 deletions(-) diff --git a/collects/scribblings/slideshow/picts.scrbl b/collects/scribblings/slideshow/picts.scrbl index 1b5ed151e8..f8ad929316 100644 --- a/collects/scribblings/slideshow/picts.scrbl +++ b/collects/scribblings/slideshow/picts.scrbl @@ -1,8 +1,13 @@ #lang scribble/doc @(require "ss.rkt" "pict-diagram.rkt" + scribble/eval (for-label racket/gui slideshow/code slideshow/flash slideshow/face slideshow/balloon slideshow/pict-convert)) +@(define ss-eval (make-base-eval)) +@(ss-eval '(require slideshow/pict racket/math racket/class racket/draw + racket/list)) + @title[#:style 'toc]{Making Pictures} @declare-exporting[slideshow/pict slideshow] @@ -133,12 +138,32 @@ of the resulting pict's @tech{bounding box}. In the three-argument case, the descent is @math{0} and the ascent is @racket[h] for the bounding box; in the five-argument case, @racket[a] and @racket[d] are used as the bounding box's ascent and descent. - + When the rendering procedure is called, the current pen and brush will be solid and in the pict's color (and linewidth), and the scale and offset of the drawing context will be set. The text mode will be transparent, but the font and text colors are not guaranteed to be anything in -particular.} +particular. + +@examples[#:eval ss-eval + (dc (λ (dc dx dy) + (define old-brush (send dc get-brush)) + (define old-pen (send dc get-pen)) + (send dc set-brush + (new brush% [style 'fdiagonal-hatch] + [color "darkslategray"])) + (send dc set-pen + (new pen% [width 3] [color "slategray"])) + (define path (new dc-path%)) + (send path move-to 0 0) + (send path line-to 50 0) + (send path line-to 25 50) + (send path close) + (send dc draw-path path dx dy) + (send dc set-brush old-brush) + (send dc set-pen old-pen)) + 50 50) +]} @defproc*[([(blank [size real? 0]) pict?] @@ -151,12 +176,16 @@ value used for both the width and height of the resulting pict's @tech{bounding box}. In the one- and two-argument case, the ascent and descent are @math{0} for the resulting pict's bounding box; in the three-argument case, the height is computed by -adding the given ascent and descent.} +adding the given ascent and descent. + +@examples[#:eval ss-eval + (blank 50) +]} @defproc[(text [content string?] [style text-style/c null] - [size (integer-in 1 1024) 12] + [size (integer-in 1 1024) 12] [angle real? 0]) pict?]{ @@ -211,15 +240,26 @@ The given @racket[size] is in pixels, but it is ignored if a The @racket[angle] is in radians, and positive values rotate counter-clockwise. For a non-zero @racket[angle], the resulting pict's @tech{bounding box} covers the rotated text, and the descent is zero -and the ascent is the height.} +and the ascent is the height. + +@examples[#:eval ss-eval + (text "tom collins") + (text "g & t" (cons 'bold 'roman)) + (text "martini" null 13 (/ pi 2)) +]} -@defproc*[([(hline [w real?] [h real?] +@defproc*[([(hline [w real?] [h real?] [#:segment seg-length (or/c #f real?) #f]) pict?] - [(vline [w real?] [h real?] + [(vline [w real?] [h real?] [#:segment seg-length (or/c #f real?) #f]) pict?])]{ -Straight lines, centered within their @tech{bounding box}es.} +Straight lines, centered within their @tech{bounding box}es. + +@examples[#:eval ss-eval + (hline 40 5) + (vline 5 40 #:segment 5) +]} @defproc[(frame [pict pict?] @@ -229,7 +269,13 @@ Straight lines, centered within their @tech{bounding box}es.} pict?]{ Frames a given pict. If the color or line width are provided, the -override settings supplied by the context.} +override settings supplied by the context. + +@examples[#:eval ss-eval + (frame (circle 30)) + (frame (circle 30) #:segment 5) + (frame (circle 30) #:color "chartreuse" #:line-width 3) +]} @defproc*[([(ellipse [w real?] [h real?]) pict?] [(circle [diameter real?]) pict?] @@ -240,11 +286,17 @@ Unfilled and filled ellipses. If @racket[draw-border?] is @racket[#f], then the pen is set to be transparent before drawing the ellipse. -} + +@examples[#:eval ss-eval + (ellipse 40 30) + (circle 30) + (filled-ellipse 30 40) + (disk 30) +]} @defproc*[([(rectangle [w real?] [h real?]) pict?] [(filled-rectangle [w real?] - [h real?] + [h real?] [#:draw-border? draw-border? any/c #t]) pict?])]{ @@ -252,7 +304,11 @@ Unfilled and filled rectangles. If @racket[draw-border?] is @racket[#f], then the pen is set to be transparent before drawing the rectangle. -} + +@examples[#:eval ss-eval + (rectangle 50 50) + (filled-rectangle 50 80) +]} @defproc*[([(rounded-rectangle [w real?] [h real?] [corner-radius real? -0.25] @@ -279,9 +335,13 @@ rotated, in radians. If @racket[draw-border?] is @racket[#f], then the pen is set to be transparent before drawing the rectangle. -} -@defproc[(bitmap [img (or/c path-string? +@examples[#:eval ss-eval + (rounded-rectangle 40 40 -0.3 #:angle (/ pi 4)) + (filled-rounded-rectangle 50 40) +]} + +@defproc[(bitmap [img (or/c path-string? (is-a?/c bitmap%) (is-a?/c image-snip%))]) pict]{ @@ -300,7 +360,13 @@ is not valid, or if the @racket[bitmap-draft-mode] parameter is set to Creates an arrow or arrowhead in the specific direction within a @racket[size] by @racket[size] pict. Points on the arrow may extend -slightly beyond the @tech{bounding box}.} +slightly beyond the @tech{bounding box}. + +@examples[#:eval ss-eval + (arrow 30 0) + (arrow 30 (/ pi 2)) + (arrowhead 30 0) +]} @defproc*[([(pip-line [dx real?] [dy real?] [size real?]) pict?] @@ -404,7 +470,28 @@ apply to the added line. When the @racket[hide-arrowhead?] argument is a true value, then space for an arrowhead is kept around the line, but the arrowhead itself is -not drawn.} +not drawn. + +@defexamples[#:eval ss-eval + (define pict-a (rectangle 40 40)) + (define pict-b (circle 40)) + (define combined (hc-append 200 pict-a pict-b)) + (pin-line combined + pict-a cc-find + pict-b cc-find) + (pin-arrow-line 30 combined + pict-a rc-find + pict-b lc-find + #:line-width 3 + #:style 'long-dash + #:color "medium goldenrod") + (pin-arrows-line 30 combined + pict-a rc-find + pict-b lc-find + #:start-angle (/ pi 11) + #:end-angle (- (/ pi 11)) + #:solid? #f) +]} @defthing[text-style/c contract?]{ @@ -445,7 +532,24 @@ similarly, the ascent of the result corresponds to the highest ascent-specified baseline. If at least one @racket[pict] is supplied, then the last element (as reported by @racket[pict-last]) for the result is @racket[(or (pict-last pict) pict)] for the using last -supplied @racket[pict].} +supplied @racket[pict]. + +@defexamples[#:eval ss-eval + (define combiners (list vl-append vc-append vr-append + ht-append htl-append hc-append + hbl-append hb-append)) + (define names (list "vl-append" "vc-append" "vr-append" + "ht-append" "htl-append" "hc-append" + "hbl-append" "hb-append")) + (define pict-a (colorize (filled-rectangle 60 30) "tomato")) + (define pict-b (colorize (disk 45) "cornflower blue")) + (define picts + (for/list ([combiner combiners] [name names]) + (list (text name null 15) + (combiner pict-a pict-b)))) + (take picts 4) + (drop picts 4) +]} @defproc*[([(lt-superimpose [pict pict?] ...) pict?] [(ltl-superimpose [pict pict?] ...) pict?] @@ -473,12 +577,36 @@ similarly, the ascent of the result corresponds to the highest ascent-specified baseline. The last element (as reported by @racket[pict-last]) for the result is the lowest, right-most among the last-element picts of the @racket[pict] arguments, as determined by -comparing the last-element bottom-right corners.} +comparing the last-element bottom-right corners. + +@defexamples[#:eval ss-eval + (define combiners (list lt-superimpose ltl-superimpose lc-superimpose + lbl-superimpose lb-superimpose ct-superimpose + ctl-superimpose cc-superimpose cbl-superimpose + cb-superimpose rt-superimpose rtl-superimpose + rc-superimpose rbl-superimpose rb-superimpose)) + (define names (list "lt-superimpose" "ltl-superimpose" "lc-superimpose" + "lbl-superimpose" "lb-superimpose" "ct-superimpose" + "ctl-superimpose" "cc-superimpose" "cbl-superimpose" + "cb-superimpose" "rt-superimpose" "rtl-superimpose" + "rc-superimpose" "rbl-superimpose" "rb-superimpose")) + (define pict-a (colorize (filled-rectangle 60 30) "tomato")) + (define pict-b (colorize (disk 45) "cornflower blue")) + (define picts + (for/list ([combiner combiners] [name names]) + (list (text name null 15) + (combiner pict-a pict-b)))) + (take picts 3) + (take (drop picts 3) 3) + (take (drop picts 6) 3) + (take (drop picts 9) 3) + (take (drop picts 12) 3) +]} @defproc*[([(pin-over [base pict?] [dx real?] [dy real?] [pict pict?]) pict?] - [(pin-over [base pict?] + [(pin-over [base pict?] [find-pict pict-path?] [find (pict? pict-path? . -> . (values real? real?))] [pict pict?]) @@ -1224,3 +1352,5 @@ and @racket[#f] otherwise. @defproc[(pict-convert [v pict-convertible?]) pict?]{ Requests a data conversion from @racket[v] to a pict. } + +@(close-eval ss-eval) From 06e52394411ce70bcb97f867b113c9f83b2c3650 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 24 Oct 2012 12:28:59 -0500 Subject: [PATCH 024/221] add rule names to the derivation struct change the intermediate data structures built up while building the derivation to use their own structs (instead of vectors) --- collects/redex/private/judgment-form.rkt | 64 +++++++++++++++--------- collects/redex/scribblings/ref.scrbl | 12 +++-- collects/redex/tests/tl-test.rkt | 29 +++++++---- 3 files changed, 67 insertions(+), 38 deletions(-) diff --git a/collects/redex/private/judgment-form.rkt b/collects/redex/private/judgment-form.rkt index de8ee6b931..2505bc0cfc 100644 --- a/collects/redex/private/judgment-form.rkt +++ b/collects/redex/private/judgment-form.rkt @@ -26,6 +26,20 @@ (require (for-template "term.rkt")) +(struct derivation (term name subs) + #:transparent + #:guard (λ (term name subs struct-name) + (unless (or (not name) (string? name)) + (raise-argument-error struct-name "(or/c string? #f)" 1 term name subs)) + (unless (and (list? subs) + (andmap derivation? subs)) + (raise-argument-error struct-name "derivation?" 2 term name subs)) + (values term name subs))) + +;; structs that hold intermediate results when building a derivation +(struct derivation-subs-acc (subs-so-far this-output) #:transparent) +(struct derivation-with-output-only (output name subs) #:transparent) + ;; Intermediate structures recording clause "extras" for typesetting. (define-struct metafunc-extra-side-cond (expr)) (define-struct metafunc-extra-where (lhs rhs)) @@ -223,11 +237,11 @@ (let ([compiled-pattern (compile-pattern lang output-pattern #t)]) (for/fold ([outputs '()]) ([sub-output (in-list output)]) (define sub-tree (if under-ellipsis? - (map (λ (x) (vector-ref x 0)) sub-output) - (vector-ref sub-output 0))) + (map derivation-subs-acc-subs-so-far sub-output) + (derivation-subs-acc-subs-so-far sub-output))) (define term (if under-ellipsis? - (map (λ (x) (vector-ref x 1)) sub-output) - (vector-ref sub-output 1))) + (map derivation-subs-acc-this-output sub-output) + (derivation-subs-acc-this-output sub-output))) (define mtchs (match-pattern compiled-pattern term)) (if mtchs (for/fold ([outputs outputs]) ([mtch (in-list mtchs)]) @@ -271,24 +285,20 @@ (case m [(I) s] [(O) (cons '_ s)]))) (define (wrapped . _) (set! outputs (form-proc form-proc input derivation-init)) - (for/list ([output outputs]) - (cons form-name (assemble mode input (vector-ref output 1))))) + (for/list ([output (in-list outputs)]) + (cons form-name (assemble mode input (derivation-with-output-only-output output))))) (apply trace-call form-name wrapped (assemble mode input spacers)) outputs) (form-proc form-proc input derivation-init))) (for/list ([v (in-list vecs)]) - (define subs (vector-ref v 0)) - (vector (and subs (derivation (cons form-name (assemble mode input (vector-ref v 1))) - (reverse subs))) - (vector-ref v 1)))) -(struct derivation (term subs) - #:transparent - #:guard (λ (term subs name) - (unless (and (list? subs) - (andmap derivation? subs)) - (error name "expected the second (subs) field to be a list of derivation?s, got: ~e" - subs)) - (values term subs))) + (define subs (derivation-with-output-only-subs v)) + (define rulename (derivation-with-output-only-name v)) + (define this-output (derivation-with-output-only-output v)) + (derivation-subs-acc + (and subs (derivation (cons form-name (assemble mode input this-output)) + rulename + (reverse subs))) + this-output))) (define (assemble mode inputs outputs) (let loop ([ms mode] [is inputs] [os outputs]) @@ -388,7 +398,7 @@ #'mk-judgment-form-proc #'#,lang #'judgment-form-lws '#,rule-names #'judgment-runtime-gen-clauses #'mk-judgment-gen-clauses)) (define mk-judgment-form-proc - (compile-judgment-form-proc #,judgment-form-name #,mode #,lang #,clauses #,position-contracts #,orig #,stx #,syn-err-name)) + (compile-judgment-form-proc #,judgment-form-name #,mode #,lang #,clauses #,rule-names #,position-contracts #,orig #,stx #,syn-err-name)) (define judgment-form-runtime-proc (mk-judgment-form-proc #,lang)) (define judgment-form-lws (compiled-judgment-form-lws #,clauses)) @@ -587,7 +597,7 @@ [(_ jf-expr) #'(#%expression (judgment-holds/derivation build-derivations #t jf-expr any))])) -(define-for-syntax (do-compile-judgment-form-proc name mode-stx clauses contracts nts orig stx syn-error-name) +(define-for-syntax (do-compile-judgment-form-proc name mode-stx clauses rule-names contracts nts orig stx syn-error-name) (with-syntax ([(init-jf-derivation-id) (generate-temporaries '(init-jf-derivation-id))]) (define mode (cdr (syntax->datum mode-stx))) (define-values (input-contracts output-contracts) @@ -595,7 +605,7 @@ (let-values ([(ins outs) (split-by-mode contracts mode)]) (values ins outs)) (values #f #f))) - (define (compile-clause clause) + (define (compile-clause clause clause-name) (syntax-case clause () [((_ . conc-pats) . prems) (let-values ([(input-pats output-pats) (split-by-mode (syntax->list #'conc-pats) mode)]) @@ -611,7 +621,9 @@ (struct-copy judgment-form (lookup-judgment-form-id name) [proc #'recur]))]) (bind-withs syn-error-name '() #'lang nts (syntax->list #'prems) - 'flatten #`(list (vector jf-derivation-id (term/nts (#,@output-pats) #,nts))) + 'flatten #`(list (derivation-with-output-only (term/nts (#,@output-pats) #,nts) + #,clause-name + jf-derivation-id)) (syntax->list #'(names ...)) (syntax->list #'(names/ellipses ...)) #f @@ -656,7 +668,7 @@ stx mode-stx))) - (with-syntax ([(((clause-proc-binding ...) clause-proc-body) ...) (map compile-clause clauses)]) + (with-syntax ([(((clause-proc-binding ...) clause-proc-body) ...) (map compile-clause clauses rule-names)]) (with-syntax ([(clause-proc-body-backwards ...) (reverse (syntax->list #'(clause-proc-body ...)))]) (if (identifier? orig) (with-syntax ([orig-mk (judgment-form-mk-proc (lookup-judgment-form-id orig))]) @@ -699,7 +711,7 @@ (define (check-judgment-form-contract form-name term+trees contracts mode modes) (define terms (if (eq? mode 'O) - (vector-ref term+trees 1) + (derivation-with-output-only-output term+trees) term+trees)) (define description (case mode @@ -879,9 +891,10 @@ (define-syntax (compile-judgment-form-proc stx) (syntax-case stx () - [(_ judgment-form-name mode-arg lang clauses ctcs orig full-def syn-err-name) + [(_ judgment-form-name mode-arg lang clauses rule-names ctcs orig full-def syn-err-name) (let ([nts (definition-nts #'lang #'full-def (syntax-e #'syn-err-name))] [clauses (syntax->list #'clauses)] + [rule-names (syntax->datum #'rule-names)] [syn-err-name (syntax-e #'syn-err-name)]) (mode-check (cdr (syntax->datum #'mode-arg)) clauses nts syn-err-name stx) (define contracts (syntax-case #'ctcs () @@ -895,6 +908,7 @@ (do-compile-judgment-form-proc #'judgment-form-name #'mode-arg clauses + rule-names contracts nts #'orig diff --git a/collects/redex/scribblings/ref.scrbl b/collects/redex/scribblings/ref.scrbl index 5fe9349420..12d515fc1d 100644 --- a/collects/redex/scribblings/ref.scrbl +++ b/collects/redex/scribblings/ref.scrbl @@ -1395,9 +1395,15 @@ See @racket[define-judgment-form] for examples. (build-derivations (even (s (s z))))] } -@defstruct[derivation ([term any/c] [subs (listof derivation?)])]{ - Represents a derivation from a judgment form. See also - @racket[build-derivations]. +@defstruct[derivation ([term any/c] [name (or/c string? #f)] [subs (listof derivation?)])]{ + Represents a derivation from a judgment form. + + The @racket[term] field holds an s-expression based rendering of the + conclusion of the derivation, the @racket[name] field holds the name + of the clause with @racket[term] as the conclusion, and + @racket[subs] contains the sub-derivations. + + See also @racket[build-derivations]. } @defidform[I]{ diff --git a/collects/redex/tests/tl-test.rkt b/collects/redex/tests/tl-test.rkt index 47cc3c3e02..d848fdbe13 100644 --- a/collects/redex/tests/tl-test.rkt +++ b/collects/redex/tests/tl-test.rkt @@ -2341,14 +2341,14 @@ (define-judgment-form L #:mode (J2 I O) - [-------- + [-------- "one" (J2 1 1)] - [-------- + [-------- two (J2 1 2)]) (test (build-derivations (J2 1 any)) - (list (derivation '(J2 1 1) '()) - (derivation '(J2 1 2) '()))) + (list (derivation '(J2 1 1) "one" '()) + (derivation '(J2 1 2) "two" '()))) @@ -2365,16 +2365,17 @@ (test (build-derivations (K (()) any)) (list (derivation '(K (()) (z)) - (list (derivation '(K () z) - '()))))) + #f + (list (derivation '(K () z) #f '()))))) (test (build-derivations (K (() ()) any)) (list (derivation '(K (() ()) (z z)) + #f (list - (derivation '(K () z) '()) - (derivation '(K () z) '()))))) + (derivation '(K () z) #f '()) + (derivation '(K () z) #f '()))))) (define-judgment-form L #:contract (J any any) @@ -2382,8 +2383,8 @@ [-------- (J () z)] [(J any_1 N) (J any_2 N) - ---------------------------- - (J (any_1 any_2) (s N))] + ---------------------------- + (J (any_1 any_2) (s N))] [(J any N) --------------- (J (any) (s N))]) @@ -2392,17 +2393,22 @@ (J ((()) (())) N)) (list (derivation '(J ((()) (())) (s (s z))) + #f (list (derivation '(J (()) (s z)) + #f (list (derivation '(J () z) + #F '()))) (derivation '(J (()) (s z)) + #f (list (derivation '(J () z) + #f '()))))))) (define-judgment-form L @@ -2414,12 +2420,15 @@ (test (build-derivations (J3 (()) N)) (list (derivation '(J3 (()) (s z)) + #f (list (derivation '(J (()) (s z)) + #f (list (derivation '(J () z) + #f '())))))))) From 7b149b7f5ac74c71da5914568def5d92df051cee Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 24 Oct 2012 13:25:09 -0600 Subject: [PATCH 025/221] Revert "Change thread test to use fake tcp with same structure" This reverts commit d39780a130923b59169f0f6fe7b046b7ba73b6cf. Matthew says this test is really about TCP, so it should not be changed. Although perhaps we can use a more basic TCP test to check if this should be done. --- collects/tests/racket/thread.rktl | 33 +++++-------------------------- 1 file changed, 5 insertions(+), 28 deletions(-) diff --git a/collects/tests/racket/thread.rktl b/collects/tests/racket/thread.rktl index 3e8d9a1c40..1f0744802f 100644 --- a/collects/tests/racket/thread.rktl +++ b/collects/tests/racket/thread.rktl @@ -613,36 +613,13 @@ (test #f semaphore-try-wait? s) (test #f semaphore-try-wait? s2)))) -(struct ftcp-listener (sema sr sw cr cw) - #:property prop:evt - (λ (l) - (handle-evt (semaphore-peek-evt (ftcp-listener-sema l)) - (λ (_) - l)))) -(define (ftcp-listen _0 _1 _2) - (define-values (cr sw) (make-pipe 4098)) - (define-values (sr cw) (make-pipe 4098)) - (ftcp-listener (make-semaphore 0) sr sw cr cw)) -(define (ftcp-addresses l _1) - (values #f l #f #f)) -(define (ftcp-connect h l) - (semaphore-post (ftcp-listener-sema l)) - (values (ftcp-listener-cr l) - (ftcp-listener-cw l))) -(define (ftcp-accept l) - (semaphore-wait (ftcp-listener-sema l)) - (values (ftcp-listener-sr l) - (ftcp-listener-sw l))) -(define (ftcp-close l) - (void)) - (define (listen-port x) - (let-values ([(la lp pa pp) (ftcp-addresses x #t)]) + (let-values ([(la lp pa pp) (tcp-addresses x #t)]) lp)) (let ([s (make-semaphore)] [s-t (make-semaphore)] - [l (ftcp-listen 0 5 #t)]) + [l (tcp-listen 0 5 #t)]) (let ([t (thread (lambda () (sync s-t)))] @@ -691,11 +668,11 @@ (set! t (thread (lambda () (semaphore-wait (make-semaphore))))) - (let-values ([(cr cw) (ftcp-connect "localhost" portnum)]) + (let-values ([(cr cw) (tcp-connect "localhost" portnum)]) (test l sync s t l r) (test l sync s t l r) - (let-values ([(sr sw) (ftcp-accept l)]) + (let-values ([(sr sw) (tcp-accept l)]) (try-all-blocked) (close-output-port w) @@ -743,7 +720,7 @@ (close-output-port cw) (test sr sync s t l sr)))) - (ftcp-close l))) + (tcp-close l))) ;; Test limited pipe output waiting: (let-values ([(r w) (make-pipe 5000)]) From 1bf5fda86947efa56cb4e42fb34fe28bc401a113 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 24 Oct 2012 13:04:35 -0700 Subject: [PATCH 026/221] fix `chaperone-prompt-tag' --- collects/tests/racket/prompt.rktl | 22 ++++++++++++++++++++++ src/racket/src/fun.c | 2 +- 2 files changed, 23 insertions(+), 1 deletion(-) diff --git a/collects/tests/racket/prompt.rktl b/collects/tests/racket/prompt.rktl index aa77227f8d..f4028a6b91 100644 --- a/collects/tests/racket/prompt.rktl +++ b/collects/tests/racket/prompt.rktl @@ -323,6 +323,28 @@ values (lambda (s) (string-append s "x"))))) +;; ---------------------------------------- +;; check that cc proc doesn't break abort proc + +(let () + (define l null) + + (define cpt + (chaperone-prompt-tag + (make-continuation-prompt-tag) + (λ (x) (set! l (cons "ho" l)) x) + (λ (x) (set! l (cons "hi" l)) x) + ;; commented out intentionally, see below + (λ (x) x))) + + (call-with-continuation-prompt + (λ () + (abort-current-continuation cpt 5)) + cpt + (λ (x) (+ 1 x))) + + (test '("ho" "hi") values l)) + ;; ---------------------------------------- ;; Check that when a continuation includes a continuation ;; application, that a captured requirement to apply a diff --git a/src/racket/src/fun.c b/src/racket/src/fun.c index be759d02e9..ffa773d5f0 100644 --- a/src/racket/src/fun.c +++ b/src/racket/src/fun.c @@ -5800,7 +5800,7 @@ Scheme_Object *do_chaperone_prompt_tag (const char *name, int is_impersonator, i ppos = 5; } else ppos = 4; - redirects = scheme_make_pair(argv[1], redirects); + redirects = scheme_make_pair(argv[2], redirects); } else { ppos = 3; redirects = argv[2]; From f43172128b12d08b3827ce0c3da0665ad2e7e0a2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 24 Oct 2012 13:12:22 -0700 Subject: [PATCH 027/221] fix syntax checking for `case' Merge to v5.3.1 --- collects/racket/private/case.rkt | 51 +++++++++++++++++++++++------- collects/tests/racket/syntax.rktl | 10 ++++++ collects/tests/racket/testing.rktl | 7 ++-- 3 files changed, 54 insertions(+), 14 deletions(-) diff --git a/collects/racket/private/case.rkt b/collects/racket/private/case.rkt index 1609e25402..201316b59b 100644 --- a/collects/racket/private/case.rkt +++ b/collects/racket/private/case.rkt @@ -32,18 +32,45 @@ (case/dispatch tmp [(k ...) e1 e2 ...] ... [else x1 x2 ...]))))] ;; Error cases - [(_ v (bad e1 e2 ...) . rest) - (raise-syntax-error - #f - "bad syntax (not a datum sequence)" - stx - (syntax bad))] - [(_ v clause . rest) - (raise-syntax-error - #f - "bad syntax (missing expression after datum sequence)" - stx - (syntax clause))] + [(_ v clause ...) + (let loop ([clauses (syntax->list #'(clause ...))]) + (unless (null? clauses) + (let ([clause (car clauses)]) + (syntax-case clause () + [((_ ...) _ _ ...) + (loop (cdr clauses))] + [((_ ...) . _) + (syntax-case clause () + [(_) + (raise-syntax-error + #f + "bad syntax (missing expression after datum sequence)" + stx + clause)] + [(_ . _) + (raise-syntax-error + #f + "bad syntax (illegal use of `.' in clause)" + stx + clause)] + [_ + (raise-syntax-error + #f + "bad syntax (ill-formed clause)" + stx + clause)])] + [(bad . _) + (raise-syntax-error + #f + "bad syntax (not a datum sequence)" + stx + (syntax bad))] + [_ + (raise-syntax-error + #f + "bad syntax (ill-formed clause)" + stx + (syntax bad))]))))] [(_ . v) (not (null? (syntax-e (syntax v)))) (raise-syntax-error diff --git a/collects/tests/racket/syntax.rktl b/collects/tests/racket/syntax.rktl index 788ed8b283..a73c98fefc 100644 --- a/collects/tests/racket/syntax.rktl +++ b/collects/tests/racket/syntax.rktl @@ -315,6 +315,16 @@ [else #f]))) (error-test #'(cond [(values 1 2) 8]) arity?) (error-test #'(case (values 1 2) [(a) 8]) arity?) +(syntax-test #'(case 1 []) #rx"ill-formed clause") +(syntax-test #'(case 1 [(y) 5] []) #rx"ill-formed clause") +(syntax-test #'(case 1 [x]) #rx"not a datum sequence") +(syntax-test #'(case 1 [(y) 5] [x]) #rx"not a datum sequence") +(syntax-test #'(case 1 [(y) 5] [x x]) #rx"not a datum sequence") +(syntax-test #'(case 1 [x x]) #rx"not a datum sequence") +(syntax-test #'(case 1 [(x)]) #rx"missing expression after datum sequence") +(syntax-test #'(case 1 [(y) 5] [(x)]) #rx"missing expression after datum sequence") +(syntax-test #'(case 1 [(x) . 8]) #rx"illegal use of `.'") +(syntax-test #'(case 1 [(x) 10] . 9) #rx"illegal use of `.'") ;; test larger `case' dispatches to trigger for binary-search ;; and hash-table-based dispatch: diff --git a/collects/tests/racket/testing.rktl b/collects/tests/racket/testing.rktl index 661a84b25e..671cbc0314 100644 --- a/collects/tests/racket/testing.rktl +++ b/collects/tests/racket/testing.rktl @@ -222,11 +222,14 @@ transcript. (define no-extra-if-tests? #f) -(define (syntax-test expr) +(define (syntax-test expr [rx #f]) (error-test expr exn:fail:syntax?) (unless no-extra-if-tests? (error-test (datum->syntax expr `(if #f ,expr (void)) expr) - exn:fail:syntax?))) + (lambda (x) + (and (exn:fail:syntax? x) + (or (not rx) + (regexp-match? rx (exn-message x)))))))) (define arity-test (case-lambda From b239a295447845d6214c1a346826256e5d6240bc Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 24 Oct 2012 17:03:35 -0700 Subject: [PATCH 028/221] doc repair Looks like it was an accidental incorrect update Merge to v5.3.1 --- collects/scribblings/reference/struct.scrbl | 12 +----------- 1 file changed, 1 insertion(+), 11 deletions(-) diff --git a/collects/scribblings/reference/struct.scrbl b/collects/scribblings/reference/struct.scrbl index 82954a27c7..a4ba5ac309 100644 --- a/collects/scribblings/reference/struct.scrbl +++ b/collects/scribblings/reference/struct.scrbl @@ -100,9 +100,7 @@ override the default @racket[equal?] definition through the [immutables (listof exact-nonnegative-integer?) null] [guard (or/c procedure? #f) #f] - [constructor-name (or/c symbol? #f) #f] - [generate (-> contract? (-> int? any/c))] - [exercise (-> contract? (-> int? any/c any/c))]) + [constructor-name (or/c symbol? #f) #f]) (values struct-type? struct-constructor-procedure? struct-predicate-procedure? @@ -176,14 +174,6 @@ If @racket[constructor-name] is not @racket[#f], it is used as the name of the generated @tech{constructor} procedure as returned by @racket[object-name] or in the printed form of the constructor value. -The @racket[generate] argument is used to define a new generator for -this structure type, which can be used to create random instances of -the structure type. For more information see @racket[contract-generate]. - -The @racket[exercise] argument allows you to define a function to verify -that a given value is an instance of your contract. This will also be used -for random generation. - The result of @racket[make-struct-type] is five values: @itemize[ From 717cf332b6a12d0cb9bf476d8b78335ed80188a4 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Wed, 24 Oct 2012 19:09:48 -0700 Subject: [PATCH 029/221] Don't copy chaperoned immutable vectors. --- collects/racket/contract/private/box.rkt | 2 +- collects/racket/contract/private/hash.rkt | 2 +- collects/racket/contract/private/vector.rkt | 4 +- collects/tests/racket/contract-test.rktl | 47 ++++++++++++++++++++- 4 files changed, 50 insertions(+), 5 deletions(-) diff --git a/collects/racket/contract/private/box.rkt b/collects/racket/contract/private/box.rkt index c2512cac9b..e0731d763e 100644 --- a/collects/racket/contract/private/box.rkt +++ b/collects/racket/contract/private/box.rkt @@ -78,7 +78,7 @@ [neg-elem-proj ((contract-projection elem-ctc) (blame-swap blame))]) (λ (val) (check-box/c ctc val blame) - (if (immutable? val) + (if (and (immutable? val) (not (chaperone? val))) (box-immutable (pos-elem-proj (unbox val))) (box-wrapper val (λ (b v) (pos-elem-proj v)) diff --git a/collects/racket/contract/private/hash.rkt b/collects/racket/contract/private/hash.rkt index b88c4da0ac..1fe4e68be4 100644 --- a/collects/racket/contract/private/hash.rkt +++ b/collects/racket/contract/private/hash.rkt @@ -169,7 +169,7 @@ (define neg-rng-proj (rng-proc (blame-add-context blame "the values of" #:swap? #t))) (λ (val) (check-hash/c ctc val blame) - (if (immutable? val) + (if (and (immutable? val) (not (chaperone? val))) (let ([hash-maker (cond [(hash-equal? val) make-immutable-hash] diff --git a/collects/racket/contract/private/vector.rkt b/collects/racket/contract/private/vector.rkt index 6155074821..83568fb9d5 100644 --- a/collects/racket/contract/private/vector.rkt +++ b/collects/racket/contract/private/vector.rkt @@ -104,7 +104,7 @@ (apply raise-blame-error blame val args))) (λ (val) (check val raise-blame #f) - (if (immutable? val) + (if (and (immutable? val) (not (chaperone? val))) (apply vector-immutable (for/list ([e (in-vector val)]) (elem-pos-proj e))) @@ -249,7 +249,7 @@ (blame-add-context blame (format "the ~a element of" (n->th i)) #:swap? #t)))]) (λ (val) (check-vector/c ctc val blame) - (if (immutable? val) + (if (and (immutable? val) (not (chaperone? val))) (apply vector-immutable (for/list ([e (in-vector val)] [i (in-naturals)]) diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 9177af5f49..77a2317ae8 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -4503,8 +4503,53 @@ 'make-flat-contract-bad-6 '(chaperone-contract? proj:prime-list/c) #t) + - +;; Adding tests for using vector/box/hash contracts with already chaperoned values + + (test/no-error + '(let ([v (chaperone-vector (vector-immutable 1) + (λ (vec i v) v) + (λ (vec i v) v))]) + (contract (vectorof any/c) v 'pos 'neg))) + + (test/no-error + '(let ([v (chaperone-vector (vector-immutable 1) + (λ (vec i v) v) + (λ (vec i v) v))]) + (contract (vector/c any/c) v 'pos 'neg))) + + (test/no-error + '(let ([v (chaperone-box (box-immutable 1) + (λ (box v) v) + (λ (box v) v))]) + (contract (box/c any/c) v 'pos 'neg))) + + (test/no-error + '(let ([v (chaperone-hash (make-immutable-hash (list (cons 1 2))) + (λ (hash k) (values k (λ (h k v) v))) + (λ (hash k v) (values k v)) + (λ (hash k) k) + (λ (hash k) k))]) + (contract (hash/c any/c any/c) v 'pos 'neg))) + + (test/no-error + '(let ([v (chaperone-hash (make-immutable-hasheq (list (cons 1 2))) + (λ (hash k) (values k (λ (h k v) v))) + (λ (hash k v) (values k v)) + (λ (hash k) k) + (λ (hash k) k))]) + (contract (hash/c any/c any/c) v 'pos 'neg))) + + (test/no-error + '(let ([v (chaperone-hash (make-immutable-hasheqv (list (cons 1 2))) + (λ (hash k) (values k (λ (h k v) v))) + (λ (hash k v) (values k v)) + (λ (hash k) k) + (λ (hash k) k))]) + (contract (hash/c any/c any/c) v 'pos 'neg))) + + ; ; ; From 9d4a3a6e07545cfad5ad38072ddaf2862eb9475a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 24 Oct 2012 23:45:38 -0500 Subject: [PATCH 030/221] improve the performance for dragging around items in mrlib/graph (used by Redex's traces window and the module browser) --- collects/mrlib/graph.rkt | 78 ++++++++++++++++++++-------------------- 1 file changed, 40 insertions(+), 38 deletions(-) diff --git a/collects/mrlib/graph.rkt b/collects/mrlib/graph.rkt index a87e68f0ca..62a702ba2e 100644 --- a/collects/mrlib/graph.rkt +++ b/collects/mrlib/graph.rkt @@ -3,7 +3,8 @@ racket/list racket/math racket/gui/base - (for-syntax racket/base) + racket/match + (for-syntax racket/base) racket/contract) (provide graph-snip<%> @@ -401,57 +402,58 @@ ;; invalidate-to-children/parents : snip dc -> void ;; invalidates the region containing this snip and ;; all of its children and parents. - (inherit invalidate-bitmap-cache) (define/private (invalidate-to-children/parents snip dc) (when (is-a? snip graph-snip<%>) + (unless (eq? last-dc dc) + (define-values (w h a s) (send dc get-text-extent "Label" #f #f 0)) + (set! last-dc dc) + (set! text-height h)) (let* ([parents-and-children (append (get-all-parents snip) (get-all-children snip))] - [rects (eliminate-redundancies (get-rectangles snip parents-and-children))] + [rects (get-rectangles snip parents-and-children)] [or/c (or/c-rects rects)] - [text-height (call-with-values - (λ () (send dc get-text-extent "Label" #f #f 0)) - (λ (w h a s) h))] [invalidate-rect (lambda (rect) - (invalidate-bitmap-cache (- (rect-left rect) text-height) - (- (rect-top rect) text-height) - (+ (- (rect-right rect) - (rect-left rect)) - text-height) - (+ (- (rect-bottom rect) - (rect-top rect)) - text-height)))]) + (save-rectangle-to-invalidate + (- (rect-left rect) text-height) + (- (rect-top rect) text-height) + (+ (- (rect-right rect) + (rect-left rect)) + text-height) + (+ (- (rect-bottom rect) + (rect-top rect)) + text-height)))]) (cond [(< (rect-area or/c) (apply + (map (lambda (x) (rect-area x)) rects))) (invalidate-rect or/c)] [else (for-each invalidate-rect rects)])))) + (inherit invalidate-bitmap-cache) + (define text-height #f) + (define last-dc #f) - ;; (listof rect) -> (listof rect) - (define/private (eliminate-redundancies rects) - (let loop ([rects rects] - [acc null]) - (cond - [(null? rects) acc] - [else (let ([r (car rects)]) - (cond - [(or (ormap (lambda (other-rect) (rect-included-in? r other-rect)) - (cdr rects)) - (ormap (lambda (other-rect) (rect-included-in? r other-rect)) - acc)) - (loop (cdr rects) - acc)] - [else - (loop (cdr rects) - (cons r acc))]))]))) + (define pending-invalidate-rectangle #f) + (define pending-invalidate-rectangle-timer #f) + (define/private (run-pending-invalidate-rectangle) + (define the-pending-invalidate-rectangle pending-invalidate-rectangle) + (set! pending-invalidate-rectangle #f) + (invalidate-bitmap-cache . the-pending-invalidate-rectangle)) - ;; rect-included-in? : rect rect -> boolean - (define/private (rect-included-in? r1 r2) - (and ((rect-left r1) . >= . (rect-left r2)) - ((rect-top r1) . >= . (rect-top r2)) - ((rect-right r1) . <= . (rect-right r2)) - ((rect-bottom r1) . <= . (rect-bottom r2)))) + (define/private (save-rectangle-to-invalidate l t r b) + (unless pending-invalidate-rectangle-timer + (set! pending-invalidate-rectangle-timer + (new timer% [notify-callback + (λ () (run-pending-invalidate-rectangle))]))) + (cond + [pending-invalidate-rectangle + (match pending-invalidate-rectangle + [(list l2 t2 r2 b2) + (set! pending-invalidate-rectangle + (list (min l l2) (min t t2) (max r r2) (max b b2)))])] + [else + (set! pending-invalidate-rectangle (list l t r b))]) + (send pending-invalidate-rectangle-timer start 20 #t)) ;; get-rectangles : snip (listof snip) -> rect ;; computes the rectangles that need to be invalidated for connecting @@ -519,7 +521,7 @@ (let ([old-font (send dc get-font)]) (when edge-label-font (send dc set-font edge-label-font)) - (draw-edges dc left top right bottom dx dy) + (unless pending-invalidate-rectangle (draw-edges dc left top right bottom dx dy)) (when edge-label-font (send dc set-font old-font)))) (super on-paint before? dc left top right bottom dx dy draw-caret)) From cb566b1ba4c685f89fa34ff853b096f27c5af93c Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 24 Oct 2012 18:26:58 -0500 Subject: [PATCH 031/221] fix font resizing performance bug in the traces window --- collects/redex/private/traces.rkt | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/collects/redex/private/traces.rkt b/collects/redex/private/traces.rkt index 5906c2445c..35f71de5af 100644 --- a/collects/redex/private/traces.rkt +++ b/collects/redex/private/traces.rkt @@ -291,7 +291,10 @@ (init-value (initial-font-size)) (max-value 127) (parent bottom-panel) - (callback (lambda (slider evt) (set-font-size (send slider get-value)))))) + (callback (lambda (slider evt) + (send graph-pb begin-edit-sequence) + (set-font-size (send slider get-value)) + (send graph-pb end-edit-sequence))))) (define lower-panel (instantiate horizontal-panel% () (parent bottom-panel) (stretchable-height #f))) From c6dc1e6ece441a7d56c2f2229dc9c0e144f8ff6f Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 25 Oct 2012 00:18:50 -0700 Subject: [PATCH 032/221] Improve contract generation in Typed Racket. This fixes several issues: - `Parameter` generates impersonator contracts correctly - `Any` handling now copies immutable data when possible - `Any` now recognizes more atomic base types Merge to 5.3.1. --- .../typed-racket/succeed/parameter-c.rkt | 7 +++ .../typed-racket/succeed/vector-chap.rkt | 11 +++++ .../typed-racket/private/type-contract.rkt | 43 +++++++++++++------ collects/typed-racket/utils/any-wrap.rkt | 21 +++++++-- 4 files changed, 65 insertions(+), 17 deletions(-) create mode 100644 collects/tests/typed-racket/succeed/parameter-c.rkt create mode 100644 collects/tests/typed-racket/succeed/vector-chap.rkt diff --git a/collects/tests/typed-racket/succeed/parameter-c.rkt b/collects/tests/typed-racket/succeed/parameter-c.rkt new file mode 100644 index 0000000000..95743ae043 --- /dev/null +++ b/collects/tests/typed-racket/succeed/parameter-c.rkt @@ -0,0 +1,7 @@ +#lang typed/racket/base + +(require/typed + rackunit + [current-check-around (Parameter Any)]) + + diff --git a/collects/tests/typed-racket/succeed/vector-chap.rkt b/collects/tests/typed-racket/succeed/vector-chap.rkt new file mode 100644 index 0000000000..7ca8aa758c --- /dev/null +++ b/collects/tests/typed-racket/succeed/vector-chap.rkt @@ -0,0 +1,11 @@ +#lang racket/load + +(module m1 racket + (define (f x y) (equal? x y)) + (provide f)) + +(module m2 typed/racket + (require/typed 'm1 [f (Any Any -> Boolean)]) + (f (vector 1 2) (vector 1 2))) + +(require 'm2) diff --git a/collects/typed-racket/private/type-contract.rkt b/collects/typed-racket/private/type-contract.rkt index 8b85b94c72..e537217a07 100644 --- a/collects/typed-racket/private/type-contract.rkt +++ b/collects/typed-racket/private/type-contract.rkt @@ -54,14 +54,24 @@ (let ([typ (if maker? ((map fld-t (Struct-flds (lookup-type-name (Name-id typ)))) #f . t:->* . typ) typ)]) - (with-syntax ([cnt (type->contract - typ - ;; this is for a `require/typed', so the value is not from the typed side - #:typed-side #f - #:kind kind - (lambda () (tc-error/stx prop "Type ~a could not be converted to a contract." typ)))]) - (quasisyntax/loc stx (define-values (n) (recursive-contract cnt #,(contract-kind->keyword kind))))))] - [_ (int-err "should never happen - not a define-values: ~a" (syntax->datum stx))])) + (with-syntax ([cnt (type->contract + typ + ;; this is for a `require/typed', so the value is not from the typed side + #:typed-side #f + #:kind kind + (λ () + (tc-error/stx + prop + "Type ~a could not be converted to a contract." + typ)))]) + (quasisyntax/loc + stx + (define-values (n) + (recursive-contract + cnt + #,(contract-kind->keyword kind))))))] + [_ (int-err "should never happen - not a define-values: ~a" + (syntax->datum stx))])) (define (change-contract-fixups forms) (map (lambda (e) @@ -89,7 +99,6 @@ (for/fold ((acc i)) ((v args)) (contract-kind-max2 v acc))) - (define (contract-kind-min i . args) (define (contract-kind-min2 x y) (cond @@ -106,7 +115,7 @@ (string->keyword (symbol->string sym))) (define (type->contract ty fail #:out [out? #f] #:typed-side [from-typed? #t] #:kind [kind 'impersonator]) - (define vars (make-parameter '())) + (define vars (make-parameter '())) (define current-contract-kind (make-parameter flat-sym)) (define (increase-current-contract-kind! kind) (current-contract-kind (contract-kind-max (current-contract-kind) kind))) @@ -138,7 +147,9 @@ [(and (> (length arrs) 1) ;; Keyword args, range and rest specs all the same. - (let ([xs (map (match-lambda [(arr: _ rng rest-spec _ kws) (list rng rest-spec kws)]) arrs)]) + (let ([xs (map (match-lambda [(arr: _ rng rest-spec _ kws) + (list rng rest-spec kws)]) + arrs)]) (foldl equal? (first xs) (rest xs))) ;; Positionals are monotonically increasing. (let-values ([(_ ok?) @@ -338,11 +349,13 @@ (match-let ([(Mu-name: n-nm _) ty]) (with-syntax ([(n*) (generate-temporaries (list n-nm))]) (parameterize ([vars (cons (list n #'n*) (vars))] - [current-contract-kind (contract-kind-min kind chaperone-sym)]) + [current-contract-kind + (contract-kind-min kind chaperone-sym)]) (define ctc (t->c b)) #`(letrec ([n* (recursive-contract #,ctc - #,(contract-kind->keyword (current-contract-kind)))]) + #,(contract-kind->keyword + (current-contract-kind)))]) n*))))] [(Value: #f) #'false/c] [(Instance: (? Mu? t)) @@ -389,7 +402,9 @@ #`(syntax/c #,(t->c t #:kind flat-sym))] [(Value: v) #`(flat-named-contract #,(format "~a" v) (lambda (x) (equal? x '#,v)))] ;; TODO Is this sound? - [(Param: in out) #`(parameter/c #,(t->c out))] + [(Param: in out) + (set-impersonator!) + #`(parameter/c #,(t->c out))] [(Hashtable: k v) (when (equal? kind flat-sym) (exit (fail))) #`(hash/c #,(t->c k #:kind chaperone-sym) #,(t->c v) #:immutable 'dont-care)] diff --git a/collects/typed-racket/utils/any-wrap.rkt b/collects/typed-racket/utils/any-wrap.rkt index da3f65d963..4699ad75bb 100644 --- a/collects/typed-racket/utils/any-wrap.rkt +++ b/collects/typed-racket/utils/any-wrap.rkt @@ -1,12 +1,12 @@ #lang racket/base -(require racket/match racket/contract/base racket/contract/combinator) +(require racket/match racket/contract/base racket/contract/combinator racket/flonum racket/fixnum) (define undef (letrec ([x x]) x)) (define (traverse b) (define (fail v) - (raise-blame-error (blame-swap b) v "Attempted to use a higher-order value passed as `Any`")) + (raise-blame-error (blame-swap b) v "Attempted to use a higher-order value passed as `Any` in untyped code")) (define (t v) (define (wrap-struct s) @@ -43,10 +43,25 @@ (match v [(? (lambda (e) (or (number? e) (string? e) (char? e) (symbol? e) - (null? e) (regexp? e) (eq? undef e) + (null? e) (regexp? e) (eq? undef e) (path? e) + (flvector? e) (flvector? e) (regexp? e) (keyword? e) (bytes? e) (boolean? e) (void? e)))) v] [(cons x y) (cons (t x) (t y))] + [(? vector? (? immutable?)) + ;; fixme -- should have an immutable for/vector + (vector->immutable-vector + (for/vector #:length (vector-length v) + ([i (in-vector v)]) (t i)))] + [(? box? (? immutable?)) (box-immutable (t (unbox v)))] + ;; fixme -- handling keys + ;; [(? hasheq? (? immutable?)) + ;; (for/hasheq ([(k v) (in-hash v)]) (values k v))] + ;; [(? hasheqv? (? immutable?)) + ;; (for/hasheqv ([(k v) (in-hash v)]) (values k v))] + + [(? hash? (? immutable?)) + (for/hash ([(k v) (in-hash v)]) (values (t k) (t v)))] [(? vector?) (chaperone-vector v (lambda (v i e) (t e)) (lambda (v i e) (fail v)))] From fa5846cb0c32b11e15cbfb0ca6e1fa2aadbd876e Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 26 Oct 2012 11:05:53 -0700 Subject: [PATCH 033/221] Flvectors and Fxvectors are higher-order if we give them restricted float types. --- collects/typed-racket/utils/any-wrap.rkt | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/collects/typed-racket/utils/any-wrap.rkt b/collects/typed-racket/utils/any-wrap.rkt index 4699ad75bb..fcac9b5334 100644 --- a/collects/typed-racket/utils/any-wrap.rkt +++ b/collects/typed-racket/utils/any-wrap.rkt @@ -1,6 +1,6 @@ #lang racket/base -(require racket/match racket/contract/base racket/contract/combinator racket/flonum racket/fixnum) +(require racket/match racket/contract/base racket/contract/combinator) (define undef (letrec ([x x]) x)) @@ -44,8 +44,7 @@ [(? (lambda (e) (or (number? e) (string? e) (char? e) (symbol? e) (null? e) (regexp? e) (eq? undef e) (path? e) - (flvector? e) (flvector? e) (regexp? e) - (keyword? e) (bytes? e) (boolean? e) (void? e)))) + (regexp? e) (keyword? e) (bytes? e) (boolean? e) (void? e)))) v] [(cons x y) (cons (t x) (t y))] [(? vector? (? immutable?)) From 7f23a85e1598190bea7276623a48af058e3f897e Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 26 Oct 2012 14:46:32 -0600 Subject: [PATCH 034/221] fixing PR13210 --- .../web-server/scribblings/tutorial/continue.scrbl | 10 +++++----- .../scribblings/tutorial/examples/test-static.rkt | 8 ++++---- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/collects/web-server/scribblings/tutorial/continue.scrbl b/collects/web-server/scribblings/tutorial/continue.scrbl index b248fb4a63..fe4c957dcc 100644 --- a/collects/web-server/scribblings/tutorial/continue.scrbl +++ b/collects/web-server/scribblings/tutorial/continue.scrbl @@ -661,10 +661,10 @@ following content: web-server/insta (define (start request) (response/xexpr - '(html (head (title "Testing")) - (link ((rel "stylesheet") - (href "/test-static.css") - (type "text/css"))) + '(html (head (title "Testing") + (link ((rel "stylesheet") + (href "/test-static.css") + (type "text/css")))) (body (h1 "Testing") (h2 "This is a header") (p "This is " (span ((class "hot")) "hot") "."))))) @@ -1255,7 +1255,7 @@ For example, @racket[input-string] is itself a library @racket[title] to that string. @racket[input-string] is rendered as @racketresult[`(input ([type "text"] [name -,_fresh_name]))], so @racket[(formlet-dispay +,_fresh_name]))], so @racket[(formlet-display new-post-formlet)] is rendered as: @racketresultblock[ (list '(input ([type "text"] [name "input_0"])) diff --git a/collects/web-server/scribblings/tutorial/examples/test-static.rkt b/collects/web-server/scribblings/tutorial/examples/test-static.rkt index e97db77a8c..d43ef02c3f 100644 --- a/collects/web-server/scribblings/tutorial/examples/test-static.rkt +++ b/collects/web-server/scribblings/tutorial/examples/test-static.rkt @@ -1,10 +1,10 @@ #lang web-server/insta (define (start request) (response/xexpr - '(html (head (title "Testing")) - (link ((rel "stylesheet") - (href "/test-static.css") - (type "text/css"))) + '(html (head (title "Testing") + (link ((rel "stylesheet") + (href "/test-static.css") + (type "text/css")))) (body (h1 "This is a header") (p "This is " (span ((class "hot")) "hot") "."))))) (static-files-path "htdocs") From f16e76ca3275608479d9b49845c421c89a931162 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 26 Oct 2012 15:26:39 -0600 Subject: [PATCH 035/221] second attempt at removing reliance on tcp. available has been greatly simplified because it relied on the behavior the thread.rktl test is actually testing --- collects/tests/net/available.rkt | 70 ++++--------------------------- collects/tests/racket/thread.rktl | 4 +- 2 files changed, 10 insertions(+), 64 deletions(-) diff --git a/collects/tests/net/available.rkt b/collects/tests/net/available.rkt index 9fc245f2c9..3b67aa85f2 100644 --- a/collects/tests/net/available.rkt +++ b/collects/tests/net/available.rkt @@ -5,75 +5,19 @@ racket/port racket/contract) -(define to-client #"0") -(define to-server #"1") (define (tcp-localhost-available?) (with-handlers ([exn? (λ (x) #f)]) (define the-listener - (tcp-listen 0 4 #t #f)) + (tcp-listen 0 5 #t)) (define-values (local-host port end-host end-port) (tcp-addresses the-listener #t)) - (let loop ([listener the-listener] - [sip #f] [sop #f] - [connected? #f] - [cip #f] [cop #f]) - (if (and (not listener) - (not sip) - (not sop) - connected? - (not cip) - (not cop)) - #t - (sync - (if listener - (handle-evt - (tcp-accept-evt listener) - (match-lambda - [(list sip sop) - (tcp-close listener) - (loop #f sip sop connected? cip cop)])) - never-evt) - (if sop - (handle-evt - (write-bytes-avail-evt to-client sop) - (λ (written-bs-n) - (tcp-abandon-port sop) - (loop #f sip #f connected? cip cop))) - never-evt) - (if sip - (handle-evt - (read-bytes-evt 1 sip) - (λ (read-bs) - (unless (bytes=? to-server read-bs) - (error 'wrong)) - (tcp-abandon-port sip) - (loop #f #f sop connected? cip cop))) - never-evt) - (if connected? - never-evt - (handle-evt - always-evt - (λ (_) - (define-values (cip cop) - (tcp-connect "localhost" port)) - (loop listener sip sop #t cip cop)))) - (if cop - (handle-evt - (write-bytes-avail-evt to-server cop) - (λ (written-bs-n) - (tcp-abandon-port cop) - (loop listener sip sop connected? cip #f))) - never-evt) - (if cip - (handle-evt - (read-bytes-evt 1 cip) - (λ (read-bs) - (unless (bytes=? to-client read-bs) - (error 'wrong)) - (tcp-abandon-port cip) - (loop listener sip sop connected? #f cop))) - never-evt)))))) + (thread + (λ () + (tcp-accept the-listener) + (tcp-close the-listener))) + (tcp-connect "localhost" port) + #t)) (provide (contract-out diff --git a/collects/tests/racket/thread.rktl b/collects/tests/racket/thread.rktl index 1f0744802f..e8bf5125b4 100644 --- a/collects/tests/racket/thread.rktl +++ b/collects/tests/racket/thread.rktl @@ -613,6 +613,8 @@ (test #f semaphore-try-wait? s) (test #f semaphore-try-wait? s2)))) +(require tests/net/available) +(when (tcp-localhost-available?) (define (listen-port x) (let-values ([(la lp pa pp) (tcp-addresses x #t)]) lp)) @@ -720,7 +722,7 @@ (close-output-port cw) (test sr sync s t l sr)))) - (tcp-close l))) + (tcp-close l)))) ;; Test limited pipe output waiting: (let-values ([(r w) (make-pipe 5000)]) From 7e8ac872fec52fecf84e4ec6d62989e2b9304605 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 25 Oct 2012 16:48:54 -0500 Subject: [PATCH 036/221] add logging to mred's event callback mechanism to record how long event processing takes --- collects/drracket/private/rep.rkt | 15 +++++++++------ collects/mred/private/wx/common/queue.rkt | 19 ++++++++++++++++++- collects/scribblings/gui/win-overview.scrbl | 19 +++++++++++++++++++ 3 files changed, 46 insertions(+), 7 deletions(-) diff --git a/collects/drracket/private/rep.rkt b/collects/drracket/private/rep.rkt index b10234d420..7b9eb28bd9 100644 --- a/collects/drracket/private/rep.rkt +++ b/collects/drracket/private/rep.rkt @@ -1265,6 +1265,7 @@ TODO (thread (λ () + (struct gui-event (start? msec name) #:prefab) ;; forward system events the user's logger, and record any ;; events that happen on the user's logger to show in the GUI (let ([sys-evt (make-log-receiver drracket:init:system-logger 'debug)] @@ -1274,16 +1275,18 @@ TODO (handle-evt sys-evt (λ (logged) - (log-message user-logger - (vector-ref logged 0) - (vector-ref logged 1) - (vector-ref logged 2)) + (unless (gui-event? (vector-ref logged 2)) + (log-message user-logger + (vector-ref logged 0) + (vector-ref logged 1) + (vector-ref logged 2))) (loop))) (handle-evt user-evt (λ (vec) - (parameterize ([current-eventspace drracket:init:system-eventspace]) - (queue-callback (λ () (new-log-message vec)))) + (unless (gui-event? (vector-ref vec 2)) + (parameterize ([current-eventspace drracket:init:system-eventspace]) + (queue-callback (λ () (new-log-message vec))))) (loop)))))))) (initialize-parameters snip-classes) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index fab54e0f06..546efb2cb6 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -438,12 +438,23 @@ (define event-dispatch-handler (make-parameter really-dispatch-event)) +(define event-logger (make-logger 'gui-event (current-logger))) +;; start? : boolean -- indicates if this is a start of an event being handled or not +;; msec : start time if start? is #t, delta from start to end if start? is #f +;; name : (or/c #f symbol?) +(struct gui-event (start? msec name) #:prefab) + (define (handle-event thunk e) (call-with-continuation-prompt ; to delimit continuations (lambda () (call-with-continuation-prompt ; to delimit search for dispatch-event-key (lambda () ;; communicate the thunk to `really-dispatch-event': + (define before (current-inexact-milliseconds)) + (when (log-level? event-logger 'debug) + (log-message event-logger 'debug + "starting to handle an event" + (gui-event #t before (object-name thunk)))) (let ([b (box thunk)]) ;; use the event-dispatch handler: (with-continuation-mark dispatch-event-key b @@ -452,7 +463,13 @@ ;; to the original one, then do so now: (when (unbox b) (set-box! b #f) - (thunk)))) + (thunk))) + (define after (current-inexact-milliseconds)) + (when (log-level? event-logger 'debug) + (log-message event-logger 'debug + (format "handled an event: ~a msec" + (- after before)) + (gui-event #f (- after before) (object-name thunk))))) dispatch-event-prompt)))) (define yield diff --git a/collects/scribblings/gui/win-overview.scrbl b/collects/scribblings/gui/win-overview.scrbl index a3585dd348..1ce753c017 100644 --- a/collects/scribblings/gui/win-overview.scrbl +++ b/collects/scribblings/gui/win-overview.scrbl @@ -951,6 +951,25 @@ Along similar lines, if a button callback captures a continuation captured during a button callback is therefore potentially useful outside of the same callback. +@subsection{Logging} + +The GUI system logs the timing of when events are handled and how +long they take to be handled. Each event that involves a callback +into Racket code has two events logged, both of which use +the @racket[gui-event] struct: +@racketblock[(struct gui-event (start? msec name) #:prefab)] +The @racket[start?] field is a boolean indicating if this +event is logging the time when an event is starting to be handled, +or when it finishes. In the case that @racket[start?] is @racket[#t], +the @racket[msec] field is the result of +@racket[current-inexact-milliseconds]; when @racket[start?] is @racket[#f], +then the @racket[msec] field is the number of milliseconds that the +event handling took (the difference between @racket[current-inexact-milliseconds]'s +results before and after the handling). The @racket[name] field is +the name of the function that handled the event; in the case of a +@racket[queue-callback]-based event, it is the name of the thunk passed to +@racket[queue-callback]. + @section[#:tag "animation"]{Animation in Canvases} The content of a canvas is buffered, so if a canvas must be redrawn, From e89a121ae5e42366702a4674cd79b339151175a3 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 25 Oct 2012 16:57:38 -0500 Subject: [PATCH 037/221] add some first-cut logging information to drracket to track how long events take to be handled --- collects/drracket/private/get-extend.rkt | 19 ++++-- .../private/module-language-tools.rkt | 5 +- collects/drracket/private/module-language.rkt | 8 ++- .../private/syncheck/blueboxes-gui.rkt | 5 +- collects/drracket/private/syncheck/gui.rkt | 18 +++-- collects/drracket/private/unit.rkt | 5 +- collects/framework/private/color.rkt | 5 +- collects/framework/private/logging-timer.rkt | 66 +++++++++++++++++++ collects/framework/private/text.rkt | 7 +- 9 files changed, 113 insertions(+), 25 deletions(-) create mode 100644 collects/framework/private/logging-timer.rkt diff --git a/collects/drracket/private/get-extend.rkt b/collects/drracket/private/get-extend.rkt index 91f3814cf0..1b25d367b4 100644 --- a/collects/drracket/private/get-extend.rkt +++ b/collects/drracket/private/get-extend.rkt @@ -1,7 +1,8 @@ #lang racket/unit (require racket/class - "drsig.rkt") + "drsig.rkt" + framework/private/logging-timer) (import [prefix drracket:unit: drracket:unit^] [prefix drracket:frame: drracket:frame^] @@ -13,7 +14,7 @@ (export drracket:get/extend^) (define make-extender - (λ (get-base% name) + (λ (get-base% name [final-mixin values]) (let ([extensions (λ (x) x)] [built-yet? #f] [built #f] @@ -42,7 +43,7 @@ (λ () (unless built-yet? (set! built-yet? #t) - (set! built (extensions (get-base%)))) + (set! built (final-mixin (extensions (get-base%))))) built))))) (define (get-base-tab%) @@ -93,4 +94,14 @@ (drracket:unit:get-definitions-text%))))))) (define-values (extend-definitions-text get-definitions-text) - (make-extender get-base-definitions-text% 'definitions-text%)) + (make-extender get-base-definitions-text% + 'definitions-text% + (let ([add-on-paint-logging + (λ (%) + (class % + (define/override (on-paint before? dc left top right bottom dx dy draw-caret) + (log-timeline + (format "on-paint method of ~a area: ~a" (object-name this) (* (- right left) (- bottom top))) + (super on-paint before? dc left top right bottom dx dy draw-caret))) + (super-new)))]) + add-on-paint-logging))) diff --git a/collects/drracket/private/module-language-tools.rkt b/collects/drracket/private/module-language-tools.rkt index 748c7e6b5f..3ca2998d8f 100644 --- a/collects/drracket/private/module-language-tools.rkt +++ b/collects/drracket/private/module-language-tools.rkt @@ -8,7 +8,8 @@ racket/class racket/gui/base "drsig.rkt" - "local-member-names.rkt") + "local-member-names.rkt" + framework/private/logging-timer) (define op (current-output-port)) (define (oprintf . args) (apply fprintf op args)) @@ -136,7 +137,7 @@ (<= start hash-lang-last-location)) (unless timer - (set! timer (new timer% + (set! timer (new logging-timer% [notify-callback (λ () (when in-module-language? diff --git a/collects/drracket/private/module-language.rkt b/collects/drracket/private/module-language.rkt index da97d9f9e1..b44142e5c0 100644 --- a/collects/drracket/private/module-language.rkt +++ b/collects/drracket/private/module-language.rkt @@ -25,7 +25,9 @@ "rep.rkt" "eval-helpers.rkt" "local-member-names.rkt" - "rectangle-intersect.rkt") + "rectangle-intersect.rkt" + + framework/private/logging-timer) (define-runtime-path expanding-place.rkt "expanding-place.rkt") @@ -1316,7 +1318,7 @@ (define compilation-out-of-date? #f) - (define tmr (new timer% [notify-callback (lambda () (send-off))])) + (define tmr (new logging-timer% [notify-callback (lambda () (send-off))])) (define cb-proc (λ (sym new-val) (when new-val @@ -1783,7 +1785,7 @@ (define lang-wants-big-defs/ints-labels? #f) (define recently-typed-timer - (new timer% + (new logging-timer% [notify-callback (λ () (update-recently-typed #f) diff --git a/collects/drracket/private/syncheck/blueboxes-gui.rkt b/collects/drracket/private/syncheck/blueboxes-gui.rkt index e8d1bfcf24..d0d1480033 100644 --- a/collects/drracket/private/syncheck/blueboxes-gui.rkt +++ b/collects/drracket/private/syncheck/blueboxes-gui.rkt @@ -8,7 +8,8 @@ setup/dirs images/icons/misc "../rectangle-intersect.rkt" - string-constants) + string-constants + framework/private/logging-timer) (provide docs-text-mixin docs-editor-canvas-mixin syncheck:add-docs-range @@ -376,7 +377,7 @@ [else (super on-event evt)])) - (define timer (new timer% + (define timer (new logging-timer% [notify-callback (λ () (set! timer-running? #f) diff --git a/collects/drracket/private/syncheck/gui.rkt b/collects/drracket/private/syncheck/gui.rkt index 7d3b1464bd..f77ce27e48 100644 --- a/collects/drracket/private/syncheck/gui.rkt +++ b/collects/drracket/private/syncheck/gui.rkt @@ -48,7 +48,8 @@ If the namespace does not, they are colored the unbound color. "traversals.rkt" "annotate.rkt" "../tooltip.rkt" - "blueboxes-gui.rkt") + "blueboxes-gui.rkt" + framework/private/logging-timer) (provide tool@) (define orig-output-port (current-output-port)) @@ -969,7 +970,7 @@ If the namespace does not, they are colored the unbound color. ;; Starts or restarts a one-shot arrow draw timer (define/private (start-arrow-draw-timer delay-ms) (unless arrow-draw-timer - (set! arrow-draw-timer (make-object timer% (λ () (maybe-update-drawn-arrows))))) + (set! arrow-draw-timer (make-object logging-timer% (λ () (maybe-update-drawn-arrows))))) (send arrow-draw-timer start delay-ms #t)) ;; this will be set to a time in the future if arrows shouldn't be drawn until then @@ -1592,7 +1593,7 @@ If the namespace does not, they are colored the unbound color. (queue-callback (λ () (when (unbox bx) - (loop val 0))) + (log-timeline "continuing replay-compile-comp-trace" (loop val 0)))) #f)] [else (process-trace-element defs-text (car val)) @@ -2066,9 +2067,12 @@ If the namespace does not, they are colored the unbound color. (drracket:module-language-tools:add-online-expansion-handler online-comp.rkt 'go - (λ (defs-text val) (send (send (send defs-text get-canvas) get-top-level-window) - replay-compile-comp-trace - defs-text - val))))) + (λ (defs-text val) + (log-timeline + "replace-compile-comp-trace" + (send (send (send defs-text get-canvas) get-top-level-window) + replay-compile-comp-trace + defs-text + val)))))) (define-runtime-path online-comp.rkt "online-comp.rkt") diff --git a/collects/drracket/private/unit.rkt b/collects/drracket/private/unit.rkt index 6f51d1c35f..b7e1ecb2ea 100644 --- a/collects/drracket/private/unit.rkt +++ b/collects/drracket/private/unit.rkt @@ -44,7 +44,8 @@ module browser threading seems wrong. mzlib/date - framework/private/aspell) + framework/private/aspell + framework/private/logging-timer) (provide unit@) @@ -4544,7 +4545,7 @@ module browser threading seems wrong. (define num-running-frames (vector-length running-frames)) (define is-running? #f) (define frame 0) - (define timer (make-object timer% (λ () (refresh) (yield)) #f)) + (define timer (make-object logging-timer% (λ () (refresh) (yield)) #f)) (define/public (set-running r?) (cond [r? (unless is-running? (set! frame 4)) diff --git a/collects/framework/private/color.rkt b/collects/framework/private/color.rkt index ed3196efd9..7a6102c5a7 100644 --- a/collects/framework/private/color.rkt +++ b/collects/framework/private/color.rkt @@ -15,7 +15,8 @@ added get-regions string-constants "../preferences.rkt" "sig.rkt" - "aspell.rkt") + "aspell.rkt" + framework/private/logging-timer) (import [prefix icon: framework:icon^] [prefix mode: framework:mode^] @@ -519,7 +520,7 @@ added get-regions exn)) (set! tok-cor #f)))) #;(printf "begin lexing\n") - (when (coroutine-run 10 tok-cor) + (when (log-timeline "colorer coroutine" (coroutine-run 10 tok-cor)) (for-each (lambda (ls) (set-lexer-state-up-to-date?! ls #t)) lexer-states) diff --git a/collects/framework/private/logging-timer.rkt b/collects/framework/private/logging-timer.rkt new file mode 100644 index 0000000000..0c9ad724e2 --- /dev/null +++ b/collects/framework/private/logging-timer.rkt @@ -0,0 +1,66 @@ +#lang racket/base + +(require racket/gui/base + racket/class + (for-syntax racket/base)) + +(define timeline-logger (make-logger 'timeline (current-logger))) + +(provide logging-timer% + (struct-out timeline-info) + log-timeline) + +(define logging-timer% + (class timer% + (init notify-callback) + (define name (object-name notify-callback)) + (define wrapped-notify-callback + (λ () + (log-timeline + (format "~a timer fired" name) + (notify-callback)))) + (super-new [notify-callback wrapped-notify-callback]) + (define/override (start msec [just-once? #f]) + (log-timeline (format "~a timer started; msec ~s just-once? ~s" name msec just-once?)) + (super start msec just-once?)))) + + +(define-syntax (log-timeline stx) + (syntax-case stx () + [(_ info-string expr) + #'(log-timeline/proc + (and (log-level? timeline-logger 'debug) + info-string) + (λ () expr))] + [(_ info-string) + #'(log-timeline/proc + (and (log-level? timeline-logger 'debug) + info-string) + #f)])) + +(define (log-timeline/proc info expr) + (define start-time (current-inexact-milliseconds)) + (when info + (log-message timeline-logger 'debug + (format "~a start" info) + (timeline-info (if expr 'start 'once) + (current-process-milliseconds) + start-time))) + (when expr + (begin0 + (expr) + (when info + (define end-time (current-inexact-milliseconds)) + (log-message timeline-logger 'debug + (format "~a end; delta ms ~a" info (- end-time start-time)) + (timeline-info start-time + end-time + (current-inexact-milliseconds))))))) + + +;; what : (or/c 'start 'once flonum) +;; flonum means that this is an 'end' event and there should be +;; a start event corresponding to it with that milliseconds +;; process-milliseconds : fixnum +;; milliseconds : flonum -- time of this event +(struct timeline-info (what process-milliseconds milliseconds) #:transparent) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 9e8d8d7aa1..d66f8579ab 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -11,7 +11,8 @@ "autocomplete.rkt" mred/mred-sig mrlib/interactive-value-port - racket/list) + racket/list + "logging-timer.rkt") (require setup/xref scribble/xref scribble/manual-struct) @@ -1063,7 +1064,7 @@ (when searching-str (unless timer (set! timer - (new timer% + (new logging-timer% [notify-callback (λ () (run-after-edit-sequence @@ -1536,7 +1537,7 @@ ;; have not yet been propogated to the delegate (define todo '()) - (define timer (new timer% + (define timer (new logging-timer% [notify-callback (λ () ;; it should be the case that todo is always '() when the delegate is #f From c6caf11323d0199e0cb5e4bd80b33fb0da2ec20a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 26 Oct 2012 09:43:49 -0500 Subject: [PATCH 038/221] Adjust online check syntax's trace replay code so that it: - lets other events be handled based on how long it has been replaying the current trace (instead of based on the number of pieces in the trace that have been seen) - breaks up the syncheck:add-rename-menu pieces of the trace to be more granular (to make the previous point work better) This should make DrRacket more responsive when the trace is being replayed --- collects/drracket/private/syncheck/gui.rkt | 9 ++++++--- .../drracket/private/syncheck/traversals.rkt | 20 +++++++++++++++---- 2 files changed, 22 insertions(+), 7 deletions(-) diff --git a/collects/drracket/private/syncheck/gui.rkt b/collects/drracket/private/syncheck/gui.rkt index f77ce27e48..245e34747a 100644 --- a/collects/drracket/private/syncheck/gui.rkt +++ b/collects/drracket/private/syncheck/gui.rkt @@ -1582,6 +1582,7 @@ If the namespace does not, they are colored the unbound color. (send (send defs-text get-tab) add-bkg-running-color 'syncheck "orchid" cs-syncheck-running) (send defs-text syncheck:init-arrows) (let loop ([val val] + [start-time (current-inexact-milliseconds)] [i 0]) (cond [(null? val) @@ -1589,15 +1590,17 @@ If the namespace does not, they are colored the unbound color. (send defs-text syncheck:update-drawn-arrows) (send (send defs-text get-tab) remove-bkg-running-color 'syncheck) (set-syncheck-running-mode #f)] - [(= i 500) + [(and (i . > . 0) ;; check i just in case things are really strange + (20 . <= . (- (current-inexact-milliseconds) start-time))) (queue-callback (λ () (when (unbox bx) - (log-timeline "continuing replay-compile-comp-trace" (loop val 0)))) + (log-timeline "continuing replay-compile-comp-trace" + (loop val (current-inexact-milliseconds) 0)))) #f)] [else (process-trace-element defs-text (car val)) - (loop (cdr val) (+ i 1))])))) + (loop (cdr val) start-time (+ i 1))])))) (define/private (process-trace-element defs-text x) ;; using 'defs-text' all the time is wrong in the case of embedded editors, diff --git a/collects/drracket/private/syncheck/traversals.rkt b/collects/drracket/private/syncheck/traversals.rkt index abcb575df8..7675316bb6 100644 --- a/collects/drracket/private/syncheck/traversals.rkt +++ b/collects/drracket/private/syncheck/traversals.rkt @@ -1134,10 +1134,22 @@ (for/or ([(level id-set) (in-hash phase-to-map)]) (get-ids id-set new-id)))))))) #t)) - (send defs-text syncheck:add-rename-menu - id-as-sym - loc-lst - name-dup?))))))) + (define max-to-send-at-once 30) + (let loop ([loc-lst loc-lst] + [len (length loc-lst)]) + (cond + [(<= len max-to-send-at-once) + (send defs-text syncheck:add-rename-menu + id-as-sym + loc-lst + name-dup?)] + [else + (send defs-text syncheck:add-rename-menu + id-as-sym + (take loc-lst max-to-send-at-once) + name-dup?) + (loop (drop loc-lst max-to-send-at-once) + (- len max-to-send-at-once))])))))))) ;; remove-duplicates-stx : (listof syntax[original]) -> (listof syntax[original]) ;; removes duplicates, based on the source locations of the identifiers From 8bc3b70a3c1d521ce8be3844b6efe9829d55fb39 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 26 Oct 2012 21:48:58 -0500 Subject: [PATCH 039/221] clean up rectangle computations, fixing some bugs along the way --- collects/mrlib/graph.rkt | 69 ++++++++++++++++------------------------ 1 file changed, 28 insertions(+), 41 deletions(-) diff --git a/collects/mrlib/graph.rkt b/collects/mrlib/graph.rkt index 62a702ba2e..b466956d37 100644 --- a/collects/mrlib/graph.rkt +++ b/collects/mrlib/graph.rkt @@ -378,7 +378,7 @@ (let ([old-currently-overs currently-overs]) (set! currently-overs new-currently-overs) - (on-mouse-over-snips currently-overs) + (on-mouse-over-snips currently-overs) (for-each (lambda (old-currently-over) (invalidate-to-children/parents old-currently-over dc)) @@ -387,9 +387,8 @@ (lambda (new-currently-over) (invalidate-to-children/parents new-currently-over dc)) new-currently-overs)))) - - (define/public (on-mouse-over-snips snips) - (void)) + + (define/public (on-mouse-over-snips snips) (void)) ;; set-equal : (listof snip) (listof snip) -> boolean ;; typically lists will be small (length 1), @@ -404,37 +403,20 @@ ;; all of its children and parents. (define/private (invalidate-to-children/parents snip dc) (when (is-a? snip graph-snip<%>) - (unless (eq? last-dc dc) - (define-values (w h a s) (send dc get-text-extent "Label" #f #f 0)) - (set! last-dc dc) - (set! text-height h)) - (let* ([parents-and-children (append (get-all-parents snip) - (get-all-children snip))] - [rects (get-rectangles snip parents-and-children)] - [or/c (or/c-rects rects)] - [invalidate-rect - (lambda (rect) - (save-rectangle-to-invalidate - (- (rect-left rect) text-height) - (- (rect-top rect) text-height) - (+ (- (rect-right rect) - (rect-left rect)) - text-height) - (+ (- (rect-bottom rect) - (rect-top rect)) - text-height)))]) - (cond - [(< (rect-area or/c) - (apply + (map (lambda (x) (rect-area x)) rects))) - (invalidate-rect or/c)] - [else - (for-each invalidate-rect rects)])))) - (inherit invalidate-bitmap-cache) - (define text-height #f) - (define last-dc #f) + (define-values (_1 text-height _2 _3) (send dc get-text-extent "Label" #f #f 0)) + (define parents-and-children (append (get-all-parents snip) + (get-all-children snip))) + (define rects (get-rectangles snip parents-and-children)) + (for ([rect (in-list rects)]) + (save-rectangle-to-invalidate + (- (rect-left rect) text-height) + (- (rect-top rect) text-height) + (+ (rect-right rect) text-height) + (+ (rect-bottom rect) text-height))))) (define pending-invalidate-rectangle #f) (define pending-invalidate-rectangle-timer #f) + (inherit invalidate-bitmap-cache) (define/private (run-pending-invalidate-rectangle) (define the-pending-invalidate-rectangle pending-invalidate-rectangle) (set! pending-invalidate-rectangle #f) @@ -445,15 +427,16 @@ (set! pending-invalidate-rectangle-timer (new timer% [notify-callback (λ () (run-pending-invalidate-rectangle))]))) - (cond - [pending-invalidate-rectangle - (match pending-invalidate-rectangle - [(list l2 t2 r2 b2) - (set! pending-invalidate-rectangle - (list (min l l2) (min t t2) (max r r2) (max b b2)))])] - [else - (set! pending-invalidate-rectangle (list l t r b))]) + (add-to-pending-indvalidate-rectangle l t r b) (send pending-invalidate-rectangle-timer start 20 #t)) + + (define/private (add-to-pending-indvalidate-rectangle l t r b) + (set! pending-invalidate-rectangle + (match pending-invalidate-rectangle + [(list l2 t2 r2 b2) + (list (min l l2) (min t t2) (max r r2) (max b b2))] + [#f + (list l t r b)]))) ;; get-rectangles : snip (listof snip) -> rect ;; computes the rectangles that need to be invalidated for connecting @@ -521,7 +504,11 @@ (let ([old-font (send dc get-font)]) (when edge-label-font (send dc set-font edge-label-font)) - (unless pending-invalidate-rectangle (draw-edges dc left top right bottom dx dy)) + (cond + [pending-invalidate-rectangle + (add-to-pending-indvalidate-rectangle left top right bottom)] + [else + (draw-edges dc left top right bottom dx dy)]) (when edge-label-font (send dc set-font old-font)))) (super on-paint before? dc left top right bottom dx dy draw-caret)) From 736e6efc2d173480ad0b81afd8ce589af392edc1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 26 Oct 2012 08:50:37 -0700 Subject: [PATCH 040/221] recognize `struct' bindings as constant The JIT takes advantage of known-constant bindings to avoid the check that a variable is still bound to a structure predicate, selector, or mutator; that makes the code short enough to really inline. The inlined version takes about half the time of the indirect version. The compiler does not yet track bindings precisely enough to recognize constants for sub-type declarations. --- .../shootout/binarytrees-normal.rkt | 49 ++ src/racket/src/cstartup.inc | 62 +-- src/racket/src/eval.c | 10 +- src/racket/src/jit.h | 11 + src/racket/src/jitcommon.c | 382 ++++++++++------ src/racket/src/jitinline.c | 121 ++++- src/racket/src/module.c | 39 +- src/racket/src/optimize.c | 421 ++++++++++++------ src/racket/src/schpriv.h | 3 + src/racket/src/schvers.h | 4 +- src/racket/src/struct.c | 19 +- src/racket/src/validate.c | 7 +- 12 files changed, 783 insertions(+), 345 deletions(-) create mode 100644 collects/tests/racket/benchmarks/shootout/binarytrees-normal.rkt diff --git a/collects/tests/racket/benchmarks/shootout/binarytrees-normal.rkt b/collects/tests/racket/benchmarks/shootout/binarytrees-normal.rkt new file mode 100644 index 0000000000..15a4143d17 --- /dev/null +++ b/collects/tests/racket/benchmarks/shootout/binarytrees-normal.rkt @@ -0,0 +1,49 @@ +#lang racket/base + +;;; The Computer Language Benchmarks Game +;;; http://shootout.alioth.debian.org/ +;;; Derived from the Chicken variant by Sven Hartrumpf + +(require racket/cmdline racket/require (for-syntax racket/base) + (filtered-in (lambda (name) (regexp-replace #rx"unsafe-" name "")) + racket/unsafe/ops)) + +(struct leaf (val)) +(struct node leaf (left right)) + +(define (make item d) + (if (fx= d 0) + (leaf item) + (let ([item2 (fx* item 2)] [d2 (fx- d 1)]) + (node item (make (fx- item2 1) d2) (make item2 d2))))) + +(define (check t) + (let loop ([t t] [acc 0]) + (let ([acc (fx+ (leaf-val t) acc)]) + (if (node? t) + (loop (node-left t) + (fx- acc (loop (node-right t) 0))) + acc)))) + +(define min-depth 4) + +(define (main n) + (let ([max-depth (max (+ min-depth 2) n)]) + (let ([stretch-depth (+ max-depth 1)]) + (printf "stretch tree of depth ~a\t check: ~a\n" + stretch-depth + (check (make 0 stretch-depth)))) + (let ([long-lived-tree (make 0 max-depth)]) + (for ([d (in-range 4 (+ max-depth 1) 2)]) + (let ([iterations (expt 2 (+ (- max-depth d) min-depth))]) + (printf "~a\t trees of depth ~a\t check: ~a\n" + (* 2 iterations) + d + (for/fold ([c 0]) ([i (in-range iterations)]) + (fx+ c (fx+ (check (make i d)) + (check (make (fx- 0 i) d)))))))) + (printf "long lived tree of depth ~a\t check: ~a\n" + max-depth + (check long-lived-tree))))) + +(command-line #:args (n) (main (string->number n))) diff --git a/src/racket/src/cstartup.inc b/src/racket/src/cstartup.inc index aa06b8fe50..e08d4734b2 100644 --- a/src/racket/src/cstartup.inc +++ b/src/racket/src/cstartup.inc @@ -1,14 +1,14 @@ { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,50,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,51,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,51,0,0,0,1,0,0,10,0,14,0, -27,0,31,0,38,0,42,0,49,0,54,0,61,0,66,0,69,0,74,0,83, +21,0,25,0,29,0,36,0,41,0,54,0,61,0,66,0,69,0,74,0,83, 0,87,0,93,0,107,0,121,0,124,0,130,0,134,0,136,0,147,0,149,0, 163,0,170,0,192,0,194,0,208,0,19,1,48,1,59,1,70,1,96,1,129, 1,162,1,221,1,21,2,99,2,155,2,160,2,180,2,73,3,93,3,145,3, 211,3,100,4,242,4,40,5,51,5,130,5,0,0,92,7,0,0,69,35,37, -109,105,110,45,115,116,120,29,11,11,11,72,112,97,114,97,109,101,116,101,114, -105,122,101,63,97,110,100,66,100,101,102,105,110,101,63,108,101,116,66,117,110, -108,101,115,115,64,99,111,110,100,66,108,101,116,114,101,99,64,108,101,116,42, +109,105,110,45,115,116,120,29,11,11,11,66,100,101,102,105,110,101,63,97,110, +100,63,108,101,116,66,117,110,108,101,115,115,64,99,111,110,100,72,112,97,114, +97,109,101,116,101,114,105,122,101,66,108,101,116,114,101,99,64,108,101,116,42, 62,111,114,64,119,104,101,110,68,104,101,114,101,45,115,116,120,29,11,11,11, 65,113,117,111,116,101,29,94,2,15,68,35,37,107,101,114,110,101,108,11,29, 94,2,15,68,35,37,112,97,114,97,109,122,11,62,105,102,65,98,101,103,105, @@ -16,12 +16,12 @@ 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, -85,88,0,0,95,159,2,17,36,36,159,2,16,36,36,159,2,16,36,36,16, -20,2,8,2,2,2,4,2,2,2,5,2,2,2,6,2,2,2,7,2,2, -2,10,2,2,2,3,2,2,2,9,2,2,2,11,2,2,2,12,2,2,97, -37,11,8,240,85,88,0,0,93,159,2,16,36,37,16,2,2,13,161,2,2, -37,2,13,2,2,2,13,96,11,11,8,240,85,88,0,0,16,0,96,38,11, -8,240,85,88,0,0,16,0,18,98,64,104,101,114,101,13,16,6,36,2,14, +110,88,0,0,95,159,2,17,36,36,159,2,16,36,36,159,2,16,36,36,16, +20,2,3,2,2,2,4,2,2,2,5,2,2,2,6,2,2,2,10,2,2, +2,7,2,2,2,8,2,2,2,9,2,2,2,11,2,2,2,12,2,2,97, +37,11,8,240,110,88,0,0,93,159,2,16,36,37,16,2,2,13,161,2,2, +37,2,13,2,2,2,13,96,38,11,8,240,110,88,0,0,16,0,96,11,11, +8,240,110,88,0,0,16,0,18,98,64,104,101,114,101,13,16,6,36,2,14, 2,2,11,11,11,8,32,8,31,8,30,8,29,27,248,22,163,4,195,249,22, 156,4,80,158,39,36,251,22,89,2,18,248,22,104,199,12,249,22,79,2,19, 248,22,106,201,27,248,22,163,4,195,249,22,156,4,80,158,39,36,251,22,89, @@ -30,14 +30,14 @@ 81,194,248,22,80,193,249,22,156,4,80,158,39,36,251,22,89,2,18,248,22, 80,199,249,22,79,2,4,248,22,81,201,11,18,100,10,13,16,6,36,2,14, 2,2,11,11,11,8,32,8,31,8,30,8,29,16,4,11,11,2,20,3,1, -8,101,110,118,49,55,50,57,54,16,4,11,11,2,21,3,1,8,101,110,118, -49,55,50,57,55,27,248,22,81,248,22,163,4,196,28,248,22,87,193,20,14, +8,101,110,118,49,55,51,51,57,16,4,11,11,2,21,3,1,8,101,110,118, +49,55,51,52,48,27,248,22,81,248,22,163,4,196,28,248,22,87,193,20,14, 159,37,36,37,28,248,22,87,248,22,81,194,248,22,80,193,249,22,156,4,80, 158,39,36,250,22,89,2,22,248,22,89,249,22,89,248,22,89,2,23,248,22, 80,201,251,22,89,2,18,2,23,2,23,249,22,79,2,11,248,22,81,204,18, 100,11,13,16,6,36,2,14,2,2,11,11,11,8,32,8,31,8,30,8,29, -16,4,11,11,2,20,3,1,8,101,110,118,49,55,50,57,57,16,4,11,11, -2,21,3,1,8,101,110,118,49,55,51,48,48,248,22,163,4,193,27,248,22, +16,4,11,11,2,20,3,1,8,101,110,118,49,55,51,52,50,16,4,11,11, +2,21,3,1,8,101,110,118,49,55,51,52,51,248,22,163,4,193,27,248,22, 163,4,194,249,22,79,248,22,89,248,22,80,196,248,22,81,195,27,248,22,81, 248,22,163,4,23,197,1,249,22,156,4,80,158,39,36,28,248,22,64,248,22, 157,4,248,22,80,23,198,2,27,249,22,2,32,0,88,163,8,36,37,43,11, @@ -51,7 +51,7 @@ 249,22,2,32,0,88,163,8,36,37,47,11,9,222,33,43,248,22,163,4,248, 22,80,201,248,22,81,198,27,248,22,81,248,22,163,4,196,27,248,22,163,4, 248,22,80,195,249,22,156,4,80,158,40,36,28,248,22,87,195,250,22,90,2, -22,9,248,22,81,199,250,22,89,2,6,248,22,89,248,22,80,199,250,22,90, +22,9,248,22,81,199,250,22,89,2,5,248,22,89,248,22,80,199,250,22,90, 2,10,248,22,81,201,248,22,81,202,27,248,22,81,248,22,163,4,23,197,1, 27,249,22,1,22,93,249,22,2,22,163,4,248,22,163,4,248,22,80,199,248, 22,183,4,249,22,156,4,80,158,41,36,251,22,89,1,22,119,105,116,104,45, @@ -63,12 +63,12 @@ 193,20,14,159,37,36,37,249,22,156,4,80,158,39,36,27,248,22,163,4,248, 22,80,197,28,249,22,152,9,62,61,62,248,22,157,4,248,22,104,196,250,22, 89,2,22,248,22,89,249,22,89,21,93,2,27,248,22,80,199,250,22,90,2, -8,249,22,89,2,27,249,22,89,248,22,113,203,2,27,248,22,81,202,251,22, +7,249,22,89,2,27,249,22,89,248,22,113,203,2,27,248,22,81,202,251,22, 89,2,18,28,249,22,152,9,248,22,157,4,248,22,80,200,64,101,108,115,101, -10,248,22,80,197,250,22,90,2,22,9,248,22,81,200,249,22,79,2,8,248, +10,248,22,80,197,250,22,90,2,22,9,248,22,81,200,249,22,79,2,7,248, 22,81,202,99,13,16,6,36,2,14,2,2,11,11,11,8,32,8,31,8,30, -8,29,16,4,11,11,2,20,3,1,8,101,110,118,49,55,51,50,50,16,4, -11,11,2,21,3,1,8,101,110,118,49,55,51,50,51,18,158,94,10,64,118, +8,29,16,4,11,11,2,20,3,1,8,101,110,118,49,55,51,54,53,16,4, +11,11,2,21,3,1,8,101,110,118,49,55,51,54,54,18,158,94,10,64,118, 111,105,100,8,48,27,248,22,81,248,22,163,4,196,249,22,156,4,80,158,39, 36,28,248,22,64,248,22,157,4,248,22,80,197,250,22,89,2,28,248,22,89, 248,22,80,199,248,22,104,198,27,248,22,157,4,248,22,80,197,250,22,89,2, @@ -81,25 +81,25 @@ 11,2,12,36,46,37,16,0,36,16,1,2,13,37,11,11,11,16,0,16,0, 16,0,36,36,11,12,11,11,16,0,16,0,16,0,36,36,16,11,16,5,11, 20,15,16,2,20,14,159,36,36,37,80,158,36,36,36,20,113,159,36,16,1, -2,13,16,1,33,33,10,16,5,2,7,88,163,8,36,37,53,37,9,223,0, +2,13,16,1,33,33,10,16,5,2,6,88,163,8,36,37,53,37,9,223,0, 33,34,36,20,113,159,36,16,1,2,13,16,0,11,16,5,2,12,88,163,8, 36,37,53,37,9,223,0,33,35,36,20,113,159,36,16,1,2,13,16,0,11, 16,5,2,4,88,163,8,36,37,53,37,9,223,0,33,36,36,20,113,159,36, 16,1,2,13,16,1,33,37,11,16,5,2,11,88,163,8,36,37,56,37,9, 223,0,33,38,36,20,113,159,36,16,1,2,13,16,1,33,39,11,16,5,2, -6,88,163,8,36,37,58,37,9,223,0,33,42,36,20,113,159,36,16,1,2, +5,88,163,8,36,37,58,37,9,223,0,33,42,36,20,113,159,36,16,1,2, 13,16,0,11,16,5,2,9,88,163,8,36,37,53,37,9,223,0,33,44,36, 20,113,159,36,16,1,2,13,16,0,11,16,5,2,10,88,163,8,36,37,54, 37,9,223,0,33,45,36,20,113,159,36,16,1,2,13,16,0,11,16,5,2, -3,88,163,8,36,37,56,37,9,223,0,33,46,36,20,113,159,36,16,1,2, -13,16,0,11,16,5,2,8,88,163,8,36,37,58,37,9,223,0,33,47,36, -20,113,159,36,16,1,2,13,16,1,33,49,11,16,5,2,5,88,163,8,36, +8,88,163,8,36,37,56,37,9,223,0,33,46,36,20,113,159,36,16,1,2, +13,16,0,11,16,5,2,7,88,163,8,36,37,58,37,9,223,0,33,47,36, +20,113,159,36,16,1,2,13,16,1,33,49,11,16,5,2,3,88,163,8,36, 37,54,37,9,223,0,33,50,36,20,113,159,36,16,1,2,13,16,0,11,16, 0,94,2,16,2,17,93,2,16,9,9,36,0}; EVAL_ONE_SIZED_STR((char *)expr, 2028); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,50,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,51,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,126,0,0,0,1,0,0,8,0,21,0, 26,0,43,0,55,0,77,0,106,0,121,0,139,0,151,0,167,0,181,0,203, 0,219,0,236,0,2,1,13,1,19,1,28,1,35,1,42,1,54,1,70,1, @@ -373,7 +373,7 @@ 95,23,195,1,23,197,1,249,22,164,2,195,88,163,8,36,38,48,11,9,223, 3,33,96,28,197,86,94,20,18,159,11,80,158,42,49,193,20,18,159,11,80, 158,42,50,196,86,94,20,18,159,11,80,158,42,55,193,20,18,159,11,80,158, -42,56,196,193,28,193,80,158,38,49,80,158,38,55,248,22,8,88,163,8,32, +42,56,196,193,28,193,80,158,38,49,80,158,38,55,248,22,9,88,163,8,32, 37,8,40,8,240,0,240,94,0,9,224,1,2,33,97,0,7,35,114,120,34, 47,43,34,28,248,22,142,7,23,195,2,27,249,22,175,15,2,99,196,28,192, 28,249,22,191,3,248,22,103,195,248,22,181,3,248,22,145,7,198,249,22,7, @@ -579,7 +579,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 10007); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,50,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,51,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,12,0,0,0,1,0,0,15,0,40,0, 57,0,75,0,97,0,120,0,140,0,162,0,169,0,176,0,183,0,0,0,179, 1,0,0,74,35,37,112,108,97,99,101,45,115,116,114,117,99,116,1,23,115, @@ -606,7 +606,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 501); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,50,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,51,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,89,0,0,0,1,0,0,7,0,18,0, 45,0,51,0,60,0,67,0,89,0,102,0,128,0,145,0,167,0,175,0,187, 0,202,0,218,0,236,0,0,1,12,1,28,1,51,1,63,1,94,1,101,1, @@ -1012,7 +1012,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 8458); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,50,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,51,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,11,0,0,0,1,0,0,10,0,16,0, 29,0,44,0,58,0,78,0,90,0,104,0,118,0,170,0,0,0,98,1,0, 0,69,35,37,98,117,105,108,116,105,110,65,113,117,111,116,101,29,94,2,2, @@ -1020,7 +1020,7 @@ 114,107,11,29,94,2,2,68,35,37,112,97,114,97,109,122,11,29,94,2,2, 74,35,37,112,108,97,99,101,45,115,116,114,117,99,116,11,29,94,2,2,66, 35,37,98,111,111,116,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,111,90, +29,94,2,2,68,35,37,107,101,114,110,101,108,11,97,36,11,8,240,136,90, 0,0,100,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,8,36,36,159,2,9,36,36,159,2,9,36, 36,16,0,159,36,20,113,159,36,16,1,11,16,0,20,26,144,9,2,1,2, diff --git a/src/racket/src/eval.c b/src/racket/src/eval.c index 98c293b3f7..0f54e2ca8b 100644 --- a/src/racket/src/eval.c +++ b/src/racket/src/eval.c @@ -1889,10 +1889,15 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro, g = scheme_current_thread->ku.multiple.count; if (i == g) { + int is_st; + values = scheme_current_thread->ku.multiple.array; scheme_current_thread->ku.multiple.array = NULL; if (SAME_OBJ(values, scheme_current_thread->values_buffer)) scheme_current_thread->values_buffer = NULL; + + is_st = scheme_is_simple_make_struct_type(vals_expr, g, 1, 1); + for (i = 0; i < g; i++) { var = SCHEME_VEC_ELS(vec)[i+delta]; if (dm_env) { @@ -1913,7 +1918,10 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro, scheme_shadow(scheme_get_bucket_home(b), (Scheme_Object *)b->key, 1); if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_SEAL) { - ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED; + if (is_st) + ((Scheme_Bucket_With_Flags *)b)->flags |= (GLOB_IS_IMMUTATED | GLOB_IS_CONSISTENT); + else + ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED; } } } diff --git a/src/racket/src/jit.h b/src/racket/src/jit.h index edd9ebe0f6..24e92ff4e7 100644 --- a/src/racket/src/jit.h +++ b/src/racket/src/jit.h @@ -1266,6 +1266,17 @@ void scheme_jit_release_native_code(void *fnlized, void *p); int scheme_do_generate_common(mz_jit_state *jitter, void *_data); int scheme_do_generate_more_common(mz_jit_state *jitter, void *_data); +int scheme_save_struct_temp(mz_jit_state *jitter, int reg); +int scheme_restore_struct_temp(mz_jit_state *jitter, int reg); +int scheme_generate_struct_op(mz_jit_state *jitter, int kind, int for_branch, + Branch_Info *branch_info, int branch_short, + int result_ignored, + int check_proc, int check_arg_fixnum, + int type_pos, int field_pos, + int pop_and_jump, + jit_insn *refslow, jit_insn *refslow2, + jit_insn *bref_false, jit_insn *bref_true); + /**********************************************************************/ /* jit */ /**********************************************************************/ diff --git a/src/racket/src/jitcommon.c b/src/racket/src/jitcommon.c index 80711c9918..e9e99a72c7 100644 --- a/src/racket/src/jitcommon.c +++ b/src/racket/src/jitcommon.c @@ -101,21 +101,25 @@ static Scheme_Object *vector_check_chaperone_of(Scheme_Object *o, Scheme_Object return o; } -static int save_struct_temp(mz_jit_state *jitter) +static int save_struct_temp(mz_jit_state *jitter, int reg) { #ifdef MZ_USE_JIT_PPC - jit_movr_p(JIT_V(3), JIT_V1); + jit_movr_p(JIT_V(3), reg); #endif #ifdef MZ_USE_JIT_I386 # ifdef X86_ALIGN_STACK - mz_set_local_p(JIT_V1, JIT_LOCAL3); + mz_set_local_p(reg, JIT_LOCAL3); # else - jit_pushr_p(JIT_V1); + jit_pushr_p(reg); # endif #endif return 1; } +int scheme_save_struct_temp(mz_jit_state *jitter, int reg) { + return save_struct_temp(jitter, reg); +} + static int restore_struct_temp(mz_jit_state *jitter, int reg) { #ifdef MZ_USE_JIT_PPC @@ -131,6 +135,10 @@ static int restore_struct_temp(mz_jit_state *jitter, int reg) return 1; } +int scheme_restore_struct_temp(mz_jit_state *jitter, int reg) { + return restore_struct_temp(jitter, reg); +} + static void allocate_values(int count, Scheme_Thread *p) { Scheme_Object **a; @@ -1418,6 +1426,227 @@ static int gen_struct_slow(mz_jit_state *jitter, int kind, int ok_proc, return 1; } +int scheme_generate_struct_op(mz_jit_state *jitter, int kind, int for_branch, + Branch_Info *branch_info, int branch_short, + int result_ignored, + int check_proc, int check_arg_fixnum, + int type_pos, int field_pos, + int pop_and_jump, + GC_CAN_IGNORE jit_insn *refslow, GC_CAN_IGNORE jit_insn *refslow2, + GC_CAN_IGNORE jit_insn *bref_false, GC_CAN_IGNORE jit_insn *bref_true) +/* kind: pred (1), get (2), or set (3) + R0 is (potential) struct proc, R1 is (potential) struct. + In set mode, value to install is saved as a temp. */ +{ + GC_CAN_IGNORE jit_insn *ref2, *ref3, *bref1, *bref2, *refretry; + GC_CAN_IGNORE jit_insn *bref3, *bref4, *bref8, *ref9, *refdone; + + __START_SHORT_JUMPS__(branch_short); + + if (check_proc) { + (void)mz_bnei_t(refslow, JIT_R0, scheme_prim_type, JIT_R2); + jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Primitive_Proc *)0x0)->pp.flags); + jit_andi_i(JIT_R2, JIT_R2, SCHEME_PRIM_OTHER_TYPE_MASK); + (void)jit_bnei_i(refslow, JIT_R2, ((kind == 3) + ? SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER + : ((kind == 1) + ? SCHEME_PRIM_STRUCT_TYPE_PRED + : SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER))); + } + + CHECK_LIMIT(); + /* Check argument: */ + if (kind == 1) { + bref1 = jit_bmsi_ul(jit_forward(), JIT_R1, 0x1); + refretry = _jit.x.pc; + jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Object *)0x0)->type); + __START_INNER_TINY__(1); + ref2 = jit_beqi_i(jit_forward(), JIT_R2, scheme_structure_type); + ref3 = jit_beqi_i(jit_forward(), JIT_R2, scheme_proc_struct_type); + ref9 = jit_beqi_i(jit_forward(), JIT_R2, scheme_chaperone_type); + __END_INNER_TINY__(1); + bref2 = jit_bnei_i(jit_forward(), JIT_R2, scheme_proc_chaperone_type); + CHECK_LIMIT(); + __START_INNER_TINY__(1); + mz_patch_branch(ref9); + jit_ldxi_p(JIT_R1, JIT_R1, &SCHEME_CHAPERONE_VAL(0x0)); + (void)jit_jmpi(refretry); + mz_patch_branch(ref3); + __END_INNER_TINY__(1); + } else { + if (check_arg_fixnum) { + (void)jit_bmsi_ul(refslow2, JIT_R1, 0x1); + } + jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Object *)0x0)->type); + __START_INNER_TINY__(1); + ref2 = jit_beqi_i(jit_forward(), JIT_R2, scheme_structure_type); + __END_INNER_TINY__(1); + (void)jit_bnei_i(refslow2, JIT_R2, scheme_proc_struct_type); + bref1 = bref2 = NULL; + } + __START_INNER_TINY__(1); + mz_patch_branch(ref2); + __END_INNER_TINY__(1); + CHECK_LIMIT(); + + if (type_pos != 0) { + /* Put argument struct type in R2, target struct type in V1 */ + jit_ldxi_p(JIT_R2, JIT_R1, &((Scheme_Structure *)0x0)->stype); + if (type_pos < 0) { + jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val); + if (kind >= 2) { + jit_ldxi_p(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->struct_type); + } + } + CHECK_LIMIT(); + + if (type_pos < 0) { + /* common case: types are the same */ + if (kind >= 2) { + __START_INNER_TINY__(1); + bref8 = jit_beqr_p(jit_forward(), JIT_R2, JIT_V1); + __END_INNER_TINY__(1); + } else + bref8 = NULL; + } else + bref8 = NULL; + + jit_ldxi_i(JIT_R2, JIT_R2, &((Scheme_Struct_Type *)0x0)->name_pos); + if (type_pos < 0) { + jit_ldxi_i(JIT_V1, JIT_V1, &((Scheme_Struct_Type *)0x0)->name_pos); + /* Now R2 is argument depth, V1 is target depth */ + if (kind == 1) { + bref3 = jit_bltr_i(jit_forward(), JIT_R2, JIT_V1); + } else { + (void)jit_bltr_i(refslow2, JIT_R2, JIT_V1); + bref3 = NULL; + } + } else { + if (type_pos != 0) { + (void)jit_blti_i(refslow2, JIT_R2, type_pos); + } + bref3 = NULL; + } + CHECK_LIMIT(); + /* Lookup argument type at target type depth, put it in R2: */ + if (type_pos < 0) { + jit_lshi_ul(JIT_R2, JIT_V1, JIT_LOG_WORD_SIZE); + jit_addi_p(JIT_R2, JIT_R2, &((Scheme_Struct_Type *)0x0)->parent_types); + } + } else { + bref3 = NULL; + bref8 = NULL; + } + jit_ldxi_p(JIT_V1, JIT_R1, &((Scheme_Structure *)0x0)->stype); + if (type_pos < 0) { + jit_ldxr_p(JIT_R2, JIT_V1, JIT_R2); + } else { + jit_ldxi_p(JIT_R2, JIT_V1, (type_pos << JIT_LOG_WORD_SIZE) + (intptr_t)&(((Scheme_Struct_Type *)0x0)->parent_types)); + } + CHECK_LIMIT(); + + /* (Re-)load target type into V1: */ + jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val); + if (kind >= 2) { + jit_ldxi_p(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->struct_type); + } + + if (kind == 1) { + bref4 = jit_bner_p(jit_forward(), JIT_R2, JIT_V1); + + /* True branch: */ + if (!for_branch) { + (void)jit_movi_p(JIT_R0, scheme_true); + } else if (branch_info) { + scheme_branch_for_true(jitter, branch_info); + } else { + mz_patch_ucbranch(bref_true); +#ifdef MZ_USE_JIT_I386 +# ifndef X86_ALIGN_STACK + jit_popr_p(JIT_V1); +# endif +#endif + } + if (pop_and_jump) + mz_epilog(JIT_V1); + else if (!for_branch) { + __START_INNER_TINY__(1); + refdone = jit_jmpi(jit_forward()); + __END_INNER_TINY__(1); + } + + /* False branch: */ + if (branch_info) { + scheme_add_branch_false(branch_info, bref1); + scheme_add_branch_false(branch_info, bref2); + if (bref3) + scheme_add_branch_false(branch_info, bref3); + scheme_add_branch_false(branch_info, bref4); + } else { + mz_patch_branch(bref1); + mz_patch_branch(bref2); + if (bref3) + mz_patch_branch(bref3); + mz_patch_branch(bref4); + if (for_branch) { + mz_patch_branch(bref_false); + if (pop_and_jump) { + restore_struct_temp(jitter, JIT_V1); + mz_epilog_without_jmp(); + } + jit_jmpr(JIT_V1); + } else { + (void)jit_movi_p(JIT_R0, scheme_false); + if (pop_and_jump) + mz_epilog(JIT_V1); + } + if (!pop_and_jump) { + __START_INNER_TINY__(1); + mz_patch_ucbranch(refdone); + __END_INNER_TINY__(1); + } + } + } else { + (void)jit_bner_p(refslow2, JIT_R2, JIT_V1); + bref4 = NULL; + if (bref8) { + __START_INNER_TINY__(1); + mz_patch_branch(bref8); + __END_INNER_TINY__(1); + } + /* Extract field */ + if (field_pos < 0) { + jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val); + jit_ldxi_i(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->field); + jit_lshi_ul(JIT_V1, JIT_V1, JIT_LOG_WORD_SIZE); + jit_addi_p(JIT_V1, JIT_V1, &((Scheme_Structure *)0x0)->slots); + } else { + field_pos = (field_pos << JIT_LOG_WORD_SIZE) + (uintptr_t)&((Scheme_Structure *)0x0)->slots; + } + if (kind == 3) { + restore_struct_temp(jitter, JIT_R0); + if (field_pos < 0) + jit_stxr_p(JIT_V1, JIT_R1, JIT_R0); + else + jit_stxi_p(field_pos, JIT_R1, JIT_R0); + if (!result_ignored) + (void)jit_movi_p(JIT_R0, scheme_void); + } else { + if (field_pos < 0) + jit_ldxr_p(JIT_R0, JIT_R1, JIT_V1); + else + jit_ldxi_p(JIT_R0, JIT_R1, field_pos); + } + if (pop_and_jump) + mz_epilog(JIT_V1); + } + CHECK_LIMIT(); + + __END_SHORT_JUMPS__(branch_short); + + return 1; +} + static int common4(mz_jit_state *jitter, void *_data) { int i, ii, iii; @@ -1570,8 +1799,8 @@ static int common4(mz_jit_state *jitter, void *_data) for (i = 0; i < 4; i++) { /* pred, pred_branch, get, or set */ void *code; int kind, for_branch; - GC_CAN_IGNORE jit_insn *ref, *ref2, *ref3, *refslow, *refslow2, *bref1, *bref2, *refretry; - GC_CAN_IGNORE jit_insn *bref3, *bref4, *bref5, *bref6, *bref8, *ref9; + GC_CAN_IGNORE jit_insn *ref, *refslow, *refslow2; + GC_CAN_IGNORE jit_insn *bref5, *bref6; if ((ii == 1) && (i == 1)) continue; /* no multi variant of pred branch */ if ((ii == 2) && (i == 1)) continue; /* no tail variant of pred branch */ @@ -1592,7 +1821,7 @@ static int common4(mz_jit_state *jitter, void *_data) for_branch = 1; sjc.struct_pred_branch_code = jit_get_ip().ptr; /* Save target address for false branch: */ - save_struct_temp(jitter); + save_struct_temp(jitter, JIT_V1); } else if (i == 2) { kind = 2; for_branch = 0; @@ -1612,7 +1841,7 @@ static int common4(mz_jit_state *jitter, void *_data) else sjc.struct_set_code = jit_get_ip().ptr; /* Save value to install: */ - save_struct_temp(jitter); + save_struct_temp(jitter, JIT_V1); } mz_prolog(JIT_V1); @@ -1637,140 +1866,13 @@ static int common4(mz_jit_state *jitter, void *_data) /* Continue trying fast path: check proc */ mz_patch_branch(ref); - (void)mz_bnei_t(refslow, JIT_R0, scheme_prim_type, JIT_R2); - jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Primitive_Proc *)0x0)->pp.flags); - jit_andi_i(JIT_R2, JIT_R2, SCHEME_PRIM_OTHER_TYPE_MASK); - (void)jit_bnei_i(refslow, JIT_R2, ((kind == 3) - ? SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER - : ((kind == 1) - ? SCHEME_PRIM_STRUCT_TYPE_PRED - : SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER))); - CHECK_LIMIT(); - /* Check argument: */ - if (kind == 1) { - bref1 = jit_bmsi_ul(jit_forward(), JIT_R1, 0x1); - refretry = _jit.x.pc; - jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Object *)0x0)->type); - __START_INNER_TINY__(1); - ref2 = jit_beqi_i(jit_forward(), JIT_R2, scheme_structure_type); - ref3 = jit_beqi_i(jit_forward(), JIT_R2, scheme_proc_struct_type); - ref9 = jit_beqi_i(jit_forward(), JIT_R2, scheme_chaperone_type); - __END_INNER_TINY__(1); - bref2 = jit_bnei_i(jit_forward(), JIT_R2, scheme_proc_chaperone_type); - CHECK_LIMIT(); - __START_INNER_TINY__(1); - mz_patch_branch(ref9); - jit_ldxi_p(JIT_R1, JIT_R1, &SCHEME_CHAPERONE_VAL(0x0)); - (void)jit_jmpi(refretry); - mz_patch_branch(ref3); - __END_INNER_TINY__(1); - } else { - (void)jit_bmsi_ul(refslow2, JIT_R1, 0x1); - jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Object *)0x0)->type); - __START_INNER_TINY__(1); - ref2 = jit_beqi_i(jit_forward(), JIT_R2, scheme_structure_type); - __END_INNER_TINY__(1); - (void)jit_bnei_i(refslow2, JIT_R2, scheme_proc_struct_type); - bref1 = bref2 = NULL; - } - __START_INNER_TINY__(1); - mz_patch_branch(ref2); - __END_INNER_TINY__(1); - CHECK_LIMIT(); - - /* Put argument struct type in R2, target struct type in V1 */ - jit_ldxi_p(JIT_R2, JIT_R1, &((Scheme_Structure *)0x0)->stype); - jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val); - if (kind >= 2) { - jit_ldxi_p(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->struct_type); - } - CHECK_LIMIT(); - - /* common case: types are the same */ - if (kind >= 2) { - __START_INNER_TINY__(1); - bref8 = jit_beqr_p(jit_forward(), JIT_R2, JIT_V1); - __END_INNER_TINY__(1); - } else - bref8 = NULL; - - jit_ldxi_i(JIT_R2, JIT_R2, &((Scheme_Struct_Type *)0x0)->name_pos); - jit_ldxi_i(JIT_V1, JIT_V1, &((Scheme_Struct_Type *)0x0)->name_pos); - /* Now R2 is argument depth, V1 is target depth */ - if (kind == 1) { - bref3 = jit_bltr_i(jit_forward(), JIT_R2, JIT_V1); - } else { - (void)jit_bltr_i(refslow2, JIT_R2, JIT_V1); - bref3 = NULL; - } - CHECK_LIMIT(); - /* Lookup argument type at target type depth, put it in R2: */ - jit_lshi_ul(JIT_R2, JIT_V1, JIT_LOG_WORD_SIZE); - jit_addi_p(JIT_R2, JIT_R2, &((Scheme_Struct_Type *)0x0)->parent_types); - jit_ldxi_p(JIT_V1, JIT_R1, &((Scheme_Structure *)0x0)->stype); - jit_ldxr_p(JIT_R2, JIT_V1, JIT_R2); - CHECK_LIMIT(); - - /* Re-load target type into V1: */ - jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val); - if (kind >= 2) { - jit_ldxi_p(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->struct_type); - } - - if (kind == 1) { - bref4 = jit_bner_p(jit_forward(), JIT_R2, JIT_V1); - - /* True branch: */ - if (!for_branch) { - (void)jit_movi_p(JIT_R0, scheme_true); - } else { - mz_patch_ucbranch(bref6); -#ifdef MZ_USE_JIT_I386 -# ifndef X86_ALIGN_STACK - jit_popr_p(JIT_V1); -# endif -#endif - } - mz_epilog(JIT_V1); - - /* False branch: */ - mz_patch_branch(bref1); - mz_patch_branch(bref2); - mz_patch_branch(bref3); - mz_patch_branch(bref4); - if (for_branch) { - mz_patch_branch(bref5); - restore_struct_temp(jitter, JIT_V1); - mz_epilog_without_jmp(); - jit_jmpr(JIT_V1); - } else { - (void)jit_movi_p(JIT_R0, scheme_false); - mz_epilog(JIT_V1); - } - } else { - (void)jit_bner_p(refslow2, JIT_R2, JIT_V1); - bref4 = NULL; - __START_INNER_TINY__(1); - mz_patch_branch(bref8); - __END_INNER_TINY__(1); - /* Extract field */ - jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val); - jit_ldxi_i(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->field); - jit_lshi_ul(JIT_V1, JIT_V1, JIT_LOG_WORD_SIZE); - jit_addi_p(JIT_V1, JIT_V1, &((Scheme_Structure *)0x0)->slots); - if (kind == 3) { - restore_struct_temp(jitter, JIT_R0); - jit_stxr_p(JIT_V1, JIT_R1, JIT_R0); - (void)jit_movi_p(JIT_R0, scheme_void); - } else { - jit_ldxr_p(JIT_R0, JIT_R1, JIT_V1); - } - mz_epilog(JIT_V1); - } - CHECK_LIMIT(); - __END_SHORT_JUMPS__(1); + scheme_generate_struct_op(jitter, kind, for_branch, NULL, 1, 0, + 1, 1, -1, -1, + 1, refslow, refslow2, bref5, bref6); + CHECK_LIMIT(); + scheme_jit_register_sub_func(jitter, code, scheme_false); } } diff --git a/src/racket/src/jitinline.c b/src/racket/src/jitinline.c index e835bc0e3b..5dde16f57c 100644 --- a/src/racket/src/jitinline.c +++ b/src/racket/src/jitinline.c @@ -352,12 +352,27 @@ static int generate_inlined_type_test(mz_jit_state *jitter, Scheme_App2_Rec *app return 1; } +static Scheme_Object *extract_struct_constant(mz_jit_state *jitter, Scheme_Object *rator) +{ + if (SAME_TYPE(SCHEME_TYPE(rator), scheme_toplevel_type) + && (SCHEME_TOPLEVEL_FLAGS(rator) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_CONST) { + rator = scheme_extract_global(rator, jitter->nc, 1); + if (rator) + return ((Scheme_Bucket *)rator)->val; + } + + return NULL; +} + static int generate_inlined_struct_op(int kind, mz_jit_state *jitter, Scheme_Object *rator, Scheme_Object *rand, Scheme_Object *rand2, Branch_Info *for_branch, int branch_short, - int is_tail, int multi_ok) + int is_tail, int multi_ok, int result_ignored) /* de-sync'd ok; for branch, sync'd before */ { + GC_CAN_IGNORE jit_insn *ref, *ref2, *refslow; + Scheme_Object *inline_rator; + LOG_IT(("inlined struct op\n")); if (!rand2) { @@ -381,24 +396,49 @@ static int generate_inlined_struct_op(int kind, mz_jit_state *jitter, /* R0 is [potential] predicate/getter/setting, R1 is struct. V1 is value for setting. */ + if ((kind == INLINE_STRUCT_PROC_PRED) /* REMOVEME */ + || (kind == INLINE_STRUCT_PROC_GET) + || (kind == INLINE_STRUCT_PROC_SET)) { + inline_rator = extract_struct_constant(jitter, rator); + if (inline_rator && (kind != INLINE_STRUCT_PROC_PRED)) { + __START_SHORT_JUMPS__(1); + ref = jit_bmci_ul(jit_forward(), JIT_R1, 0x1); + refslow = _jit.x.pc; + if (kind == INLINE_STRUCT_PROC_SET) + scheme_restore_struct_temp(jitter, JIT_V1); + __END_SHORT_JUMPS__(1); + } else { + ref = NULL; + refslow = NULL; + } + } else { + inline_rator = NULL; + ref = NULL; + refslow = NULL; + } + if (for_branch) { scheme_prepare_branch_jump(jitter, for_branch); CHECK_LIMIT(); - __START_SHORT_JUMPS__(for_branch->branch_short); - scheme_add_branch_false_movi(for_branch, jit_patchable_movi_p(JIT_V1, jit_forward())); - __END_SHORT_JUMPS__(for_branch->branch_short); - (void)jit_calli(sjc.struct_pred_branch_code); - __START_SHORT_JUMPS__(for_branch->branch_short); - scheme_branch_for_true(jitter, for_branch); - __END_SHORT_JUMPS__(for_branch->branch_short); - CHECK_LIMIT(); + if (!inline_rator) { + __START_SHORT_JUMPS__(for_branch->branch_short); + scheme_add_branch_false_movi(for_branch, jit_patchable_movi_p(JIT_V1, jit_forward())); + __END_SHORT_JUMPS__(for_branch->branch_short); + (void)jit_calli(sjc.struct_pred_branch_code); + __START_SHORT_JUMPS__(for_branch->branch_short); + scheme_branch_for_true(jitter, for_branch); + __END_SHORT_JUMPS__(for_branch->branch_short); + CHECK_LIMIT(); + } } else if (kind == INLINE_STRUCT_PROC_PRED) { - if (is_tail) { - (void)jit_calli(sjc.struct_pred_tail_code); - } else if (multi_ok) { - (void)jit_calli(sjc.struct_pred_multi_code); - } else { - (void)jit_calli(sjc.struct_pred_code); + if (!inline_rator) { + if (is_tail) { + (void)jit_calli(sjc.struct_pred_tail_code); + } else if (multi_ok) { + (void)jit_calli(sjc.struct_pred_multi_code); + } else { + (void)jit_calli(sjc.struct_pred_code); + } } } else if (kind == INLINE_STRUCT_PROC_GET) { if (is_tail) { @@ -446,6 +486,48 @@ static int generate_inlined_struct_op(int kind, mz_jit_state *jitter, scheme_signal_error("internal error: unknown struct-op mode"); } + if (inline_rator) { + int pos, tpos, jkind; + + inline_rator = ((Scheme_Primitive_Closure *)inline_rator)->val[0]; + if (kind == INLINE_STRUCT_PROC_PRED) { + pos = 0; + tpos = ((Scheme_Struct_Type *)inline_rator)->name_pos; + } else { + pos = ((Struct_Proc_Info *)inline_rator)->field; + tpos = ((Struct_Proc_Info *)inline_rator)->struct_type->name_pos; + } + + if (ref) { + __START_SHORT_JUMPS__(1); + ref2 = jit_jmpi(jit_forward()); + mz_patch_ucbranch(ref); + __END_SHORT_JUMPS__(1); + } else + ref2 = NULL; + + if (kind == INLINE_STRUCT_PROC_GET) + jkind = 2; + else if (kind == INLINE_STRUCT_PROC_SET) { + scheme_save_struct_temp(jitter, JIT_V1); + jkind = 3; + } else + jkind = 1; + + scheme_generate_struct_op(jitter, jkind, !!for_branch, + for_branch, branch_short, + result_ignored, + 0, 0, + tpos, pos, + 0, refslow, refslow, NULL, NULL); + + if (ref2) { + __START_SHORT_JUMPS__(1); + mz_patch_ucbranch(ref2); + __END_SHORT_JUMPS__(1); + } + } + return 1; } @@ -836,7 +918,8 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in int k; k = inlineable_struct_prim(rator, jitter, 1, 1); if (k == INLINE_STRUCT_PROC_PRED) { - generate_inlined_struct_op(1, jitter, rator, app->rand, NULL, for_branch, branch_short, is_tail, multi_ok); + generate_inlined_struct_op(1, jitter, rator, app->rand, NULL, for_branch, branch_short, is_tail, multi_ok, + result_ignored); scheme_direct_call_count++; return 1; } else if (((k == INLINE_STRUCT_PROC_GET) @@ -844,7 +927,8 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in || (k == INLINE_STRUCT_PROC_PROP_PRED) || (k == INLINE_STRUCT_PROC_CONSTR)) && !for_branch) { - generate_inlined_struct_op(k, jitter, rator, app->rand, NULL, for_branch, branch_short, is_tail, multi_ok); + generate_inlined_struct_op(k, jitter, rator, app->rand, NULL, for_branch, branch_short, is_tail, multi_ok, + result_ignored); scheme_direct_call_count++; return 1; } @@ -2066,7 +2150,8 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i int k; k = inlineable_struct_prim(rator, jitter, 2, 2); if (k) { - generate_inlined_struct_op(k, jitter, rator, app->rand1, app->rand2, for_branch, branch_short, is_tail, multi_ok); + generate_inlined_struct_op(k, jitter, rator, app->rand1, app->rand2, for_branch, branch_short, is_tail, multi_ok, + result_ignored); scheme_direct_call_count++; return 1; } diff --git a/src/racket/src/module.c b/src/racket/src/module.c index 1f1244d329..3a9e466d01 100644 --- a/src/racket/src/module.c +++ b/src/racket/src/module.c @@ -4121,6 +4121,7 @@ static void setup_accessible_table(Scheme_Module *m) for (i = 0; i < cnt; i++) { form = SCHEME_VEC_ELS(m->bodies[0])[i]; if (SAME_TYPE(SCHEME_TYPE(form), scheme_define_values_type)) { + int checked_st = 0, is_st = 0; for (k = SCHEME_VEC_SIZE(form); k-- > 1; ) { tl = SCHEME_VEC_ELS(form)[k]; if (SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_SEAL) { @@ -4135,21 +4136,31 @@ static void setup_accessible_table(Scheme_Module *m) won't generate such modules, but synthesized module bytecode might leave bindings out of the `toplevels' table. */ } else { - if ((SCHEME_VEC_SIZE(form) == 2) - && scheme_compiled_duplicate_ok(SCHEME_VEC_ELS(form)[0], 1)) { - /* record simple constant from cross-module propagation: */ - v = scheme_make_pair(v, SCHEME_VEC_ELS(form)[0]); - } else if (SAME_TYPE(SCHEME_TYPE(SCHEME_VEC_ELS(form)[0]), scheme_inline_variant_type)) { - /* record a potentially inlineable function */ - if (SCHEME_VEC_ELS(SCHEME_VEC_ELS(form)[0])[2] != (Scheme_Object *)m->prefix) - SCHEME_VEC_ELS(SCHEME_VEC_ELS(form)[0])[2] = (Scheme_Object *)m->prefix; - v = scheme_make_pair(v, SCHEME_VEC_ELS(form)[0]); - } else if (is_procedure_expression(SCHEME_VEC_ELS(form)[0])) { - /* record that it's constant across all instantiations: */ - v = scheme_make_pair(v, scheme_constant_key); + if (SCHEME_VEC_SIZE(form) == 2) { + if (scheme_compiled_duplicate_ok(SCHEME_VEC_ELS(form)[0], 1)) { + /* record simple constant from cross-module propagation: */ + v = scheme_make_pair(v, SCHEME_VEC_ELS(form)[0]); + } else if (SAME_TYPE(SCHEME_TYPE(SCHEME_VEC_ELS(form)[0]), scheme_inline_variant_type)) { + /* record a potentially inlineable function */ + if (SCHEME_VEC_ELS(SCHEME_VEC_ELS(form)[0])[2] != (Scheme_Object *)m->prefix) + SCHEME_VEC_ELS(SCHEME_VEC_ELS(form)[0])[2] = (Scheme_Object *)m->prefix; + v = scheme_make_pair(v, SCHEME_VEC_ELS(form)[0]); + } else if (is_procedure_expression(SCHEME_VEC_ELS(form)[0])) { + /* record that it's constant across all instantiations: */ + v = scheme_make_pair(v, scheme_constant_key); + } else { + /* record that it's fixed for any given instantiation: */ + v = scheme_make_pair(v, scheme_fixed_key); + } } else { - /* record that it's fixed for any given instantiation: */ - v = scheme_make_pair(v, scheme_fixed_key); + if (!checked_st) { + is_st = scheme_is_simple_make_struct_type(SCHEME_VEC_ELS(form)[0], + SCHEME_VEC_SIZE(form)-1, + 1, 1); + checked_st = 1; + } + if (is_st) + v = scheme_make_pair(v, scheme_constant_key); } scheme_hash_set(ht, tl, v); } diff --git a/src/racket/src/optimize.c b/src/racket/src/optimize.c index 639d9d48c3..6d3c11976d 100644 --- a/src/racket/src/optimize.c +++ b/src/racket/src/optimize.c @@ -149,59 +149,6 @@ void scheme_init_optimize() /* utils */ /*========================================================================*/ -static int is_current_inspector_call(Scheme_Object *a) -{ - if (SAME_TYPE(SCHEME_TYPE(a), scheme_application_type)) { - Scheme_App_Rec *app = (Scheme_App_Rec *)a; - if (!app->num_args - && SAME_OBJ(app->args[0], scheme_current_inspector_proc)) - return 1; - } - return 0; -} - -static int is_proc_spec_proc(Scheme_Object *p) -{ - Scheme_Type vtype; - - if (SCHEME_PROCP(p)) { - p = scheme_get_or_check_arity(p, -1); - if (SCHEME_INTP(p)) { - return (SCHEME_INT_VAL(p) >= 1); - } else if (SCHEME_STRUCTP(p) - && scheme_is_struct_instance(scheme_arity_at_least, p)) { - p = ((Scheme_Structure *)p)->slots[0]; - if (SCHEME_INTP(p)) - return (SCHEME_INT_VAL(p) >= 1); - } - return 0; - } - - vtype = SCHEME_TYPE(p); - - if (vtype == scheme_unclosed_procedure_type) { - if (((Scheme_Closure_Data *)p)->num_params >= 1) - return 1; - } - - return 0; -} - -static void note_match(int actual, int expected, Optimize_Info *warn_info) -{ - if (!warn_info || (expected == -1)) - return; - - if (actual != expected) { - scheme_log(warn_info->logger, - SCHEME_LOG_WARNING, - 0, - "warning%s: %d values produced when %d expected", - scheme_optimize_context_to_string(warn_info->context), - actual, expected); - } -} - int scheme_is_functional_primitive(Scheme_Object *rator, int num_args, int expected_vals) /* return 2 => results are a constant when arguments are constants */ { @@ -220,6 +167,21 @@ int scheme_is_functional_primitive(Scheme_Object *rator, int num_args, int expec return 0; } +static void note_match(int actual, int expected, Optimize_Info *warn_info) +{ + if (!warn_info || (expected == -1)) + return; + + if (actual != expected) { + scheme_log(warn_info->logger, + SCHEME_LOG_WARNING, + 0, + "warning%s: %d values produced when %d expected", + scheme_optimize_context_to_string(warn_info->context), + actual, expected); + } +} + int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, Optimize_Info *warn_info, int deeper_than, int no_id) /* Checks whether the bytecode `o' returns `vals' values with no @@ -358,33 +320,16 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, } if (vtype == scheme_application_type) { - /* Look for multiple values, or for `make-struct-type'. - (The latter is especially useful to Honu.) */ Scheme_App_Rec *app = (Scheme_App_Rec *)o; - if ((app->num_args >= 4) && (app->num_args <= 10) + + if ((app->num_args >= 4) && (app->num_args <= 11) && SAME_OBJ(scheme_make_struct_type_proc, app->args[0])) { note_match(5, vals, warn_info); - if ((vals == 5) || (vals < 0)) { - /* Look for (make-struct-type sym #f non-neg-int non-neg-int [omitable null]) */ - if (SCHEME_SYMBOLP(app->args[1]) - && SCHEME_FALSEP(app->args[2]) - && SCHEME_INTP(app->args[3]) - && (SCHEME_INT_VAL(app->args[3]) >= 0) - && SCHEME_INTP(app->args[4]) - && (SCHEME_INT_VAL(app->args[4]) >= 0) - && ((app->num_args < 5) - || scheme_omittable_expr(app->args[5], 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? app->num_args : 0), 0)) - && ((app->num_args < 6) - || SCHEME_NULLP(app->args[6])) - && ((app->num_args < 7) - || SCHEME_FALSEP(app->args[7]) - || is_current_inspector_call(app->args[7])) - && ((app->num_args < 8) - || SCHEME_FALSEP(app->args[8]) - || is_proc_spec_proc(app->args[8])) - && ((app->num_args < 9) - || SCHEME_NULLP(app->args[9]))) { + if (scheme_is_simple_make_struct_type(o, vals, resolved, 0)) { + if ((app->num_args < 5) + /* auto-field value: */ + || scheme_omittable_expr(app->args[5], 1, fuel - 1, resolved, warn_info, + deeper_than + (resolved ? app->num_args : 0), 0)) { return 1; } } @@ -445,6 +390,216 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, return 0; } +static int is_current_inspector_call(Scheme_Object *a) +{ + if (SAME_TYPE(SCHEME_TYPE(a), scheme_application_type)) { + Scheme_App_Rec *app = (Scheme_App_Rec *)a; + if (!app->num_args + && SAME_OBJ(app->args[0], scheme_current_inspector_proc)) + return 1; + } + return 0; +} + +static int is_proc_spec_proc(Scheme_Object *p) +{ + Scheme_Type vtype; + + if (SCHEME_PROCP(p)) { + p = scheme_get_or_check_arity(p, -1); + if (SCHEME_INTP(p)) { + return (SCHEME_INT_VAL(p) >= 1); + } else if (SCHEME_STRUCTP(p) + && scheme_is_struct_instance(scheme_arity_at_least, p)) { + p = ((Scheme_Structure *)p)->slots[0]; + if (SCHEME_INTP(p)) + return (SCHEME_INT_VAL(p) >= 1); + } + return 0; + } + + vtype = SCHEME_TYPE(p); + + if (vtype == scheme_unclosed_procedure_type) { + if (((Scheme_Closure_Data *)p)->num_params >= 1) + return 1; + } + + return 0; +} + +static int is_local_ref(Scheme_Object *e, int p, int r) +{ + return (SAME_TYPE(SCHEME_TYPE(e), scheme_local_type) + && (SCHEME_LOCAL_POS(e) >= p) + && (SCHEME_LOCAL_POS(e) < (p + r))); +} + +static int is_int_list(Scheme_Object *o, int up_to) +{ + if (SCHEME_PAIRP(o)) { + char *s, quick[8]; + Scheme_Object *e; + if (up_to <= 8) + s = quick; + else + s = (char *)scheme_malloc_atomic(up_to); + memset(s, 0, up_to); + while (SCHEME_PAIRP(o)) { + e = SCHEME_CAR(o); + o = SCHEME_CDR(o); + if (!SCHEME_INTP(e) + || (SCHEME_INT_VAL(e) < 0) + || (SCHEME_INT_VAL(e) > up_to) + || s[SCHEME_INT_VAL(e)]) + return 0; + s[SCHEME_INT_VAL(e)] = 1; + } + } + + return SCHEME_NULLP(o); +} + +static int is_values_with_accessors_and_mutators(Scheme_Object *e, int vals, int resolved) +{ + if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) { + Scheme_App_Rec *app = (Scheme_App_Rec *)e; + int delta = (resolved ? app->num_args : 0); + if (SAME_OBJ(app->args[0], scheme_values_func) + && (app->num_args == vals)) { + int i; + for (i = app->num_args; i > 0; i--) { + if (is_local_ref(app->args[1], delta, 5)) { + /* ok */ + } else if (SAME_TYPE(SCHEME_TYPE(app->args[i]), scheme_application3_type)) { + Scheme_App3_Rec *app3 = (Scheme_App3_Rec *)app->args[i]; + int delta2 = delta + (resolved ? 2 : 0); + if (SAME_OBJ(app3->rator, scheme_make_struct_field_accessor_proc)) { + if (!is_local_ref(app3->rand1, delta2+3, 1) + && SCHEME_SYMBOLP(app3->rand2)) + break; + } else if (SAME_OBJ(app3->rator, scheme_make_struct_field_mutator_proc)) { + if (!is_local_ref(app3->rand1, delta2+4, 1) + && SCHEME_SYMBOLP(app3->rand2)) + break; + } else + break; + } + } + if (i <= 0) + return 1; + } + } + + return 0; +} + +static Scheme_Object *skip_clears(Scheme_Object *body) +{ + if (SAME_TYPE(SCHEME_TYPE(body), scheme_sequence_type)) { + Scheme_Sequence *seq = (Scheme_Sequence *)body; + int i; + for (i = seq->count - 1; i--; ) { + if (!SAME_TYPE(SCHEME_TYPE(seq->array[i]), scheme_local_type)) + break; + } + if (i < 0) + return seq->array[seq->count-1]; + } + return body; +} + +int scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int resolved, int check_auto) +/* Checks whether it's a `make-struct-type' call that certainly succeeds + (i.e., no exception) --- pending a check of argument 5 if !check_auto */ +{ + if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) { + if ((vals == 5) || (vals < 0)) { + Scheme_App_Rec *app = (Scheme_App_Rec *)e; + + if ((app->num_args >= 4) && (app->num_args <= 11) + && SAME_OBJ(scheme_make_struct_type_proc, app->args[0])) { + if (SCHEME_SYMBOLP(app->args[1]) + && SCHEME_FALSEP(app->args[2]) /* super = #f */ + && SCHEME_INTP(app->args[3]) + && (SCHEME_INT_VAL(app->args[3]) >= 0) + && SCHEME_INTP(app->args[4]) + && (SCHEME_INT_VAL(app->args[4]) >= 0) + && ((app->num_args < 5) + /* auto-field value: */ + || !check_auto + || scheme_omittable_expr(app->args[5], 1, 3, resolved, NULL, -1, 0)) + && ((app->num_args < 6) + /* no properties: */ + || SCHEME_NULLP(app->args[6])) + && ((app->num_args < 7) + /* inspector: */ + || SCHEME_FALSEP(app->args[7]) + || is_current_inspector_call(app->args[7])) + && ((app->num_args < 8) + /* propcedure property: */ + || SCHEME_FALSEP(app->args[8]) + || is_proc_spec_proc(app->args[8])) + && ((app->num_args < 9) + /* immutables: */ + || is_int_list(app->args[9], + SCHEME_INT_VAL(app->args[3]))) + && ((app->num_args < 10) + /* guard: */ + || SCHEME_FALSEP(app->args[10])) + && ((app->num_args < 11) + /* constructor name: */ + || SCHEME_FALSEP(app->args[11]) + || SCHEME_SYMBOLP(app->args[11]))) { + return 1; + } + } + } + } + + if (SAME_TYPE(SCHEME_TYPE(e), scheme_compiled_let_void_type)) { + /* check for (let-values ([(: mk ? ref- set-!) (make-struct-type ...)]) (values ...)) + as generated by the expansion of `struct' */ + Scheme_Let_Header *lh = (Scheme_Let_Header *)e; + if ((lh->count == 5) && (lh->num_clauses == 1)) { + if (SAME_TYPE(SCHEME_TYPE(lh->body), scheme_compiled_let_value_type)) { + Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body; + if (SAME_TYPE(SCHEME_TYPE(lv->value), scheme_application_type) + && scheme_is_simple_make_struct_type(lv->value, 5, resolved, check_auto)) { + /* We have (let-values ([... (make-struct-type)]) ....), so make sure body + just uses `make-struct-field-{accessor,mutator}'. */ + if (is_values_with_accessors_and_mutators(lv->body, vals, resolved)) + return 1; + } + } + } + } + + if (SAME_TYPE(SCHEME_TYPE(e), scheme_let_void_type)) { + /* same thing, but in resolved form */ + Scheme_Let_Void *lvd = (Scheme_Let_Void *)e; + if (lvd->count == 5) { + if (SAME_TYPE(SCHEME_TYPE(lvd->body), scheme_let_value_type)) { + Scheme_Let_Value *lv = (Scheme_Let_Value *)lvd->body; + if ((lv->position == 0) && (lv->count == 5)) { + Scheme_Object *e2; + e2 = skip_clears(lv->value); + if (SAME_TYPE(SCHEME_TYPE(e2), scheme_application_type) + && scheme_is_simple_make_struct_type(e2, 5, resolved, check_auto)) { + /* We have (let-values ([... (make-struct-type)]) ....), so make sure body + just uses `make-struct-field-{accessor,mutator}'. */ + e2 = skip_clears(lv->body); + if (is_values_with_accessors_and_mutators(e2, vals, resolved)) + return 1; + } + } + } + } + } + + return 0; +} + static int single_valued_noncm_expression(Scheme_Object *expr, int fuel) /* Non-omittable but single-valued expresions that are not sensitive to being in tail position. */ @@ -4550,21 +4705,19 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) e = SCHEME_VEC_ELS(e)[1]; n = scheme_list_length(vars); - if (n == 1) { - if (IS_COMPILED_PROC(e)) { - Scheme_Toplevel *tl; + if ((n == 1) && IS_COMPILED_PROC(e)) { + Scheme_Toplevel *tl; - tl = (Scheme_Toplevel *)SCHEME_CAR(vars); - - if (!(SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_MUTATED)) { - int pos; - if (!consts) - consts = scheme_make_hash_table(SCHEME_hash_ptr); - pos = tl->position; - scheme_hash_set(consts, - scheme_make_integer(pos), - estimate_closure_size(e)); - } + tl = (Scheme_Toplevel *)SCHEME_CAR(vars); + + if (!(SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_MUTATED)) { + int pos; + if (!consts) + consts = scheme_make_hash_table(SCHEME_hash_ptr); + pos = tl->position; + scheme_hash_set(consts, + scheme_make_integer(pos), + estimate_closure_size(e)); } } } @@ -4625,56 +4778,60 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) cnst = 1; sproc = 1; } + } else if (scheme_is_simple_make_struct_type(e, n, 0, 1)) { + cnst = 1; } if (cnst) { Scheme_Toplevel *tl; + while (n--) { + tl = (Scheme_Toplevel *)SCHEME_CAR(vars); + vars = SCHEME_CDR(vars); - tl = (Scheme_Toplevel *)SCHEME_CAR(vars); + if (!(SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_MUTATED)) { + Scheme_Object *e2; - if (!(SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_MUTATED)) { - Scheme_Object *e2; - - if (sproc) { - e2 = scheme_make_noninline_proc(e); - } else if (IS_COMPILED_PROC(e)) { - e2 = optimize_clone(1, e, info, 0, 0); - if (e2) { - Scheme_Object *pr; - pr = scheme_make_raw_pair(scheme_make_raw_pair(e2, e), NULL); - if (cl_last) - SCHEME_CDR(cl_last) = pr; - else - cl_first = pr; - cl_last = pr; - } else + if (sproc) { e2 = scheme_make_noninline_proc(e); - } else { - e2 = e; - } + } else if (IS_COMPILED_PROC(e)) { + e2 = optimize_clone(1, e, info, 0, 0); + if (e2) { + Scheme_Object *pr; + pr = scheme_make_raw_pair(scheme_make_raw_pair(e2, e), NULL); + if (cl_last) + SCHEME_CDR(cl_last) = pr; + else + cl_first = pr; + cl_last = pr; + } else + e2 = scheme_make_noninline_proc(e); + } else { + e2 = e; + } - if (e2) { - int pos; - if (!consts) - consts = scheme_make_hash_table(SCHEME_hash_ptr); - pos = tl->position; - scheme_hash_set(consts, scheme_make_integer(pos), e2); - if (!re_consts) - re_consts = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(re_consts, scheme_make_integer(i_m), - scheme_make_integer(pos)); - } else { - /* At least mark it as fixed */ + if (e2) { + int pos; + if (!consts) + consts = scheme_make_hash_table(SCHEME_hash_ptr); + pos = tl->position; + scheme_hash_set(consts, scheme_make_integer(pos), e2); + if (!re_consts) + re_consts = scheme_make_hash_table(SCHEME_hash_ptr); + scheme_hash_set(re_consts, scheme_make_integer(i_m), + scheme_make_integer(pos)); + } else { + /* At least mark it as fixed */ - if (!fixed_table) { - fixed_table = scheme_make_hash_table(SCHEME_hash_ptr); - if (!consts) - consts = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(consts, scheme_false, (Scheme_Object *)fixed_table); - } - scheme_hash_set(fixed_table, scheme_make_integer(tl->position), scheme_true); - } - } + if (!fixed_table) { + fixed_table = scheme_make_hash_table(SCHEME_hash_ptr); + if (!consts) + consts = scheme_make_hash_table(SCHEME_hash_ptr); + scheme_hash_set(consts, scheme_false, (Scheme_Object *)fixed_table); + } + scheme_hash_set(fixed_table, scheme_make_integer(tl->position), scheme_true); + } + } + } } else { /* The binding is not inlinable/propagatable, but unless it's set!ed, it is constant after evaluating the definition. We diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index c81e6053a8..0311f11072 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -371,6 +371,8 @@ extern Scheme_Object *scheme_hash_ref_proc; extern Scheme_Object *scheme_box_proc; extern Scheme_Object *scheme_call_with_values_proc; extern Scheme_Object *scheme_make_struct_type_proc; +extern Scheme_Object *scheme_make_struct_field_accessor_proc; +extern Scheme_Object *scheme_make_struct_field_mutator_proc; extern Scheme_Object *scheme_current_inspector_proc; extern Scheme_Object *scheme_varref_const_p_proc; @@ -2869,6 +2871,7 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, int scheme_might_invoke_call_cc(Scheme_Object *value); int scheme_is_liftable(Scheme_Object *o, int bind_count, int fuel, int as_rator); int scheme_is_functional_primitive(Scheme_Object *rator, int num_args, int expected_vals); +int scheme_is_simple_make_struct_type(Scheme_Object *app, int vals, int resolved, int check_auto); int scheme_is_env_variable_boxed(Scheme_Comp_Env *env, int which); diff --git a/src/racket/src/schvers.h b/src/racket/src/schvers.h index eec864f698..b3c0fa8679 100644 --- a/src/racket/src/schvers.h +++ b/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "5.3.1.2" +#define MZSCHEME_VERSION "5.3.1.3" #define MZSCHEME_VERSION_X 5 #define MZSCHEME_VERSION_Y 3 #define MZSCHEME_VERSION_Z 1 -#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) diff --git a/src/racket/src/struct.c b/src/racket/src/struct.c index 02c7e349a2..501a8481c1 100644 --- a/src/racket/src/struct.c +++ b/src/racket/src/struct.c @@ -36,6 +36,8 @@ READ_ONLY Scheme_Object *scheme_equal_property; READ_ONLY Scheme_Object *scheme_no_arity_property; READ_ONLY Scheme_Object *scheme_impersonator_of_property; READ_ONLY Scheme_Object *scheme_make_struct_type_proc; +READ_ONLY Scheme_Object *scheme_make_struct_field_accessor_proc; +READ_ONLY Scheme_Object *scheme_make_struct_field_mutator_proc; READ_ONLY Scheme_Object *scheme_current_inspector_proc; READ_ONLY Scheme_Object *scheme_recur_symbol; READ_ONLY Scheme_Object *scheme_display_symbol; @@ -553,15 +555,20 @@ scheme_init_struct (Scheme_Env *env) 3, 3), env); + REGISTER_SO(scheme_make_struct_field_accessor_proc); + scheme_make_struct_field_accessor_proc = scheme_make_prim_w_arity(make_struct_field_accessor, + "make-struct-field-accessor", + 2, 3); scheme_add_global_constant("make-struct-field-accessor", - scheme_make_prim_w_arity(make_struct_field_accessor, - "make-struct-field-accessor", - 2, 3), + scheme_make_struct_field_accessor_proc, env); + + REGISTER_SO(scheme_make_struct_field_mutator_proc); + scheme_make_struct_field_mutator_proc = scheme_make_prim_w_arity(make_struct_field_mutator, + "make-struct-field-mutator", + 2, 3); scheme_add_global_constant("make-struct-field-mutator", - scheme_make_prim_w_arity(make_struct_field_mutator, - "make-struct-field-mutator", - 2, 3), + scheme_make_struct_field_mutator_proc, env); scheme_add_global_constant("wrap-evt", diff --git a/src/racket/src/validate.c b/src/racket/src/validate.c index a17a87389c..820ab6da3c 100644 --- a/src/racket/src/validate.c +++ b/src/racket/src/validate.c @@ -363,6 +363,8 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port, tl_state, tl_timestamp, NULL, !!only_var, 0, vc, 0, 0, NULL, size-1); + if (scheme_is_simple_make_struct_type(val, size-1, 1, 1)) + result = 2; flags = SCHEME_TOPLEVEL_READY; if (result == 2) { @@ -1412,7 +1414,10 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, check_self_call_valid(app->args[0], port, vc, delta, stack); if (result) { - r = scheme_is_functional_primitive(app->args[0], app->num_args, expected_results); + if (scheme_is_simple_make_struct_type((Scheme_Object *)app, expected_results, 1, 1)) + r = 2; + else + r = scheme_is_functional_primitive(app->args[0], app->num_args, expected_results); result = validate_join(result, r); } } From e698be778b892674e26c01c0dc054ad83f6ada79 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 26 Oct 2012 12:49:42 -0600 Subject: [PATCH 041/221] remove a level of indirection in struct selectors/mutators --- src/racket/src/jitcommon.c | 10 +- src/racket/src/jitinline.c | 8 +- src/racket/src/mzmark_struct.inc | 29 ------ src/racket/src/mzmarksrc.c | 11 --- src/racket/src/schpriv.h | 7 -- src/racket/src/struct.c | 163 ++++++++++++++++--------------- src/racket/src/stypes.h | 75 +++++++------- 7 files changed, 124 insertions(+), 179 deletions(-) diff --git a/src/racket/src/jitcommon.c b/src/racket/src/jitcommon.c index e9e99a72c7..fd504853b1 100644 --- a/src/racket/src/jitcommon.c +++ b/src/racket/src/jitcommon.c @@ -1494,9 +1494,6 @@ int scheme_generate_struct_op(mz_jit_state *jitter, int kind, int for_branch, jit_ldxi_p(JIT_R2, JIT_R1, &((Scheme_Structure *)0x0)->stype); if (type_pos < 0) { jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val); - if (kind >= 2) { - jit_ldxi_p(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->struct_type); - } } CHECK_LIMIT(); @@ -1547,9 +1544,6 @@ int scheme_generate_struct_op(mz_jit_state *jitter, int kind, int for_branch, /* (Re-)load target type into V1: */ jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val); - if (kind >= 2) { - jit_ldxi_p(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->struct_type); - } if (kind == 1) { bref4 = jit_bner_p(jit_forward(), JIT_R2, JIT_V1); @@ -1616,8 +1610,8 @@ int scheme_generate_struct_op(mz_jit_state *jitter, int kind, int for_branch, } /* Extract field */ if (field_pos < 0) { - jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val); - jit_ldxi_i(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->field); + jit_ldxi_p(JIT_V1, JIT_R0, &(((Scheme_Primitive_Closure *)0x0)->val[1])); + jit_rshi_ul(JIT_V1, JIT_V1, 1); jit_lshi_ul(JIT_V1, JIT_V1, JIT_LOG_WORD_SIZE); jit_addi_p(JIT_V1, JIT_V1, &((Scheme_Structure *)0x0)->slots); } else { diff --git a/src/racket/src/jitinline.c b/src/racket/src/jitinline.c index 5dde16f57c..7caeac63ff 100644 --- a/src/racket/src/jitinline.c +++ b/src/racket/src/jitinline.c @@ -396,7 +396,7 @@ static int generate_inlined_struct_op(int kind, mz_jit_state *jitter, /* R0 is [potential] predicate/getter/setting, R1 is struct. V1 is value for setting. */ - if ((kind == INLINE_STRUCT_PROC_PRED) /* REMOVEME */ + if ((kind == INLINE_STRUCT_PROC_PRED) || (kind == INLINE_STRUCT_PROC_GET) || (kind == INLINE_STRUCT_PROC_SET)) { inline_rator = extract_struct_constant(jitter, rator); @@ -489,13 +489,11 @@ static int generate_inlined_struct_op(int kind, mz_jit_state *jitter, if (inline_rator) { int pos, tpos, jkind; - inline_rator = ((Scheme_Primitive_Closure *)inline_rator)->val[0]; + tpos = ((Scheme_Struct_Type *)((Scheme_Primitive_Closure *)inline_rator)->val[0])->name_pos; if (kind == INLINE_STRUCT_PROC_PRED) { pos = 0; - tpos = ((Scheme_Struct_Type *)inline_rator)->name_pos; } else { - pos = ((Struct_Proc_Info *)inline_rator)->field; - tpos = ((Struct_Proc_Info *)inline_rator)->struct_type->name_pos; + pos = SCHEME_INT_VAL(((Scheme_Primitive_Closure *)inline_rator)->val[1]); } if (ref) { diff --git a/src/racket/src/mzmark_struct.inc b/src/racket/src/mzmark_struct.inc index 77bc9c6c0b..81e3842154 100644 --- a/src/racket/src/mzmark_struct.inc +++ b/src/racket/src/mzmark_struct.inc @@ -153,35 +153,6 @@ static int mark_struct_type_val_FIXUP(void *p, struct NewGC *gc) { #define mark_struct_type_val_IS_CONST_SIZE 0 -static int mark_struct_proc_info_SIZE(void *p, struct NewGC *gc) { - return - gcBYTES_TO_WORDS(sizeof(Struct_Proc_Info)); -} - -static int mark_struct_proc_info_MARK(void *p, struct NewGC *gc) { - Struct_Proc_Info *i = (Struct_Proc_Info *)p; - - gcMARK2(i->struct_type, gc); - gcMARK2(i->func_name, gc); - - return - gcBYTES_TO_WORDS(sizeof(Struct_Proc_Info)); -} - -static int mark_struct_proc_info_FIXUP(void *p, struct NewGC *gc) { - Struct_Proc_Info *i = (Struct_Proc_Info *)p; - - gcFIXUP2(i->struct_type, gc); - gcFIXUP2(i->func_name, gc); - - return - gcBYTES_TO_WORDS(sizeof(Struct_Proc_Info)); -} - -#define mark_struct_proc_info_IS_ATOMIC 0 -#define mark_struct_proc_info_IS_CONST_SIZE 1 - - static int mark_struct_property_SIZE(void *p, struct NewGC *gc) { return gcBYTES_TO_WORDS(sizeof(Scheme_Struct_Property)); diff --git a/src/racket/src/mzmarksrc.c b/src/racket/src/mzmarksrc.c index 761a382195..265e289d94 100644 --- a/src/racket/src/mzmarksrc.c +++ b/src/racket/src/mzmarksrc.c @@ -2102,17 +2102,6 @@ mark_struct_type_val { * sizeof(Scheme_Struct_Type *)))); } -mark_struct_proc_info { - mark: - Struct_Proc_Info *i = (Struct_Proc_Info *)p; - - gcMARK2(i->struct_type, gc); - gcMARK2(i->func_name, gc); - - size: - gcBYTES_TO_WORDS(sizeof(Struct_Proc_Info)); -} - mark_struct_property { mark: Scheme_Struct_Property *i = (Scheme_Struct_Property *)p; diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index 0311f11072..a14d86d6bb 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -791,13 +791,6 @@ typedef struct Scheme_Serialized_Structure } Scheme_Serialized_Structure; #endif -typedef struct Struct_Proc_Info { - MZTAG_IF_REQUIRED - Scheme_Struct_Type *struct_type; - char *func_name; - mzshort field; -} Struct_Proc_Info; - #define SCHEME_STRUCT_TYPE(o) (((Scheme_Structure *)o)->stype) #define SCHEME_STRUCT_NUM_SLOTS(o) (SCHEME_STRUCT_TYPE(o)->num_slots) diff --git a/src/racket/src/struct.c b/src/racket/src/struct.c index 501a8481c1..74d4c50956 100644 --- a/src/racket/src/struct.c +++ b/src/racket/src/struct.c @@ -1370,14 +1370,19 @@ static Scheme_Object *guard_property(Scheme_Object *prop, Scheme_Object *v, Sche static int extract_accessor_offset(Scheme_Object *acc) { - Struct_Proc_Info *i = (Struct_Proc_Info *)SCHEME_PRIM_CLOSURE_ELS(acc)[0]; + Scheme_Struct_Type *st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(acc)[0]; - if (i->struct_type->name_pos) - return i->struct_type->parent_types[i->struct_type->name_pos - 1]->num_slots; + if (st->name_pos) + return st->parent_types[st->name_pos - 1]->num_slots; else return 0; } +static char *extract_field_proc_name(Scheme_Object *prim) +{ + return (char *)SCHEME_PRIM_CLOSURE_ELS(prim)[2]; +} + typedef int (*Check_Val_Proc)(Scheme_Object *); static void wrong_property_contract(const char *name, const char *contract, Scheme_Object *v) @@ -2304,16 +2309,17 @@ static Scheme_Object *struct_pred(int argc, Scheme_Object **args, Scheme_Object return scheme_false; } -static int parse_pos(const char *who, Struct_Proc_Info *i, Scheme_Object **args, int argc) +static int parse_pos(const char *who, Scheme_Object *prim, Scheme_Object **args, int argc) { int pos; + Scheme_Struct_Type *st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(prim)[0]; if (!SCHEME_INTP(args[1]) || (SCHEME_INT_VAL(args[1]) < 0)) { if (SCHEME_BIGNUMP(args[1]) && SCHEME_BIGPOS(args[1])) { pos = 32769; /* greater than max field count */ } else { if (!who) - who = i->func_name; + who = extract_field_proc_name(prim); scheme_wrong_contract(who, "exact-nonnegative-integer?", 1, argc, args); @@ -2322,20 +2328,20 @@ static int parse_pos(const char *who, Struct_Proc_Info *i, Scheme_Object **args, } else pos = SCHEME_INT_VAL(args[1]); - if ((pos < i->struct_type->num_slots) - && i->struct_type->name_pos) - pos += i->struct_type->parent_types[i->struct_type->name_pos - 1]->num_slots; + if ((pos < st->num_slots) + && st->name_pos) + pos += st->parent_types[st->name_pos - 1]->num_slots; - if (pos >= i->struct_type->num_slots) { + if (pos >= st->num_slots) { int sc; if (!who) - who = i->func_name; + who = extract_field_proc_name(prim); - sc = (i->struct_type->name_pos - ? (i->struct_type->num_slots - - i->struct_type->parent_types[i->struct_type->name_pos - 1]->num_slots) - : i->struct_type->num_slots); + sc = (st->name_pos + ? (st->num_slots + - st->parent_types[st->name_pos - 1]->num_slots) + : st->num_slots); scheme_contract_error(who, "index too large", @@ -2354,29 +2360,29 @@ Scheme_Object *scheme_struct_getter(int argc, Scheme_Object **args, Scheme_Objec { Scheme_Structure *inst; int pos; - Struct_Proc_Info *i = (Struct_Proc_Info *)SCHEME_PRIM_CLOSURE_ELS(prim)[0]; + Scheme_Struct_Type *st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(prim)[0]; inst = (Scheme_Structure *)args[0]; if (SCHEME_CHAPERONEP(((Scheme_Object *)inst))) inst = (Scheme_Structure *)SCHEME_CHAPERONE_VAL((Scheme_Object *)inst); if (!SCHEME_STRUCTP(((Scheme_Object *)inst))) { - scheme_wrong_contract(i->func_name, - pred_name_string(i->struct_type->name), + scheme_wrong_contract(extract_field_proc_name(prim), + pred_name_string(st->name), 0, argc, args); return NULL; - } else if (!STRUCT_TYPEP(i->struct_type, inst)) { - wrong_struct_type(i->func_name, - i->struct_type->name, + } else if (!STRUCT_TYPEP(st, inst)) { + wrong_struct_type(extract_field_proc_name(prim), + st->name, SCHEME_STRUCT_NAME_SYM(inst), 0, argc, args); return NULL; } if (argc == 2) - pos = parse_pos(NULL, i, args, argc); + pos = parse_pos(NULL, prim, args, argc); else - pos = i->field; + pos = SCHEME_INT_VAL(SCHEME_PRIM_CLOSURE_ELS(prim)[1]); if (SAME_OBJ((Scheme_Object *)inst, args[0])) return inst->slots[pos]; @@ -2389,44 +2395,43 @@ Scheme_Object *scheme_struct_setter(int argc, Scheme_Object **args, Scheme_Objec Scheme_Structure *inst; int pos; Scheme_Object *v; - Struct_Proc_Info *i = (Struct_Proc_Info *)SCHEME_PRIM_CLOSURE_ELS(prim)[0]; + Scheme_Struct_Type *st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(prim)[0]; inst = (Scheme_Structure *)args[0]; if (SCHEME_CHAPERONEP(((Scheme_Object *)inst))) inst = (Scheme_Structure *)SCHEME_CHAPERONE_VAL((Scheme_Object *)inst); if (!SCHEME_STRUCTP(((Scheme_Object *)inst))) { - scheme_wrong_contract(i->func_name, - pred_name_string(i->struct_type->name), + scheme_wrong_contract(extract_field_proc_name(prim), + pred_name_string(st->name), 0, argc, args); return NULL; } - if (!STRUCT_TYPEP(i->struct_type, inst)) { - wrong_struct_type(i->func_name, - i->struct_type->name, + if (!STRUCT_TYPEP(st, inst)) { + wrong_struct_type(extract_field_proc_name(prim), + st->name, SCHEME_STRUCT_NAME_SYM(inst), 0, argc, args); return NULL; } if (argc == 3) { - pos = parse_pos(NULL, i, args, argc); + pos = parse_pos(NULL, prim, args, argc); v = args[2]; } else { - pos = i->field; + pos = SCHEME_INT_VAL(SCHEME_PRIM_CLOSURE_ELS(prim)[1]); v = args[1]; } - if (i->struct_type->immutables) { - Scheme_Struct_Type *t = i->struct_type; + if (st->immutables) { int p = pos; - if (t->name_pos) - p -= t->parent_types[t->name_pos - 1]->num_slots; + if (st->name_pos) + p -= st->parent_types[st->name_pos - 1]->num_slots; - if (t->immutables[p]) { - scheme_contract_error(i->func_name, + if (st->immutables[p]) { + scheme_contract_error(extract_field_proc_name(prim), "cannot modify value of immutable field in structure", "structure", 1, args[0], "field index", 1, scheme_make_integer(pos), @@ -3104,12 +3109,12 @@ chaperone_prop_getter_p(int argc, Scheme_Object *argv[]) static Scheme_Object *make_struct_field_xxor(const char *who, int getter, int argc, Scheme_Object *argv[]) { - Struct_Proc_Info *i; int pos; char *name; const char *fieldstr; char digitbuf[20]; int fieldstrlen; + Scheme_Struct_Type *st; /* We don't allow chaperones on the getter or setter procedure, because we can't preserve them in the generated procedure. */ @@ -3124,9 +3129,7 @@ static Scheme_Object *make_struct_field_xxor(const char *who, int getter, return NULL; } - i = (Struct_Proc_Info *)SCHEME_PRIM_CLOSURE_ELS(argv[0])[0]; - - pos = parse_pos(who, i, argv, argc); + pos = parse_pos(who, argv[0], argv, argc); if (argc > 2) { if (SCHEME_FALSEP(argv[2])) { @@ -3146,20 +3149,22 @@ static Scheme_Object *make_struct_field_xxor(const char *who, int getter, fieldstrlen = strlen(fieldstr); } + st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(argv[0])[0]; + if (!fieldstr) { if (getter) name = "accessor"; else name = "mutator"; } else if (getter) { - name = (char *)GET_NAME((char *)i->struct_type->name, -1, + name = (char *)GET_NAME((char *)st->name, -1, fieldstr, fieldstrlen, 0); } else { - name = (char *)SET_NAME((char *)i->struct_type->name, -1, + name = (char *)SET_NAME((char *)st->name, -1, fieldstr, fieldstrlen, 0); } - return make_struct_proc(i->struct_type, + return make_struct_proc(st, name, (getter ? SCHEME_GETTER : SCHEME_SETTER), pos); } @@ -3774,7 +3779,7 @@ make_struct_proc(Scheme_Struct_Type *struct_type, char *func_name, Scheme_ProcT proc_type, int field_num) { - Scheme_Object *p, *a[1]; + Scheme_Object *p, *a[3]; short flags = 0; if (proc_type == SCHEME_CONSTR) { @@ -3800,28 +3805,21 @@ make_struct_proc(Scheme_Struct_Type *struct_type, 1, 1, 1); flags |= SCHEME_PRIM_STRUCT_TYPE_PRED; } else { - Struct_Proc_Info *i; int need_pos; - i = MALLOC_ONE_RT(Struct_Proc_Info); -#ifdef MZTAG_REQUIRED - i->type = scheme_rt_struct_proc_info; -#endif - i->struct_type = struct_type; - i->func_name = func_name; - i->field = field_num; - if ((proc_type == SCHEME_GEN_GETTER) || (proc_type == SCHEME_GEN_SETTER)) need_pos = 1; else need_pos = 0; - a[0] = (Scheme_Object *)i; + a[0] = (Scheme_Object *)struct_type; + a[1] = scheme_make_integer(field_num); + a[2] = (Scheme_Object *)func_name; if ((proc_type == SCHEME_GETTER) || (proc_type == SCHEME_GEN_GETTER)) { p = scheme_make_folding_prim_closure(scheme_struct_getter, - 1, a, + 3, a, func_name, 1 + need_pos, 1 + need_pos, 0); if (need_pos) @@ -3833,7 +3831,7 @@ make_struct_proc(Scheme_Struct_Type *struct_type, if (need_pos) struct_type->accessor = p; */ } else { p = scheme_make_folding_prim_closure(scheme_struct_setter, - 1, a, + 3, a, func_name, 2 + need_pos, 2 + need_pos, 0); if (need_pos) @@ -3870,15 +3868,17 @@ Scheme_Object *scheme_rename_struct_proc(Scheme_Object *p, Scheme_Object *sym) if (is_getter || is_setter) { const char *func_name; - Struct_Proc_Info *i; + Scheme_Struct_Type *st; + int field_pos; func_name = scheme_symbol_name(sym); + + st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(p)[0]; + field_pos = SCHEME_INT_VAL(SCHEME_PRIM_CLOSURE_ELS(p)[1]); - i = (Struct_Proc_Info *)SCHEME_PRIM_CLOSURE_ELS(p)[0]; - - return make_struct_proc(i->struct_type, (char *)func_name, + return make_struct_proc(st, (char *)func_name, is_getter ? SCHEME_GETTER : SCHEME_SETTER, - i->field); + field_pos); } } @@ -5205,14 +5205,14 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator, /* (chaperone-struct v mutator/selector redirect-proc ...) */ { Scheme_Chaperone *px; - Scheme_Struct_Type *stype; + Scheme_Struct_Type *stype, *st; Scheme_Object *val = argv[0], *proc; Scheme_Object *redirects, *prop, *si_chaperone = scheme_false; - Struct_Proc_Info *pi; Scheme_Object *a[1], *inspector, *getter_positions = scheme_null; int i, offset, arity, non_applicable_op, repeat_op; const char *kind; Scheme_Hash_Tree *props = NULL, *red_props = NULL, *setter_positions = NULL; + intptr_t field_pos; if (argc == 1) return argv[0]; @@ -5276,12 +5276,14 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator, "struct-info procedure supplied a second time", "procedure", 1, a[0], NULL); - pi = NULL; + st = NULL; + field_pos = 0; prop = NULL; arity = 2; } else if (offset == -1) { prop = SCHEME_PRIM_CLOSURE_ELS(proc)[0]; - pi = NULL; + st = NULL; + field_pos = 0; if (is_impersonator && !((Scheme_Struct_Property *)prop)->can_impersonate) @@ -5303,22 +5305,23 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator, arity = 2; } } else { - pi = (Struct_Proc_Info *)((Scheme_Primitive_Closure *)proc)->val[0]; + st = (Scheme_Struct_Type *)((Scheme_Primitive_Closure *)proc)->val[0]; + field_pos = SCHEME_INT_VAL(((Scheme_Primitive_Closure *)proc)->val[1]); prop = NULL; - if (!SCHEME_STRUCTP(val) || !scheme_is_struct_instance((Scheme_Object *)pi->struct_type, val)) + if (!SCHEME_STRUCTP(val) || !scheme_is_struct_instance((Scheme_Object *)st, val)) non_applicable_op = 1; - else if (SCHEME_TRUEP(SCHEME_VEC_ELS(redirects)[PRE_REDIRECTS + offset + pi->field])) + else if (SCHEME_TRUEP(SCHEME_VEC_ELS(redirects)[PRE_REDIRECTS + offset + field_pos])) repeat_op = 1; else { if (is_impersonator) { - intptr_t field_pos; - field_pos = pi->field - (pi->struct_type->name_pos - ? pi->struct_type->parent_types[pi->struct_type->name_pos - 1]->num_slots - : 0); + intptr_t loc_field_pos; + loc_field_pos = field_pos - (st->name_pos + ? st->parent_types[st->name_pos - 1]->num_slots + : 0); /* Must not be an immutable field. */ if (stype->immutables) { - if (stype->immutables[field_pos]) + if (stype->immutables[loc_field_pos]) scheme_contract_error(name, "cannot replace operation for an immutable field", "operation kind", 0, kind, @@ -5329,15 +5332,15 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator, /* impersonating a getter is allowed only if the structure type is transparent or if the setter is also impersonated (which would prove that the code creating the impersonator has suitable access). */ - if (!scheme_inspector_sees_part(argv[0], inspector, pi->field)) { - getter_positions = scheme_make_pair(scheme_make_pair(scheme_make_integer(pi->field), a[0]), + if (!scheme_inspector_sees_part(argv[0], inspector, field_pos)) { + getter_positions = scheme_make_pair(scheme_make_pair(scheme_make_integer(field_pos), a[0]), getter_positions); } } else { - if (!scheme_inspector_sees_part(argv[0], inspector, pi->field)) { + if (!scheme_inspector_sees_part(argv[0], inspector, field_pos)) { if (!setter_positions) setter_positions = scheme_make_hash_tree(0); - setter_positions = scheme_hash_tree_set(setter_positions, scheme_make_integer(pi->field), scheme_true); + setter_positions = scheme_hash_tree_set(setter_positions, scheme_make_integer(field_pos), scheme_true); } } } @@ -5384,8 +5387,8 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator, if (prop) red_props = scheme_hash_tree_set(red_props, prop, proc); - else if (pi) - SCHEME_VEC_ELS(redirects)[PRE_REDIRECTS + offset + pi->field] = proc; + else if (st) + SCHEME_VEC_ELS(redirects)[PRE_REDIRECTS + offset + field_pos] = proc; else si_chaperone = proc; } @@ -5550,8 +5553,6 @@ static void register_traversers(void) GC_REG_TRAV(scheme_nack_guard_evt_type, mark_nack_guard_evt); GC_REG_TRAV(scheme_poll_evt_type, mark_nack_guard_evt); - GC_REG_TRAV(scheme_rt_struct_proc_info, mark_struct_proc_info); - GC_REG_TRAV(scheme_chaperone_type, mark_chaperone); GC_REG_TRAV(scheme_proc_chaperone_type, mark_chaperone); } diff --git a/src/racket/src/stypes.h b/src/racket/src/stypes.h index ceb4e5bb76..62d0ed51ab 100644 --- a/src/racket/src/stypes.h +++ b/src/racket/src/stypes.h @@ -238,44 +238,43 @@ enum { scheme_rt_tcp_select_info, /* 214 */ scheme_rt_param_data, /* 215 */ scheme_rt_will, /* 216 */ - scheme_rt_struct_proc_info, /* 217 */ - scheme_rt_linker_name, /* 218 */ - scheme_rt_param_map, /* 219 */ - scheme_rt_finalization, /* 220 */ - scheme_rt_finalizations, /* 221 */ - scheme_rt_cpp_object, /* 222 */ - scheme_rt_cpp_array_object, /* 223 */ - scheme_rt_stack_object, /* 224 */ - scheme_rt_preallocated_object, /* 225 */ - scheme_thread_hop_type, /* 226 */ - scheme_rt_srcloc, /* 227 */ - scheme_rt_evt, /* 228 */ - scheme_rt_syncing, /* 229 */ - scheme_rt_comp_prefix, /* 230 */ - scheme_rt_user_input, /* 231 */ - scheme_rt_user_output, /* 232 */ - scheme_rt_compact_port, /* 233 */ - scheme_rt_read_special_dw, /* 234 */ - scheme_rt_regwork, /* 235 */ - scheme_rt_rx_lazy_string, /* 236 */ - scheme_rt_buf_holder, /* 237 */ - scheme_rt_parameterization, /* 238 */ - scheme_rt_print_params, /* 239 */ - scheme_rt_read_params, /* 240 */ - scheme_rt_native_code, /* 241 */ - scheme_rt_native_code_plus_case, /* 242 */ - scheme_rt_jitter_data, /* 243 */ - scheme_rt_module_exports, /* 244 */ - scheme_rt_delay_load_info, /* 245 */ - scheme_rt_marshal_info, /* 246 */ - scheme_rt_unmarshal_info, /* 247 */ - scheme_rt_runstack, /* 248 */ - scheme_rt_sfs_info, /* 249 */ - scheme_rt_validate_clearing, /* 250 */ - scheme_rt_avl_node, /* 251 */ - scheme_rt_lightweight_cont, /* 252 */ - scheme_rt_export_info, /* 253 */ - scheme_rt_cont_jmp, /* 254 */ + scheme_rt_linker_name, /* 217 */ + scheme_rt_param_map, /* 218 */ + scheme_rt_finalization, /* 219 */ + scheme_rt_finalizations, /* 220 */ + scheme_rt_cpp_object, /* 221 */ + scheme_rt_cpp_array_object, /* 222 */ + scheme_rt_stack_object, /* 223 */ + scheme_rt_preallocated_object, /* 224 */ + scheme_thread_hop_type, /* 225 */ + scheme_rt_srcloc, /* 226 */ + scheme_rt_evt, /* 227 */ + scheme_rt_syncing, /* 228 */ + scheme_rt_comp_prefix, /* 229 */ + scheme_rt_user_input, /* 230 */ + scheme_rt_user_output, /* 231 */ + scheme_rt_compact_port, /* 232 */ + scheme_rt_read_special_dw, /* 233 */ + scheme_rt_regwork, /* 234 */ + scheme_rt_rx_lazy_string, /* 235 */ + scheme_rt_buf_holder, /* 236 */ + scheme_rt_parameterization, /* 237 */ + scheme_rt_print_params, /* 238 */ + scheme_rt_read_params, /* 239 */ + scheme_rt_native_code, /* 240 */ + scheme_rt_native_code_plus_case, /* 241 */ + scheme_rt_jitter_data, /* 242 */ + scheme_rt_module_exports, /* 243 */ + scheme_rt_delay_load_info, /* 244 */ + scheme_rt_marshal_info, /* 245 */ + scheme_rt_unmarshal_info, /* 246 */ + scheme_rt_runstack, /* 247 */ + scheme_rt_sfs_info, /* 248 */ + scheme_rt_validate_clearing, /* 249 */ + scheme_rt_avl_node, /* 250 */ + scheme_rt_lightweight_cont, /* 251 */ + scheme_rt_export_info, /* 252 */ + scheme_rt_cont_jmp, /* 253 */ #endif _scheme_last_type_ From 5f30cc87eaf97bd4569c5637a1870ba79b48f88e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 26 Oct 2012 19:41:34 -0600 Subject: [PATCH 042/221] track information about `struct' bindings during compilation This tracking allows the compiler to treat structure sub-type declarations as generating constant results, and it also allows the compiler to recognize an applications of a constructor or predicate as functional. --- collects/racket/private/define-struct.rkt | 5 +- collects/tests/racket/optimize.rktl | 148 ++++++ src/racket/src/compenv.c | 6 +- src/racket/src/compile.c | 8 +- src/racket/src/eval.c | 8 +- src/racket/src/jitcommon.c | 11 +- src/racket/src/module.c | 16 +- src/racket/src/mzmark_type.inc | 38 +- src/racket/src/mzmarksrc.c | 12 +- src/racket/src/optimize.c | 565 +++++++++++++++++----- src/racket/src/resolve.c | 4 +- src/racket/src/schpriv.h | 22 +- src/racket/src/sfs.c | 2 +- src/racket/src/struct.c | 13 +- src/racket/src/stypes.h | 147 +++--- src/racket/src/type.c | 22 +- src/racket/src/validate.c | 128 +++-- 17 files changed, 859 insertions(+), 296 deletions(-) diff --git a/collects/racket/private/define-struct.rkt b/collects/racket/private/define-struct.rkt index f91f1c2f2b..5c93db6d71 100644 --- a/collects/racket/private/define-struct.rkt +++ b/collects/racket/private/define-struct.rkt @@ -516,7 +516,10 @@ stx super-id)) (and super-expr - #`(check-struct-type 'fm #,super-expr)))] + #`(let ([the-super #,super-expr]) + (if (struct-type? the-super) + the-super + (check-struct-type 'fm the-super)))))] [prune (lambda (stx) (identifier-prune-lexical-context stx (list (syntax-e stx) '#%top)))] [reflect-name-expr (if reflect-name-expr diff --git a/collects/tests/racket/optimize.rktl b/collects/tests/racket/optimize.rktl index 0c8168bdc4..494a505208 100644 --- a/collects/tests/racket/optimize.rktl +++ b/collects/tests/racket/optimize.rktl @@ -1682,6 +1682,154 @@ (hash-ref '#hash((x . y)) x add1)) #f) +;; Check elimination of ignored structure predicate +;; and constructor applications: + +(test-comp '(module m racket/base + (define-values (struct:a a a? a-ref a-set!) + (make-struct-type 'a #f 2 0)) + (begin0 + (a? (a-ref (a 1 2) 1)) + a? + a + a-ref + (a? 7) + (a 1 2) + 5)) + '(module m racket/base + (define-values (struct:a a a? a-ref a-set!) + (make-struct-type 'a #f 2 0)) + (begin0 + (a? (a-ref (a 1 2) 1)) + 5))) + +(test-comp '(module m racket/base + (define-values (struct:a a a? a-x a-y) + (let-values ([(struct:a a a? a-ref a-set!) + (make-struct-type 'a #f 2 0)]) + (values struct:a a a? + (make-struct-field-accessor a-ref 0) + (make-struct-field-accessor a-ref 1)))) + (begin0 + (a? (a-x (a 1 2))) + a? + a + a-x + (a? 7) + (a 1 2) + 5)) + '(module m racket/base + (define-values (struct:a a a? a-x a-y) + (let-values ([(struct:a a a? a-ref a-set!) + (make-struct-type 'a #f 2 0)]) + (values struct:a a a? + (make-struct-field-accessor a-ref 0) + (make-struct-field-accessor a-ref 1)))) + (begin0 + (a? (a-x (a 1 2))) + 5))) + +(test-comp '(module m racket/base + (struct a (x y) #:omit-define-syntaxes) + (begin0 + (a? (a-x (a 1 2))) + a? + a + a-x + (a? 7) + (a 1 2) + 5)) + '(module m racket/base + (struct a (x y) #:omit-define-syntaxes) + (begin0 + (a? (a-x (a 1 2))) + 5))) + +(test-comp '(module m racket/base + (struct a (x y) #:omit-define-syntaxes #:prefab) + (begin0 + (a? (a-x (a 1 2))) + a? + a + a-x + (a? 7) + (a 1 2) + 5)) + '(module m racket/base + (struct a (x y) #:omit-define-syntaxes #:prefab) + (begin0 + (a? (a-x (a 1 2))) + 5))) + +(test-comp '(module m racket/base + (struct a (x y) #:omit-define-syntaxes #:mutable) + (begin0 + (a? (set-a-x! (a 1 2) 5)) + a? + a + a-x + set-a-x! + (a? 7) + (a 1 2) + 5)) + '(module m racket/base + (struct a (x y) #:omit-define-syntaxes #:mutable) + (begin0 + (a? (set-a-x! (a 1 2) 5)) + 5))) + +(test-comp '(module m racket/base + (struct a (x y) #:omit-define-syntaxes) + (struct b (z) #:super struct:a #:omit-define-syntaxes) + (begin0 + (list (a? (a-x (a 1 2))) + (b? (b-z (b 1 2 3)))) + a? + a + a-x + (a? 7) + (a 1 2) + b? + b + b-z + (b 1 2 3) + 5)) + '(module m racket/base + (struct a (x y) #:omit-define-syntaxes) + (struct b (z) #:super struct:a #:omit-define-syntaxes) + (begin0 + (list (a? (a-x (a 1 2))) + (b? (b-z (b 1 2 3)))) + 5))) + +(module struct-a-for-optimize racket/base + (provide (struct-out a) + (struct-out b)) + (struct a (x y)) + (struct b a (z))) + +(test-comp '(module m racket/base + (require 'struct-a-for-optimize) + (begin0 + (list (a? (a-x (a 1 2))) + (b? (b-z (b 1 2 3)))) + a? + a + a-x + (a? 7) + (a 1 2) + b? + b + b-z + (b 1 2 3) + 5)) + '(module m racket/base + (require 'struct-a-for-optimize) + (begin0 + (list (a? (a-x (a 1 2))) + (b? (b-z (b 1 2 3)))) + 5))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Check bytecode verification of lifted functions diff --git a/src/racket/src/compenv.c b/src/racket/src/compenv.c index 1fc21e42bb..fa036b7690 100644 --- a/src/racket/src/compenv.c +++ b/src/racket/src/compenv.c @@ -2000,7 +2000,11 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, is_constant = 2; else if (SAME_OBJ(mod_constant, scheme_fixed_key)) is_constant = 1; - else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_inline_variant_type)) { + else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_struct_proc_shape_type)) { + if (_inline_variant) + *_inline_variant = mod_constant; + is_constant = 2; + } else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_inline_variant_type)) { if (_inline_variant) *_inline_variant = mod_constant; is_constant = 2; diff --git a/src/racket/src/compile.c b/src/racket/src/compile.c index 3f0d6321b4..21aa3e330d 100644 --- a/src/racket/src/compile.c +++ b/src/racket/src/compile.c @@ -2923,7 +2923,7 @@ Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt) total++; } else if (opt && (((opt > 0) && !last) || ((opt < 0) && !first)) - && scheme_omittable_expr(v, -1, -1, 0, NULL, -1, 0)) { + && scheme_omittable_expr(v, -1, -1, 0, NULL, NULL, -1, 0)) { /* A value that is not the result. We'll drop it. */ total++; } else { @@ -2951,7 +2951,7 @@ Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt) /* can't optimize away a begin0 at read time; it's too late, since the return is combined with EXPD_BEGIN0 */ addconst = 1; - } else if ((opt < 0) && !scheme_omittable_expr(SCHEME_CAR(seq), 1, -1, 0, NULL, -1, 0)) { + } else if ((opt < 0) && !scheme_omittable_expr(SCHEME_CAR(seq), 1, -1, 0, NULL, NULL, -1, 0)) { /* We can't optimize (begin0 expr cont) to expr because exp is not in tail position in the original (so we'd mess up continuation marks). */ @@ -2983,7 +2983,7 @@ Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt) } else if (opt && (((opt > 0) && (k < total)) || ((opt < 0) && k)) - && scheme_omittable_expr(v, -1, -1, 0, NULL, -1, 0)) { + && scheme_omittable_expr(v, -1, -1, 0, NULL, NULL, -1, 0)) { /* Value not the result. Do nothing. */ } else o->array[i++] = v; @@ -3483,7 +3483,7 @@ static Scheme_Object *eval_letmacro_rhs(Scheme_Object *a, Scheme_Comp_Env *rhs_e save_runstack = scheme_push_prefix(NULL, rp, NULL, NULL, phase, phase, rhs_env->genv, NULL); - if (scheme_omittable_expr(a, 1, -1, 0, NULL, -1, 0)) { + if (scheme_omittable_expr(a, 1, -1, 0, NULL, NULL, -1, 0)) { /* short cut */ a = _scheme_eval_linked_expr_multi(a); } else { diff --git a/src/racket/src/eval.c b/src/racket/src/eval.c index 0f54e2ca8b..ac047cfc4b 100644 --- a/src/racket/src/eval.c +++ b/src/racket/src/eval.c @@ -1896,7 +1896,13 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro, if (SAME_OBJ(values, scheme_current_thread->values_buffer)) scheme_current_thread->values_buffer = NULL; - is_st = scheme_is_simple_make_struct_type(vals_expr, g, 1, 1); + if (dm_env) + is_st = 0; + else + is_st = !!scheme_is_simple_make_struct_type(vals_expr, g, 1, 1, + NULL, NULL, NULL, NULL, + NULL, NULL, MZ_RUNSTACK, 0, + NULL, NULL, 5); for (i = 0; i < g; i++) { var = SCHEME_VEC_ELS(vec)[i+delta]; diff --git a/src/racket/src/jitcommon.c b/src/racket/src/jitcommon.c index fd504853b1..da8c7b9731 100644 --- a/src/racket/src/jitcommon.c +++ b/src/racket/src/jitcommon.c @@ -1520,9 +1520,14 @@ int scheme_generate_struct_op(mz_jit_state *jitter, int kind, int for_branch, } } else { if (type_pos != 0) { - (void)jit_blti_i(refslow2, JIT_R2, type_pos); - } - bref3 = NULL; + if (kind == 1) { + bref3 = jit_blti_i(jit_forward(), JIT_R2, type_pos); + } else { + (void)jit_blti_i(refslow2, JIT_R2, type_pos); + bref3 = NULL; + } + } else + bref3 = NULL; } CHECK_LIMIT(); /* Lookup argument type at target type depth, put it in R2: */ diff --git a/src/racket/src/module.c b/src/racket/src/module.c index 3a9e466d01..69b1a5f33f 100644 --- a/src/racket/src/module.c +++ b/src/racket/src/module.c @@ -4121,7 +4121,7 @@ static void setup_accessible_table(Scheme_Module *m) for (i = 0; i < cnt; i++) { form = SCHEME_VEC_ELS(m->bodies[0])[i]; if (SAME_TYPE(SCHEME_TYPE(form), scheme_define_values_type)) { - int checked_st = 0, is_st = 0; + int checked_st = 0, is_st = 0, st_count = 0, st_icount = 0; for (k = SCHEME_VEC_SIZE(form); k-- > 1; ) { tl = SCHEME_VEC_ELS(form)[k]; if (SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_SEAL) { @@ -4154,13 +4154,17 @@ static void setup_accessible_table(Scheme_Module *m) } } else { if (!checked_st) { - is_st = scheme_is_simple_make_struct_type(SCHEME_VEC_ELS(form)[0], - SCHEME_VEC_SIZE(form)-1, - 1, 1); + is_st = !!scheme_is_simple_make_struct_type(SCHEME_VEC_ELS(form)[0], + SCHEME_VEC_SIZE(form)-1, + 1, 1, NULL, &st_count, &st_icount, + NULL, + NULL, NULL, NULL, 0, + m->prefix->toplevels, ht, + 5); checked_st = 1; } if (is_st) - v = scheme_make_pair(v, scheme_constant_key); + v = scheme_make_pair(v, scheme_make_struct_proc_shape(k-1, st_count, st_icount)); } scheme_hash_set(ht, tl, v); } @@ -9002,7 +9006,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ Scheme_Object *prev = NULL, *next; for (p = first; !SCHEME_NULLP(p); p = next) { next = SCHEME_CDR(p); - if (scheme_omittable_expr(SCHEME_CAR(p), -1, -1, 0, NULL, -1, 0)) { + if (scheme_omittable_expr(SCHEME_CAR(p), -1, -1, 0, NULL, NULL, -1, 0)) { if (prev) SCHEME_CDR(prev) = next; else diff --git a/src/racket/src/mzmark_type.inc b/src/racket/src/mzmark_type.inc index c6eec5e5ad..e2a3f68f4e 100644 --- a/src/racket/src/mzmark_type.inc +++ b/src/racket/src/mzmark_type.inc @@ -248,6 +248,25 @@ static int small_object_FIXUP(void *p, struct NewGC *gc) { #define small_object_IS_CONST_SIZE 1 +static int small_atomic_obj_SIZE(void *p, struct NewGC *gc) { + return + gcBYTES_TO_WORDS(sizeof(Scheme_Small_Object)); +} + +static int small_atomic_obj_MARK(void *p, struct NewGC *gc) { + return + gcBYTES_TO_WORDS(sizeof(Scheme_Small_Object)); +} + +static int small_atomic_obj_FIXUP(void *p, struct NewGC *gc) { + return + gcBYTES_TO_WORDS(sizeof(Scheme_Small_Object)); +} + +#define small_atomic_obj_IS_ATOMIC 1 +#define small_atomic_obj_IS_CONST_SIZE 1 + + static int app_rec_SIZE(void *p, struct NewGC *gc) { Scheme_App_Rec *r = (Scheme_App_Rec *)p; @@ -1191,25 +1210,6 @@ static int escaping_cont_proc_FIXUP(void *p, struct NewGC *gc) { #define escaping_cont_proc_IS_CONST_SIZE 1 -static int char_obj_SIZE(void *p, struct NewGC *gc) { - return - gcBYTES_TO_WORDS(sizeof(Scheme_Small_Object)); -} - -static int char_obj_MARK(void *p, struct NewGC *gc) { - return - gcBYTES_TO_WORDS(sizeof(Scheme_Small_Object)); -} - -static int char_obj_FIXUP(void *p, struct NewGC *gc) { - return - gcBYTES_TO_WORDS(sizeof(Scheme_Small_Object)); -} - -#define char_obj_IS_ATOMIC 1 -#define char_obj_IS_CONST_SIZE 1 - - static int bignum_obj_SIZE(void *p, struct NewGC *gc) { Scheme_Bignum *b = (Scheme_Bignum *)p; diff --git a/src/racket/src/mzmarksrc.c b/src/racket/src/mzmarksrc.c index 265e289d94..3def9be272 100644 --- a/src/racket/src/mzmarksrc.c +++ b/src/racket/src/mzmarksrc.c @@ -89,6 +89,12 @@ small_object { gcBYTES_TO_WORDS(sizeof(Scheme_Small_Object)); } +small_atomic_obj { + mark: + size: + gcBYTES_TO_WORDS(sizeof(Scheme_Small_Object)); +} + app_rec { Scheme_App_Rec *r = (Scheme_App_Rec *)p; @@ -467,12 +473,6 @@ escaping_cont_proc { gcBYTES_TO_WORDS(sizeof(Scheme_Escaping_Cont)); } -char_obj { - mark: - size: - gcBYTES_TO_WORDS(sizeof(Scheme_Small_Object)); -} - bignum_obj { Scheme_Bignum *b = (Scheme_Bignum *)p; diff --git a/src/racket/src/optimize.c b/src/racket/src/optimize.c index 6d3c11976d..7e0bfab501 100644 --- a/src/racket/src/optimize.c +++ b/src/racket/src/optimize.c @@ -118,6 +118,8 @@ static Scheme_Object *optimize_shift(Scheme_Object *obj, int delta, int after_de static int compiled_proc_body_size(Scheme_Object *o, int less_args); +READ_ONLY static Scheme_Object *struct_proc_shape_other; + typedef struct Scheme_Once_Used { Scheme_Object so; Scheme_Object *expr; @@ -143,6 +145,9 @@ void scheme_init_optimize() #ifdef MZ_PRECISE_GC register_traversers(); #endif + + REGISTER_SO(struct_proc_shape_other); + struct_proc_shape_other = scheme_make_struct_proc_shape(3, 0, 0); } /*========================================================================*/ @@ -167,6 +172,47 @@ int scheme_is_functional_primitive(Scheme_Object *rator, int num_args, int expec return 0; } +static Scheme_Object *get_struct_proc_shape(Scheme_Object *rator, Optimize_Info *info) +{ + Scheme_Object *c; + + if (info + && (info->top_level_consts || info->cp->inline_variants) + && SAME_TYPE(SCHEME_TYPE(rator), scheme_compiled_toplevel_type)) { + int pos; + pos = SCHEME_TOPLEVEL_POS(rator); + c = NULL; + if (info->top_level_consts) + c = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos)); + if (!c && info->cp->inline_variants) + c = scheme_hash_get(info->cp->inline_variants, scheme_make_integer(pos)); + if (c && SAME_TYPE(SCHEME_TYPE(c), scheme_struct_proc_shape_type)) { + return c; + } + } + + return NULL; +} + +int scheme_is_struct_functional(Scheme_Object *rator, int num_args, Optimize_Info *info, int vals) +{ + Scheme_Object *c; + + if ((vals == 1) || (vals == -1)) { + c = get_struct_proc_shape(rator, info); + if (c) { + int mode = (SCHEME_PROC_SHAPE_MODE(c) & STRUCT_PROC_SHAPE_MASK); + int field_count = (SCHEME_PROC_SHAPE_MODE(c) >> STRUCT_PROC_SHAPE_SHIFT); + if (((num_args == 1) && (mode == STRUCT_PROC_SHAPE_PRED)) + || ((num_args == field_count) && (mode == STRUCT_PROC_SHAPE_CONSTR))) { + return 1; + } + } + } + + return 0; +} + static void note_match(int actual, int expected, Optimize_Info *warn_info) { if (!warn_info || (expected == -1)) @@ -183,7 +229,7 @@ static void note_match(int actual, int expected, Optimize_Info *warn_info) } int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, - Optimize_Info *warn_info, int deeper_than, int no_id) + Optimize_Info *opt_info, Optimize_Info *warn_info, int deeper_than, int no_id) /* Checks whether the bytecode `o' returns `vals' values with no side-effects and without pushing and using continuation marks. -1 for vals means that any return count is ok. @@ -258,9 +304,9 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, if (vtype == scheme_branch_type) { Scheme_Branch_Rec *b; b = (Scheme_Branch_Rec *)o; - return (scheme_omittable_expr(b->test, 1, fuel - 1, resolved, warn_info, deeper_than, 0) - && scheme_omittable_expr(b->tbranch, vals, fuel - 1, resolved, warn_info, deeper_than, no_id) - && scheme_omittable_expr(b->fbranch, vals, fuel - 1, resolved, warn_info, deeper_than, no_id)); + return (scheme_omittable_expr(b->test, 1, fuel - 1, resolved, opt_info, warn_info, deeper_than, 0) + && scheme_omittable_expr(b->tbranch, vals, fuel - 1, resolved, opt_info, warn_info, deeper_than, no_id) + && scheme_omittable_expr(b->fbranch, vals, fuel - 1, resolved, opt_info, warn_info, deeper_than, no_id)); } #if 0 @@ -268,15 +314,15 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, a let_value_type! */ if (vtype == scheme_let_value_type) { Scheme_Let_Value *lv = (Scheme_Let_Value *)o; - return (scheme_omittable_expr(lv->value, lv->count, fuel - 1, resolved, warn_info, deeper_than, no_id) - && scheme_omittable_expr(lv->body, vals, fuel - 1, resolved, warn_info, deeper_than, no_id)); + return (scheme_omittable_expr(lv->value, lv->count, fuel - 1, resolved, opt_info, warn_info, deeper_than, no_id) + && scheme_omittable_expr(lv->body, vals, fuel - 1, resolved, opt_info, warn_info, deeper_than, no_id)); } #endif if (vtype == scheme_let_one_type) { Scheme_Let_One *lo = (Scheme_Let_One *)o; - return (scheme_omittable_expr(lo->value, 1, fuel - 1, resolved, warn_info, deeper_than + 1, 0) - && scheme_omittable_expr(lo->body, vals, fuel - 1, resolved, warn_info, deeper_than + 1, no_id)); + return (scheme_omittable_expr(lo->value, 1, fuel - 1, resolved, opt_info, warn_info, deeper_than + 1, 0) + && scheme_omittable_expr(lo->body, vals, fuel - 1, resolved, opt_info, warn_info, deeper_than + 1, no_id)); } if (vtype == scheme_let_void_type) { @@ -286,7 +332,7 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, Scheme_Let_Value *lv2 = (Scheme_Let_Value *)lv->body; if ((lv2->count == 1) && (lv2->position == 0) - && scheme_omittable_expr(lv2->value, 1, fuel - 1, resolved, warn_info, + && scheme_omittable_expr(lv2->value, 1, fuel - 1, resolved, opt_info, warn_info, deeper_than + 1 + lv->count, 0)) { o = lv2->body; @@ -305,7 +351,7 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, if ((lh->count == 1) && (lh->num_clauses == 1)) { if (SAME_TYPE(SCHEME_TYPE(lh->body), scheme_compiled_let_value_type)) { Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body; - if (scheme_omittable_expr(lv->value, 1, fuel - 1, resolved, warn_info, deeper_than + 1, 0)) { + if (scheme_omittable_expr(lv->value, 1, fuel - 1, resolved, opt_info, warn_info, deeper_than + 1, 0)) { o = lv->body; deeper_than++; goto try_again; @@ -325,26 +371,19 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, if ((app->num_args >= 4) && (app->num_args <= 11) && SAME_OBJ(scheme_make_struct_type_proc, app->args[0])) { note_match(5, vals, warn_info); - if (scheme_is_simple_make_struct_type(o, vals, resolved, 0)) { - if ((app->num_args < 5) - /* auto-field value: */ - || scheme_omittable_expr(app->args[5], 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? app->num_args : 0), 0)) { - return 1; - } - } } - - if (SCHEME_PRIMP(app->args[0])) { - if (scheme_is_functional_primitive(app->args[0], app->num_args, vals)) { - int i; - for (i = app->num_args; i--; ) { - if (!scheme_omittable_expr(app->args[i + 1], 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? app->num_args : 0), 0)) - return 0; - } - return 1; - } else if (!(SCHEME_PRIM_PROC_FLAGS(app->args[0]) & SCHEME_PRIM_IS_MULTI_RESULT)) { + + if (scheme_is_functional_primitive(app->args[0], app->num_args, vals) + || scheme_is_struct_functional(app->args[0], app->num_args, opt_info, vals)) { + int i; + for (i = app->num_args; i--; ) { + if (!scheme_omittable_expr(app->args[i + 1], 1, fuel - 1, resolved, opt_info, warn_info, + deeper_than + (resolved ? app->num_args : 0), 0)) + return 0; + } + return 1; + } else if (SCHEME_PRIMP(app->args[0])) { + if (!(SCHEME_PRIM_PROC_FLAGS(app->args[0]) & SCHEME_PRIM_IS_MULTI_RESULT)) { note_match(1, vals, warn_info); } else if (SAME_OBJ(scheme_values_func, app->args[0])) { note_match(app->num_args, vals, warn_info); @@ -356,13 +395,14 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, if (vtype == scheme_application2_type) { Scheme_App2_Rec *app = (Scheme_App2_Rec *)o; - if (SCHEME_PRIMP(app->rator)) { - if (scheme_is_functional_primitive(app->rator, 1, vals)) { - if (scheme_omittable_expr(app->rand, 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? 1 : 0), 0)) - return 1; - } else if (!(SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_MULTI_RESULT) - || SAME_OBJ(scheme_values_func, app->rator)) { + if (scheme_is_functional_primitive(app->rator, 1, vals) + || scheme_is_struct_functional(app->rator, 1, opt_info, vals)) { + if (scheme_omittable_expr(app->rand, 1, fuel - 1, resolved, opt_info, warn_info, + deeper_than + (resolved ? 1 : 0), 0)) + return 1; + } else if (SCHEME_PRIMP(app->rator)) { + if (!(SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_MULTI_RESULT) + || SAME_OBJ(scheme_values_func, app->rator)) { note_match(1, vals, warn_info); } } @@ -371,14 +411,15 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, if (vtype == scheme_application3_type) { Scheme_App3_Rec *app = (Scheme_App3_Rec *)o; - if (SCHEME_PRIMP(app->rator)) { - if (scheme_is_functional_primitive(app->rator, 2, vals)) { - if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? 2 : 0), 0) - && scheme_omittable_expr(app->rand2, 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? 2 : 0), 0)) - return 1; - } else if (!(SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_MULTI_RESULT)) { + if (scheme_is_functional_primitive(app->rator, 2, vals) + || scheme_is_struct_functional(app->rator, 2, opt_info, vals)) { + if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, opt_info, warn_info, + deeper_than + (resolved ? 2 : 0), 0) + && scheme_omittable_expr(app->rand2, 1, fuel - 1, resolved, opt_info, warn_info, + deeper_than + (resolved ? 2 : 0), 0)) + return 1; + } else if (SCHEME_PRIMP(app->rator)) { + if (!(SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_MULTI_RESULT)) { note_match(1, vals, warn_info); } else if (SAME_OBJ(scheme_values_func, app->rator)) { note_match(2, vals, warn_info); @@ -387,6 +428,22 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, return 0; } + /* check for struct-type declaration: */ + { + Scheme_Object *auto_e; + int auto_e_depth; + auto_e = scheme_is_simple_make_struct_type(o, vals, resolved, 0, &auto_e_depth, + NULL, NULL, NULL, + (opt_info ? opt_info->top_level_consts : NULL), + NULL, NULL, 0, NULL, NULL, + 5); + if (auto_e) { + if (scheme_omittable_expr(auto_e, 1, fuel - 1, resolved, opt_info, warn_info, + deeper_than + auto_e_depth, 0)) + return 1; + } + } + return 0; } @@ -460,33 +517,58 @@ static int is_int_list(Scheme_Object *o, int up_to) return SCHEME_NULLP(o); } -static int is_values_with_accessors_and_mutators(Scheme_Object *e, int vals, int resolved) +static int ok_proc_creator_args(Scheme_Object *rator, Scheme_Object *rand1, Scheme_Object *rand2, Scheme_Object *rand3, + int delta2, int field_count) +{ + if ((SAME_OBJ(rator, scheme_make_struct_field_accessor_proc) + && is_local_ref(rand1, delta2+3, 1)) + || (SAME_OBJ(rator, scheme_make_struct_field_mutator_proc) + && is_local_ref(rand1, delta2+4, 1))) { + if (SCHEME_INTP(rand2) + && (SCHEME_INT_VAL(rand2) >= 0) + && (SCHEME_INT_VAL(rand2) < field_count) + && (!rand3 || SCHEME_SYMBOLP(rand3))) { + return 1; + } + } + + return 0; +} + +static int is_values_with_accessors_and_mutators(Scheme_Object *e, int vals, int resolved, int field_count) { if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) { Scheme_App_Rec *app = (Scheme_App_Rec *)e; int delta = (resolved ? app->num_args : 0); if (SAME_OBJ(app->args[0], scheme_values_func) - && (app->num_args == vals)) { + && (app->num_args == vals) + && (app->num_args >= 3) + && is_local_ref(app->args[1], delta, 1) + && is_local_ref(app->args[2], delta+1, 1) + && is_local_ref(app->args[3], delta+2, 1)) { int i; - for (i = app->num_args; i > 0; i--) { - if (is_local_ref(app->args[1], delta, 5)) { + for (i = app->num_args; i > 3; i--) { + if (is_local_ref(app->args[i], delta, 5)) { /* ok */ - } else if (SAME_TYPE(SCHEME_TYPE(app->args[i]), scheme_application3_type)) { - Scheme_App3_Rec *app3 = (Scheme_App3_Rec *)app->args[i]; - int delta2 = delta + (resolved ? 2 : 0); - if (SAME_OBJ(app3->rator, scheme_make_struct_field_accessor_proc)) { - if (!is_local_ref(app3->rand1, delta2+3, 1) - && SCHEME_SYMBOLP(app3->rand2)) - break; - } else if (SAME_OBJ(app3->rator, scheme_make_struct_field_mutator_proc)) { - if (!is_local_ref(app3->rand1, delta2+4, 1) - && SCHEME_SYMBOLP(app3->rand2)) + } else if (SAME_TYPE(SCHEME_TYPE(app->args[i]), scheme_application_type)) { + Scheme_App_Rec *app3 = (Scheme_App_Rec *)app->args[i]; + int delta2 = delta + (resolved ? app3->num_args : 0); + if (app3->num_args == 3) { + if (!ok_proc_creator_args(app3->args[0], app3->args[1], app3->args[2], app3->args[3], + delta2, field_count)) break; } else break; - } + } else if (SAME_TYPE(SCHEME_TYPE(app->args[i]), scheme_application3_type)) { + Scheme_App3_Rec *app3 = (Scheme_App3_Rec *)app->args[i]; + int delta2 = delta + (resolved ? 2 : 0); + if (!ok_proc_creator_args(app3->rator, app3->rand1, app3->rand2, NULL, + delta2, field_count)) + break; + } else + break; } - if (i <= 0) + if (i <= 3) return 1; } } @@ -509,18 +591,112 @@ static Scheme_Object *skip_clears(Scheme_Object *body) return body; } -int scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int resolved, int check_auto) -/* Checks whether it's a `make-struct-type' call that certainly succeeds - (i.e., no exception) --- pending a check of argument 5 if !check_auto */ +static int is_constant_super(Scheme_Object *arg, + Scheme_Hash_Table *top_level_consts, + Scheme_Hash_Table *top_level_table, + Scheme_Object **runstack, int rs_delta, + Scheme_Object **symbols, Scheme_Hash_Table *symbol_table) { + int pos; + Scheme_Object *v; + + if (SAME_TYPE(SCHEME_TYPE(arg), scheme_compiled_toplevel_type)) { + pos = SCHEME_TOPLEVEL_POS(arg); + if (top_level_consts) { + /* This is optimize mode */ + v = scheme_hash_get(top_level_consts, scheme_make_integer(pos)); + if (v && SAME_TYPE(SCHEME_TYPE(v), scheme_struct_proc_shape_type)) { + int mode = (SCHEME_PROC_SHAPE_MODE(v) & STRUCT_PROC_SHAPE_MASK); + int field_count = (SCHEME_PROC_SHAPE_MODE(v) >> STRUCT_PROC_SHAPE_SHIFT); + if (mode == STRUCT_PROC_SHAPE_STRUCT) + return field_count + 1; + } + } + } else if (SAME_TYPE(SCHEME_TYPE(arg), scheme_toplevel_type)) { + pos = SCHEME_TOPLEVEL_POS(arg); + if (runstack) { + /* This is eval mode; conceptually, this code belongs in + define_execute_with_dynamic_state() */ + Scheme_Bucket *b; + Scheme_Prefix *toplevels; + toplevels = (Scheme_Prefix *)runstack[SCHEME_TOPLEVEL_DEPTH(arg) - rs_delta]; + b = (Scheme_Bucket *)toplevels->a[pos]; + if (b->val) { + if (SCHEME_STRUCT_TYPEP(b->val) + && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_CONSISTENT)) { + Scheme_Struct_Type *st = (Scheme_Struct_Type *)b->val; + if (st->num_slots == st->num_islots) + return st->num_slots + 1; + } + } + } + if (symbols) { + /* This is module-export mode; conceptually, this code belongs in + setup_accessible_table() */ + Scheme_Object *name; + name = symbols[pos]; + if (SCHEME_SYMBOLP(name)) { + v = scheme_hash_get(symbol_table, name); + if (v && SCHEME_PAIRP(v)) { + v = SCHEME_CDR(v); + if (v && SAME_TYPE(SCHEME_TYPE(v), scheme_struct_proc_shape_type)) { + int mode = (SCHEME_PROC_SHAPE_MODE(v) & STRUCT_PROC_SHAPE_MASK); + int field_count = (SCHEME_PROC_SHAPE_MODE(v) >> STRUCT_PROC_SHAPE_SHIFT); + if (mode == STRUCT_PROC_SHAPE_STRUCT) + return field_count + 1; + } + } + } + } + if (top_level_table) { + /* This is validate mode; conceptually, this code belongs in + define_values_validate() */ + v = scheme_hash_get(top_level_table, scheme_make_integer(pos)); + if (v) + return SCHEME_INT_VAL(v) + 1; + } + } + + return 0; +} + +Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int resolved, + int check_auto, + GC_CAN_IGNORE int *_auto_e_depth, + int *_field_count, int *_init_field_count, + int *_uses_super, + Scheme_Hash_Table *top_level_consts, + Scheme_Hash_Table *top_level_table, + Scheme_Object **runstack, int rs_delta, + Scheme_Object **symbols, Scheme_Hash_Table *symbol_table, + int fuel) +/* Checks whether it's a `make-struct-type' call that certainly succeeds + (i.e., no exception) --- pending a check of the auto-value argument if !check_auto. + The result is the auto-value argument or scheme_true if it's simple, NULL if not. + The first result is a struct type, the second a constructor, and the thrd a predicate; + the rest are an unspecified mixture of selectors and mutators. */ +{ + if (!fuel) return NULL; + if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) { if ((vals == 5) || (vals < 0)) { Scheme_App_Rec *app = (Scheme_App_Rec *)e; if ((app->num_args >= 4) && (app->num_args <= 11) && SAME_OBJ(scheme_make_struct_type_proc, app->args[0])) { + int super_count_plus_one; + + if (!SCHEME_FALSEP(app->args[2])) + super_count_plus_one = is_constant_super(app->args[2], + top_level_consts, top_level_table, runstack, + rs_delta + app->num_args, + symbols, symbol_table); + else + super_count_plus_one = 0; + if (SCHEME_SYMBOLP(app->args[1]) - && SCHEME_FALSEP(app->args[2]) /* super = #f */ + && (SCHEME_FALSEP(app->args[2]) /* super */ + || super_count_plus_one) && SCHEME_INTP(app->args[3]) && (SCHEME_INT_VAL(app->args[3]) >= 0) && SCHEME_INTP(app->args[4]) @@ -528,13 +704,16 @@ int scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int resolved, && ((app->num_args < 5) /* auto-field value: */ || !check_auto - || scheme_omittable_expr(app->args[5], 1, 3, resolved, NULL, -1, 0)) + || scheme_omittable_expr(app->args[5], 1, 3, resolved, NULL, NULL, -1, 0)) && ((app->num_args < 6) /* no properties: */ || SCHEME_NULLP(app->args[6])) && ((app->num_args < 7) /* inspector: */ || SCHEME_FALSEP(app->args[7]) + || (SCHEME_SYMBOLP(app->args[7]) + && !strcmp("prefab", SCHEME_SYM_VAL(app->args[7])) + && !SCHEME_SYM_WEIRDP(app->args[7])) || is_current_inspector_call(app->args[7])) && ((app->num_args < 8) /* propcedure property: */ @@ -551,7 +730,20 @@ int scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int resolved, /* constructor name: */ || SCHEME_FALSEP(app->args[11]) || SCHEME_SYMBOLP(app->args[11]))) { - return 1; + int super_count = (super_count_plus_one + ? (super_count_plus_one - 1) + : 0); + if (_auto_e_depth) + *_auto_e_depth = (resolved ? app->num_args : 0); + if (_field_count) + *_field_count = SCHEME_INT_VAL(app->args[3]) + super_count; + if (_init_field_count) + *_init_field_count = (SCHEME_INT_VAL(app->args[3]) + + SCHEME_INT_VAL(app->args[4]) + + super_count); + if (_uses_super) + *_uses_super = (super_count_plus_one ? 1 : 0); + return ((app->num_args < 5) ? scheme_true : app->args[5]); } } } @@ -564,12 +756,29 @@ int scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int resolved, if ((lh->count == 5) && (lh->num_clauses == 1)) { if (SAME_TYPE(SCHEME_TYPE(lh->body), scheme_compiled_let_value_type)) { Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body; - if (SAME_TYPE(SCHEME_TYPE(lv->value), scheme_application_type) - && scheme_is_simple_make_struct_type(lv->value, 5, resolved, check_auto)) { - /* We have (let-values ([... (make-struct-type)]) ....), so make sure body - just uses `make-struct-field-{accessor,mutator}'. */ - if (is_values_with_accessors_and_mutators(lv->body, vals, resolved)) - return 1; + if (SAME_TYPE(SCHEME_TYPE(lv->value), scheme_application_type)) { + Scheme_Object *auto_e; + int ifc; + int lh_delta = ((SCHEME_LET_FLAGS(lh) & (SCHEME_LET_RECURSIVE | SCHEME_LET_STAR)) + ? lh->count + : 0); + auto_e = scheme_is_simple_make_struct_type(lv->value, 5, resolved, check_auto, + _auto_e_depth, _field_count, &ifc, + _uses_super, + top_level_consts, top_level_table, + runstack, rs_delta + lh_delta, + symbols, symbol_table, + fuel-1); + if (auto_e) { + /* We have (let-values ([... (make-struct-type)]) ....), so make sure body + just uses `make-struct-field-{accessor,mutator}'. */ + if (is_values_with_accessors_and_mutators(lv->body, vals, resolved, ifc)) { + if (_auto_e_depth && lh_delta) + *_auto_e_depth += lh_delta; + if (_init_field_count) *_init_field_count = ifc; + return auto_e; + } + } } } } @@ -584,20 +793,63 @@ int scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int resolved, if ((lv->position == 0) && (lv->count == 5)) { Scheme_Object *e2; e2 = skip_clears(lv->value); - if (SAME_TYPE(SCHEME_TYPE(e2), scheme_application_type) - && scheme_is_simple_make_struct_type(e2, 5, resolved, check_auto)) { - /* We have (let-values ([... (make-struct-type)]) ....), so make sure body - just uses `make-struct-field-{accessor,mutator}'. */ - e2 = skip_clears(lv->body); - if (is_values_with_accessors_and_mutators(e2, vals, resolved)) - return 1; + if (SAME_TYPE(SCHEME_TYPE(e2), scheme_application_type)) { + Scheme_Object *auto_e; + int ifc; + auto_e = scheme_is_simple_make_struct_type(e2, 5, resolved, check_auto, + _auto_e_depth, _field_count, &ifc, + _uses_super, + top_level_consts, top_level_table, + runstack, rs_delta + lvd->count, + symbols, symbol_table, + fuel-1); + if (auto_e) { + /* We have (let-values ([... (make-struct-type)]) ....), so make sure body + just uses `make-struct-field-{accessor,mutator}'. */ + e2 = skip_clears(lv->body); + if (is_values_with_accessors_and_mutators(e2, vals, resolved, ifc)) { + if (_auto_e_depth) *_auto_e_depth += lvd->count; + if (_init_field_count) *_init_field_count = ifc; + return auto_e; + } + } } } } } } - return 0; + return NULL; +} + +Scheme_Object *scheme_make_struct_proc_shape(int k, int field_count, int init_field_count) +{ + Scheme_Object *ps; + + switch (k) { + case 0: + if (field_count == init_field_count) + k = STRUCT_PROC_SHAPE_STRUCT | (field_count << STRUCT_PROC_SHAPE_SHIFT); + else + k = STRUCT_PROC_SHAPE_OTHER; + break; + case 1: + k = STRUCT_PROC_SHAPE_CONSTR | (init_field_count << STRUCT_PROC_SHAPE_SHIFT); + break; + case 2: + k = STRUCT_PROC_SHAPE_PRED; + break; + default: + if (struct_proc_shape_other) + return struct_proc_shape_other; + k = STRUCT_PROC_SHAPE_OTHER; + } + + ps = scheme_malloc_small_atomic_tagged(sizeof(Scheme_Small_Object)); + ps->type = scheme_struct_proc_shape_type; + SCHEME_PROC_SHAPE_MODE(ps) = k; + + return ps; } static int single_valued_noncm_expression(Scheme_Object *expr, int fuel) @@ -2039,9 +2291,17 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz } } + if (SAME_OBJ(scheme_struct_type_p_proc, app->rator)) { + Scheme_Object *c; + c = get_struct_proc_shape(app->rand, info); + if (c && ((SCHEME_PROC_SHAPE_MODE(c) & STRUCT_PROC_SHAPE_MASK) + == STRUCT_PROC_SHAPE_STRUCT)) + return scheme_true; + } + if ((SAME_OBJ(scheme_values_func, app->rator) || SAME_OBJ(scheme_list_star_proc, app->rator)) - && (scheme_omittable_expr(app->rand, 1, -1, 0, info, -1, 0) + && (scheme_omittable_expr(app->rand, 1, -1, 0, info, info, -1, 0) || single_valued_noncm_expression(app->rand, 5))) { info->preserves_marks = 1; info->single_result = 1; @@ -2083,13 +2343,13 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz if (SAME_OBJ(scheme_list_proc, app2->rator)) { if (IS_NAMED_PRIM(app->rator, "car")) { /* (car (list X)) */ - if (scheme_omittable_expr(app2->rand, 1, 5, 0, NULL, -1, 0) + if (scheme_omittable_expr(app2->rand, 1, 5, 0, info, NULL, -1, 0) || single_valued_noncm_expression(app2->rand, 5)) { alt = app2->rand; } } else if (IS_NAMED_PRIM(app->rator, "cdr")) { /* (cdr (list X)) */ - if (scheme_omittable_expr(app2->rand, 1, 5, 0, NULL, -1, 0)) + if (scheme_omittable_expr(app2->rand, 1, 5, 0, info, NULL, -1, 0)) alt = scheme_null; } } @@ -2100,27 +2360,27 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz || SAME_OBJ(scheme_list_proc, app3->rator) || SAME_OBJ(scheme_list_star_proc, app3->rator)) { /* (car ({cons|list|list*} X Y)) */ - if ((scheme_omittable_expr(app3->rand1, 1, 5, 0, NULL, -1, 0) + if ((scheme_omittable_expr(app3->rand1, 1, 5, 0, info, NULL, -1, 0) || single_valued_noncm_expression(app3->rand1, 5)) - && scheme_omittable_expr(app3->rand2, 1, 5, 0, NULL, -1, 0)) { + && scheme_omittable_expr(app3->rand2, 1, 5, 0, info, NULL, -1, 0)) { alt = app3->rand1; } } } else if (IS_NAMED_PRIM(app->rator, "cdr")) { /* (cdr (cons X Y)) */ if (SAME_OBJ(scheme_cons_proc, app3->rator)) { - if ((scheme_omittable_expr(app3->rand2, 1, 5, 0, NULL, -1, 0) + if ((scheme_omittable_expr(app3->rand2, 1, 5, 0, info, NULL, -1, 0) || single_valued_noncm_expression(app3->rand2, 5)) - && scheme_omittable_expr(app3->rand1, 1, 5, 0, NULL, -1, 0)) { + && scheme_omittable_expr(app3->rand1, 1, 5, 0, info, NULL, -1, 0)) { alt = app3->rand2; } } } else if (IS_NAMED_PRIM(app->rator, "cadr")) { if (SAME_OBJ(scheme_list_proc, app3->rator)) { /* (cadr (list X Y)) */ - if ((scheme_omittable_expr(app3->rand2, 1, 5, 0, NULL, -1, 0) + if ((scheme_omittable_expr(app3->rand2, 1, 5, 0, info, NULL, -1, 0) || single_valued_noncm_expression(app3->rand2, 5)) - && scheme_omittable_expr(app3->rand1, 1, 5, 0, NULL, -1, 0)) { + && scheme_omittable_expr(app3->rand1, 1, 5, 0, info, NULL, -1, 0)) { alt = app3->rand2; } } @@ -2472,7 +2732,7 @@ static Scheme_Object *optimize_sequence(Scheme_Object *o, Optimize_Info *info, i /* Inlining and constant propagation can expose omittable expressions. */ if ((i + 1 != count) - && scheme_omittable_expr(le, -1, -1, 0, NULL, -1, 0)) { + && scheme_omittable_expr(le, -1, -1, 0, info, NULL, -1, 0)) { drop++; info->size = prev_size; s->array[i] = NULL; @@ -2655,7 +2915,7 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int } /* Try optimize: (if v v) => v */ - if (scheme_omittable_expr(t, 1, 20, 0, NULL, -1, 0) + if (scheme_omittable_expr(t, 1, 20, 0, info, NULL, -1, 0) && equivalent_exprs(tb, fb)) { info->size -= 2; /* could be more precise */ return tb; @@ -2697,7 +2957,7 @@ static int omittable_key(Scheme_Object *k, Optimize_Info *info) { /* A key is not omittable if it might refer to a chaperoned/impersonated continuation mark key, so that's why we pass 1 for `no_id': */ - return scheme_omittable_expr(k, 1, 20, 0, info, -1, 1); + return scheme_omittable_expr(k, 1, 20, 0, info, info, -1, 1); } static Scheme_Object *optimize_wcm(Scheme_Object *o, Optimize_Info *info, int context) @@ -2712,8 +2972,8 @@ static Scheme_Object *optimize_wcm(Scheme_Object *o, Optimize_Info *info, int co b = scheme_optimize_expr(wcm->body, info, scheme_optimize_tail_context(context)); if (omittable_key(k, info) - && scheme_omittable_expr(v, 1, 20, 0, info, -1, 0) - && scheme_omittable_expr(b, -1, 20, 0, info, -1, 0)) + && scheme_omittable_expr(v, 1, 20, 0, info, info, -1, 0) + && scheme_omittable_expr(b, -1, 20, 0, info, info, -1, 0)) return b; /* info->single_result is already set */ @@ -3030,17 +3290,53 @@ case_lambda_shift(Scheme_Object *data, int delta, int after_depth) static Scheme_Object * begin0_optimize(Scheme_Object *obj, Optimize_Info *info, int context) { - int i, count; + int i, count, drop = 0, prev_size; + Scheme_Sequence *s = (Scheme_Sequence *)obj; + Scheme_Object *le; - count = ((Scheme_Sequence *)obj)->count; + count = s->count; for (i = 0; i < count; i++) { - Scheme_Object *le; - le = scheme_optimize_expr(((Scheme_Sequence *)obj)->array[i], info, + prev_size = info->size; + + le = scheme_optimize_expr(s->array[i], + info, (!i ? scheme_optimize_result_context(context) : 0)); - ((Scheme_Sequence *)obj)->array[i] = le; + + /* Inlining and constant propagation can expose + omittable expressions. */ + if (i && scheme_omittable_expr(le, -1, -1, 0, info, NULL, -1, 0)) { + drop++; + info->size = prev_size; + s->array[i] = NULL; + } else { + s->array[i] = le; + } + } + + if (drop) { + Scheme_Sequence *s2; + int j = 0; + + if ((s->count - drop) == 1) { + /* can't drop down to 1 expression */ + s->array[s->count-1] = scheme_false; + --drop; + } + + s2 = scheme_malloc_sequence(s->count - drop); + s2->so.type = s->so.type; + s2->count = s->count - drop; + + for (i = 0; i < s->count; i++) { + if (s->array[i]) { + s2->array[j++] = s->array[i]; + } + } + + obj = (Scheme_Object *)s2; } /* Optimization of expression 0 has already set single_result */ @@ -3236,6 +3532,9 @@ int scheme_compiled_propagate_ok(Scheme_Object *value, Optimize_Info *info) pos = SCHEME_TOPLEVEL_POS(value); value = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos)); value = no_potential_size(value); + if (SAME_OBJ(value, scheme_constant_key) + || (value && SAME_TYPE(SCHEME_TYPE(value), scheme_struct_proc_shape_type))) + return 0; if (value) return 1; } @@ -3256,7 +3555,7 @@ int scheme_is_statically_proc(Scheme_Object *value, Optimize_Info *info) Scheme_Let_Header *lh = (Scheme_Let_Header *)value; if (lh->num_clauses == 1) { Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body; - if (scheme_omittable_expr(lv->value, lv->count, 20, 0, NULL, -1, 0)) { + if (scheme_omittable_expr(lv->value, lv->count, 20, 0, info, NULL, -1, 0)) { value = lv->body; info = NULL; } else @@ -3819,7 +4118,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i if ((pre_body->count != 1) && is_values_apply(value, pre_body->count) && ((!is_rec && no_mutable_bindings(pre_body)) - || scheme_omittable_expr(value, pre_body->count, -1, 0, info, + || scheme_omittable_expr(value, pre_body->count, -1, 0, info, info, (is_rec ? (pre_body->position + pre_body->count) : -1), @@ -4202,7 +4501,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i } if (!used - && (scheme_omittable_expr(pre_body->value, pre_body->count, -1, 0, info, -1, 0) + && (scheme_omittable_expr(pre_body->value, pre_body->count, -1, 0, info, info, -1, 0) || ((pre_body->count == 1) && first_once_used && (first_once_used->pos == pos) @@ -4630,7 +4929,7 @@ static Scheme_Object *is_cross_module_inline_candidiate(Scheme_Object *e, Optimi return NULL; } -static int is_general_compiled_proc(Scheme_Object *e) +static int is_general_compiled_proc(Scheme_Object *e, Optimize_Info *info) { /* recognize (begin * ) */ if (SCHEME_TYPE(e) == scheme_sequence_type) { @@ -4638,7 +4937,7 @@ static int is_general_compiled_proc(Scheme_Object *e) if (seq->count > 0) { int i; for (i = seq->count - 1; i--; ) { - if (!scheme_omittable_expr(seq->array[i], -1, 20, 0, NULL, -1, 0)) + if (!scheme_omittable_expr(seq->array[i], -1, 20, 0, info, NULL, -1, 0)) return 0; } } @@ -4739,7 +5038,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { Scheme_Object *e2; e2 = SCHEME_VEC_ELS(e)[1]; - if (is_general_compiled_proc(e2)) + if (is_general_compiled_proc(e2, info)) is_proc_def = 1; } } @@ -4763,13 +5062,19 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) (including raising an exception), then continue the group of simultaneous definitions: */ if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { - int n, cnst = 0, sproc = 0; + int n, cnst = 0, sproc = 0, sstruct = 0, field_count = 0, init_field_count = 0; vars = SCHEME_VEC_ELS(e)[0]; e = SCHEME_VEC_ELS(e)[1]; n = scheme_list_length(vars); - cont = scheme_omittable_expr(e, n, -1, 0, info, -1, 0); + cont = scheme_omittable_expr(e, n, -1, 0, + /* no `info' here, because the decision + of omittable should not depend on + information that's only available at + optimization time: */ + NULL, + info, -1, 0); if (n == 1) { if (scheme_compiled_propagate_ok(e, info)) @@ -4778,20 +5083,28 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) cnst = 1; sproc = 1; } - } else if (scheme_is_simple_make_struct_type(e, n, 0, 1)) { + } else if (scheme_is_simple_make_struct_type(e, n, 0, 1, NULL, + &field_count, &init_field_count, NULL, + info->top_level_consts, + NULL, NULL, 0, NULL, NULL, + 5)) { + sstruct = 1; cnst = 1; } if (cnst) { Scheme_Toplevel *tl; - while (n--) { + int i; + for (i = 0; i < n; i++) { tl = (Scheme_Toplevel *)SCHEME_CAR(vars); vars = SCHEME_CDR(vars); if (!(SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_MUTATED)) { Scheme_Object *e2; - if (sproc) { + if (sstruct) { + e2 = scheme_make_struct_proc_shape(i, field_count, init_field_count); + } else if (sproc) { e2 = scheme_make_noninline_proc(e); } else if (IS_COMPILED_PROC(e)) { e2 = optimize_clone(1, e, info, 0, 0); @@ -4811,17 +5124,27 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) if (e2) { int pos; - if (!consts) - consts = scheme_make_hash_table(SCHEME_hash_ptr); pos = tl->position; - scheme_hash_set(consts, scheme_make_integer(pos), e2); - if (!re_consts) - re_consts = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(re_consts, scheme_make_integer(i_m), - scheme_make_integer(pos)); + if (sstruct) { + /* Add directly to `info->top_level_consts' for use + by sub-struct declarations in the same set */ + if (!info->top_level_consts) { + Scheme_Hash_Table *tlc; + tlc = scheme_make_hash_table(SCHEME_hash_ptr); + info->top_level_consts = tlc; + } + scheme_hash_set(info->top_level_consts, scheme_make_integer(pos), e2); + } else { + if (!consts) + consts = scheme_make_hash_table(SCHEME_hash_ptr); + scheme_hash_set(consts, scheme_make_integer(pos), e2); + if (!re_consts) + re_consts = scheme_make_hash_table(SCHEME_hash_ptr); + scheme_hash_set(re_consts, scheme_make_integer(i_m), + scheme_make_integer(pos)); + } } else { /* At least mark it as fixed */ - if (!fixed_table) { fixed_table = scheme_make_hash_table(SCHEME_hash_ptr); if (!consts) @@ -4851,7 +5174,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) } } } else { - cont = scheme_omittable_expr(e, -1, -1, 0, NULL, -1, 0); + cont = scheme_omittable_expr(e, -1, -1, 0, NULL, NULL, -1, 0); } if (i_m + 1 == cnt) cont = 0; @@ -5025,7 +5348,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) for (i_m = 0; i_m < cnt; i_m++) { /* Optimize this expression: */ e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; - if (scheme_omittable_expr(e, -1, -1, 0, NULL, -1, 0)) { + if (scheme_omittable_expr(e, -1, -1, 0, info, NULL, -1, 0)) { can_omit++; } } @@ -5036,7 +5359,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) for (i_m = 0; i_m < cnt; i_m++) { /* Optimize this expression: */ e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; - if (!scheme_omittable_expr(e, -1, -1, 0, NULL, -1, 0)) { + if (!scheme_omittable_expr(e, -1, -1, 0, info, NULL, -1, 0)) { SCHEME_VEC_ELS(vec)[j++] = e; } } diff --git a/src/racket/src/resolve.c b/src/racket/src/resolve.c index 5635b1d17c..5ce2407393 100644 --- a/src/racket/src/resolve.c +++ b/src/racket/src/resolve.c @@ -508,7 +508,7 @@ static Scheme_Object *look_for_letv_change(Scheme_Sequence *s) v = s->array[i]; if (SAME_TYPE(SCHEME_TYPE(v), scheme_let_value_type)) { Scheme_Let_Value *lv = (Scheme_Let_Value *)v; - if (scheme_omittable_expr(lv->body, 1, -1, 0, NULL, -1, 0)) { + if (scheme_omittable_expr(lv->body, 1, -1, 0, NULL, NULL, -1, 0)) { int esize = s->count - (i + 1); int nsize = i + 1; Scheme_Object *nv, *ev; @@ -1240,7 +1240,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) } if (j >= 0) break; - if (!scheme_omittable_expr(clv->value, clv->count, -1, 0, NULL, -1, 0)) + if (!scheme_omittable_expr(clv->value, clv->count, -1, 0, NULL, NULL, -1, 0)) break; } if (i < 0) { diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index a14d86d6bb..880a8cdd55 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -373,6 +373,7 @@ extern Scheme_Object *scheme_call_with_values_proc; extern Scheme_Object *scheme_make_struct_type_proc; extern Scheme_Object *scheme_make_struct_field_accessor_proc; extern Scheme_Object *scheme_make_struct_field_mutator_proc; +extern Scheme_Object *scheme_struct_type_p_proc; extern Scheme_Object *scheme_current_inspector_proc; extern Scheme_Object *scheme_varref_const_p_proc; @@ -2860,11 +2861,28 @@ int scheme_used_app_only(Scheme_Comp_Env *env, int which); int scheme_used_ever(Scheme_Comp_Env *env, int which); int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, - Optimize_Info *warn_info, int deeper_than, int no_id); + Optimize_Info *opt_info, Optimize_Info *warn_info, int deeper_than, int no_id); int scheme_might_invoke_call_cc(Scheme_Object *value); int scheme_is_liftable(Scheme_Object *o, int bind_count, int fuel, int as_rator); int scheme_is_functional_primitive(Scheme_Object *rator, int num_args, int expected_vals); -int scheme_is_simple_make_struct_type(Scheme_Object *app, int vals, int resolved, int check_auto); +Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *app, int vals, int resolved, + int check_auto, int *_auto_e_depth, + int *_field_count, int *_init_field_count, + int *_uses_super, + Scheme_Hash_Table *top_level_consts, + Scheme_Hash_Table *top_level_table, + Scheme_Object **runstack, int rs_delta, + Scheme_Object **symbols, Scheme_Hash_Table *symbol_table, + int fuel); + +Scheme_Object *scheme_make_struct_proc_shape(int k, int field_count, int init_field_count); +#define STRUCT_PROC_SHAPE_STRUCT 0 +#define STRUCT_PROC_SHAPE_PRED 1 +#define STRUCT_PROC_SHAPE_OTHER 2 +#define STRUCT_PROC_SHAPE_CONSTR 3 +#define STRUCT_PROC_SHAPE_MASK 0x7 +#define STRUCT_PROC_SHAPE_SHIFT 3 +#define SCHEME_PROC_SHAPE_MODE(obj) (((Scheme_Small_Object *)(obj))->u.int_val) int scheme_is_env_variable_boxed(Scheme_Comp_Env *env, int which); diff --git a/src/racket/src/sfs.c b/src/racket/src/sfs.c index 0c0ec2156f..b6828cb69c 100644 --- a/src/racket/src/sfs.c +++ b/src/racket/src/sfs.c @@ -671,7 +671,7 @@ static Scheme_Object *sfs_let_one(Scheme_Object *o, SFS_Info *info) it might not because (1) it was introduced late by inlining, or (2) the rhs expression doesn't always produce a single value. */ - if (scheme_omittable_expr(rhs, 1, -1, 1, NULL, -1, 0)) { + if (scheme_omittable_expr(rhs, 1, -1, 1, NULL, NULL, -1, 0)) { rhs = scheme_false; } else if ((ip < info->max_calls[pos]) && SAME_TYPE(SCHEME_TYPE(rhs), scheme_toplevel_type)) { diff --git a/src/racket/src/struct.c b/src/racket/src/struct.c index 74d4c50956..44958b10a4 100644 --- a/src/racket/src/struct.c +++ b/src/racket/src/struct.c @@ -38,6 +38,7 @@ READ_ONLY Scheme_Object *scheme_impersonator_of_property; READ_ONLY Scheme_Object *scheme_make_struct_type_proc; READ_ONLY Scheme_Object *scheme_make_struct_field_accessor_proc; READ_ONLY Scheme_Object *scheme_make_struct_field_mutator_proc; +READ_ONLY Scheme_Object *scheme_struct_type_p_proc; READ_ONLY Scheme_Object *scheme_current_inspector_proc; READ_ONLY Scheme_Object *scheme_recur_symbol; READ_ONLY Scheme_Object *scheme_display_symbol; @@ -607,11 +608,13 @@ scheme_init_struct (Scheme_Env *env) "struct?", 1, 1, 1), env); - scheme_add_global_constant("struct-type?", - scheme_make_folding_prim(struct_type_p, - "struct-type?", - 1, 1, 1), - env); + + REGISTER_SO(scheme_struct_type_p_proc); + scheme_struct_type_p_proc = scheme_make_folding_prim(struct_type_p, + "struct-type?", + 1, 1, 1); + scheme_add_global_constant("struct-type?", scheme_struct_type_p_proc, env); + scheme_add_global_constant("struct-type-property?", scheme_make_folding_prim(struct_type_property_p, "struct-type-property?", diff --git a/src/racket/src/stypes.h b/src/racket/src/stypes.h index 62d0ed51ab..e69c816d31 100644 --- a/src/racket/src/stypes.h +++ b/src/racket/src/stypes.h @@ -198,83 +198,84 @@ enum { scheme_serialized_tcp_fd_type, /* 178 */ scheme_serialized_file_fd_type, /* 179 */ scheme_port_closed_evt_type, /* 180 */ + scheme_struct_proc_shape_type, /* 181 */ #ifdef MZTAG_REQUIRED - _scheme_last_normal_type_, /* 181 */ + _scheme_last_normal_type_, /* 182 */ - scheme_rt_weak_array, /* 182 */ + scheme_rt_weak_array, /* 183 */ - scheme_rt_comp_env, /* 183 */ - scheme_rt_constant_binding, /* 184 */ - scheme_rt_resolve_info, /* 185 */ - scheme_rt_unresolve_info, /* 186 */ - scheme_rt_optimize_info, /* 187 */ - scheme_rt_compile_info, /* 188 */ - scheme_rt_cont_mark, /* 189 */ - scheme_rt_saved_stack, /* 190 */ - scheme_rt_reply_item, /* 191 */ - scheme_rt_closure_info, /* 192 */ - scheme_rt_overflow, /* 193 */ - scheme_rt_overflow_jmp, /* 194 */ - scheme_rt_meta_cont, /* 195 */ - scheme_rt_dyn_wind_cell, /* 196 */ - scheme_rt_dyn_wind_info, /* 197 */ - scheme_rt_dyn_wind, /* 198 */ - scheme_rt_dup_check, /* 199 */ - scheme_rt_thread_memory, /* 200 */ - scheme_rt_input_file, /* 201 */ - scheme_rt_input_fd, /* 202 */ - scheme_rt_oskit_console_input, /* 203 */ - scheme_rt_tested_input_file, /* 204 */ - scheme_rt_tested_output_file, /* 205 */ - scheme_rt_indexed_string, /* 206 */ - scheme_rt_output_file, /* 207 */ - scheme_rt_load_handler_data, /* 208 */ - scheme_rt_pipe, /* 209 */ - scheme_rt_beos_process, /* 210 */ - scheme_rt_system_child, /* 211 */ - scheme_rt_tcp, /* 212 */ - scheme_rt_write_data, /* 213 */ - scheme_rt_tcp_select_info, /* 214 */ - scheme_rt_param_data, /* 215 */ - scheme_rt_will, /* 216 */ - scheme_rt_linker_name, /* 217 */ - scheme_rt_param_map, /* 218 */ - scheme_rt_finalization, /* 219 */ - scheme_rt_finalizations, /* 220 */ - scheme_rt_cpp_object, /* 221 */ - scheme_rt_cpp_array_object, /* 222 */ - scheme_rt_stack_object, /* 223 */ - scheme_rt_preallocated_object, /* 224 */ - scheme_thread_hop_type, /* 225 */ - scheme_rt_srcloc, /* 226 */ - scheme_rt_evt, /* 227 */ - scheme_rt_syncing, /* 228 */ - scheme_rt_comp_prefix, /* 229 */ - scheme_rt_user_input, /* 230 */ - scheme_rt_user_output, /* 231 */ - scheme_rt_compact_port, /* 232 */ - scheme_rt_read_special_dw, /* 233 */ - scheme_rt_regwork, /* 234 */ - scheme_rt_rx_lazy_string, /* 235 */ - scheme_rt_buf_holder, /* 236 */ - scheme_rt_parameterization, /* 237 */ - scheme_rt_print_params, /* 238 */ - scheme_rt_read_params, /* 239 */ - scheme_rt_native_code, /* 240 */ - scheme_rt_native_code_plus_case, /* 241 */ - scheme_rt_jitter_data, /* 242 */ - scheme_rt_module_exports, /* 243 */ - scheme_rt_delay_load_info, /* 244 */ - scheme_rt_marshal_info, /* 245 */ - scheme_rt_unmarshal_info, /* 246 */ - scheme_rt_runstack, /* 247 */ - scheme_rt_sfs_info, /* 248 */ - scheme_rt_validate_clearing, /* 249 */ - scheme_rt_avl_node, /* 250 */ - scheme_rt_lightweight_cont, /* 251 */ - scheme_rt_export_info, /* 252 */ - scheme_rt_cont_jmp, /* 253 */ + scheme_rt_comp_env, /* 184 */ + scheme_rt_constant_binding, /* 185 */ + scheme_rt_resolve_info, /* 186 */ + scheme_rt_unresolve_info, /* 187 */ + scheme_rt_optimize_info, /* 188 */ + scheme_rt_compile_info, /* 189 */ + scheme_rt_cont_mark, /* 190 */ + scheme_rt_saved_stack, /* 191 */ + scheme_rt_reply_item, /* 192 */ + scheme_rt_closure_info, /* 193 */ + scheme_rt_overflow, /* 194 */ + scheme_rt_overflow_jmp, /* 195 */ + scheme_rt_meta_cont, /* 196 */ + scheme_rt_dyn_wind_cell, /* 197 */ + scheme_rt_dyn_wind_info, /* 198 */ + scheme_rt_dyn_wind, /* 199 */ + scheme_rt_dup_check, /* 200 */ + scheme_rt_thread_memory, /* 201 */ + scheme_rt_input_file, /* 202 */ + scheme_rt_input_fd, /* 203 */ + scheme_rt_oskit_console_input, /* 204 */ + scheme_rt_tested_input_file, /* 205 */ + scheme_rt_tested_output_file, /* 206 */ + scheme_rt_indexed_string, /* 207 */ + scheme_rt_output_file, /* 208 */ + scheme_rt_load_handler_data, /* 209 */ + scheme_rt_pipe, /* 210 */ + scheme_rt_beos_process, /* 211 */ + scheme_rt_system_child, /* 212 */ + scheme_rt_tcp, /* 213 */ + scheme_rt_write_data, /* 214 */ + scheme_rt_tcp_select_info, /* 215 */ + scheme_rt_param_data, /* 216 */ + scheme_rt_will, /* 217 */ + scheme_rt_linker_name, /* 218 */ + scheme_rt_param_map, /* 219 */ + scheme_rt_finalization, /* 220 */ + scheme_rt_finalizations, /* 221 */ + scheme_rt_cpp_object, /* 222 */ + scheme_rt_cpp_array_object, /* 223 */ + scheme_rt_stack_object, /* 224 */ + scheme_rt_preallocated_object, /* 225 */ + scheme_thread_hop_type, /* 226 */ + scheme_rt_srcloc, /* 227 */ + scheme_rt_evt, /* 228 */ + scheme_rt_syncing, /* 229 */ + scheme_rt_comp_prefix, /* 230 */ + scheme_rt_user_input, /* 231 */ + scheme_rt_user_output, /* 232 */ + scheme_rt_compact_port, /* 233 */ + scheme_rt_read_special_dw, /* 234 */ + scheme_rt_regwork, /* 235 */ + scheme_rt_rx_lazy_string, /* 236 */ + scheme_rt_buf_holder, /* 237 */ + scheme_rt_parameterization, /* 238 */ + scheme_rt_print_params, /* 239 */ + scheme_rt_read_params, /* 240 */ + scheme_rt_native_code, /* 241 */ + scheme_rt_native_code_plus_case, /* 242 */ + scheme_rt_jitter_data, /* 243 */ + scheme_rt_module_exports, /* 244 */ + scheme_rt_delay_load_info, /* 245 */ + scheme_rt_marshal_info, /* 246 */ + scheme_rt_unmarshal_info, /* 247 */ + scheme_rt_runstack, /* 248 */ + scheme_rt_sfs_info, /* 249 */ + scheme_rt_validate_clearing, /* 250 */ + scheme_rt_avl_node, /* 251 */ + scheme_rt_lightweight_cont, /* 252 */ + scheme_rt_export_info, /* 253 */ + scheme_rt_cont_jmp, /* 254 */ #endif _scheme_last_type_ diff --git a/src/racket/src/type.c b/src/racket/src/type.c index 0ed1de3248..b99e135fe4 100644 --- a/src/racket/src/type.c +++ b/src/racket/src/type.c @@ -594,7 +594,7 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_escaping_cont_type, escaping_cont_proc); GC_REG_TRAV(scheme_rt_cont_jmp, cont_jmp_proc); - GC_REG_TRAV(scheme_char_type, char_obj); + GC_REG_TRAV(scheme_char_type, small_atomic_obj); GC_REG_TRAV(scheme_integer_type, bad_trav); GC_REG_TRAV(scheme_bignum_type, bignum_obj); GC_REG_TRAV(scheme_rational_type, rational_obj); @@ -611,7 +611,7 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_place_dead_type, small_object); #endif GC_REG_TRAV(scheme_keyword_type, symbol_obj); - GC_REG_TRAV(scheme_null_type, char_obj); /* small */ + GC_REG_TRAV(scheme_null_type, small_atomic_obj); GC_REG_TRAV(scheme_pair_type, cons_cell); GC_REG_TRAV(scheme_mutable_pair_type, cons_cell); GC_REG_TRAV(scheme_raw_pair_type, cons_cell); @@ -624,10 +624,10 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_input_port_type, input_port); GC_REG_TRAV(scheme_output_port_type, output_port); - GC_REG_TRAV(scheme_eof_type, char_obj); /* small */ - GC_REG_TRAV(scheme_true_type, char_obj); /* small */ - GC_REG_TRAV(scheme_false_type, char_obj); /* small */ - GC_REG_TRAV(scheme_void_type, char_obj); /* small */ + GC_REG_TRAV(scheme_eof_type, small_atomic_obj); + GC_REG_TRAV(scheme_true_type, small_atomic_obj); + GC_REG_TRAV(scheme_false_type, small_atomic_obj); + GC_REG_TRAV(scheme_void_type, small_atomic_obj); GC_REG_TRAV(scheme_syntax_compiler_type, syntax_compiler); GC_REG_TRAV(scheme_macro_type, small_object); GC_REG_TRAV(scheme_box_type, small_object); @@ -654,7 +654,7 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_eval_waiting_type, bad_trav); GC_REG_TRAV(scheme_tail_call_waiting_type, bad_trav); - GC_REG_TRAV(scheme_undefined_type, char_obj); /* small */ + GC_REG_TRAV(scheme_undefined_type, small_atomic_obj); GC_REG_TRAV(scheme_placeholder_type, small_object); GC_REG_TRAV(scheme_table_placeholder_type, iptr_obj); @@ -673,9 +673,9 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_security_guard_type, guard_val); GC_REG_TRAV(scheme_nack_evt_type, twoptr_obj); - GC_REG_TRAV(scheme_always_evt_type, char_obj); - GC_REG_TRAV(scheme_never_evt_type, char_obj); - GC_REG_TRAV(scheme_thread_recv_evt_type, char_obj); + GC_REG_TRAV(scheme_always_evt_type, small_atomic_obj); + GC_REG_TRAV(scheme_never_evt_type, small_atomic_obj); + GC_REG_TRAV(scheme_thread_recv_evt_type, small_atomic_obj); GC_REG_TRAV(scheme_port_closed_evt_type, small_object); GC_REG_TRAV(scheme_inspector_type, mark_inspector); @@ -709,6 +709,8 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_rib_delimiter_type, small_object); GC_REG_TRAV(scheme_noninline_proc_type, small_object); GC_REG_TRAV(scheme_prune_context_type, small_object); + + GC_REG_TRAV(scheme_struct_proc_shape_type, small_atomic_obj); } END_XFORM_SKIP; diff --git a/src/racket/src/validate.c b/src/racket/src/validate.c index 820ab6da3c..19643e26d9 100644 --- a/src/racket/src/validate.c +++ b/src/racket/src/validate.c @@ -42,7 +42,8 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, Scheme_Object *app_rator, int proc_with_refs_ok, int result_ignored, struct Validate_Clearing *vc, int tailpos, int need_flonum, Scheme_Hash_Tree *procs, - int expected_results); + int expected_results, + Scheme_Hash_Table **_st_ht); static int validate_rator_wants_box(Scheme_Object *app_rator, int pos, int hope, Validate_TLS tls, @@ -132,6 +133,7 @@ void scheme_validate_code(Mz_CPort *port, Scheme_Object *code, struct Validate_Clearing *vc; Validate_TLS tls; mzshort *tl_state; + Scheme_Hash_Table *st_ht = NULL; depth += ((num_toplevels || num_stxes || num_lifts) ? 1 : 0); @@ -188,7 +190,7 @@ void scheme_validate_code(Mz_CPort *port, Scheme_Object *code, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, - vc, 1, 0, NULL, -1)) { + vc, 1, 0, NULL, -1, &st_ht)) { tl_timestamp++; if (0) { printf("increment to %d for %d %p\n", tl_timestamp, @@ -204,7 +206,7 @@ void scheme_validate_code(Mz_CPort *port, Scheme_Object *code, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, 0, NULL, 0, 0, - vc, 1, 0, NULL, -1); + vc, 1, 0, NULL, -1, NULL); } } @@ -242,7 +244,7 @@ static int validate_toplevel(Scheme_Object *expr, Mz_CPort *port, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, skip_refs_check ? 1 : 0, 0, - make_clearing_stack(), 0, 0, NULL, 1); + make_clearing_stack(), 0, 0, NULL, 1, NULL); } static int define_values_validate(Scheme_Object *data, Mz_CPort *port, @@ -253,9 +255,10 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port, mzshort *tl_state, mzshort tl_timestamp, int result_ignored, struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs) + Scheme_Hash_Tree *procs, + Scheme_Hash_Table **_st_ht) { - int i, size, flags, result; + int i, size, flags, result, is_struct, field_count, field_icount, uses_super; Scheme_Object *val, *only_var; val = SCHEME_VEC_ELS(data)[0]; @@ -357,14 +360,45 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port, only_var = NULL; } + if (scheme_is_simple_make_struct_type(val, size-1, 1, 1, NULL, + &field_count, &field_icount, + &uses_super, + NULL, (_st_ht ? *_st_ht : NULL), + NULL, 0, NULL, NULL, 5)) { + /* This set of bindings is constant across invocations, but + if `uses_super', we need to increment tl_timestamp for + subtype-defining `struct' sequences. */ + is_struct = 1; + } else { + is_struct = 0; + uses_super = 0; + field_count = 0; + field_icount = 0; + } + result = validate_expr(port, val, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, - tl_state, tl_timestamp, + tl_state, tl_timestamp + (uses_super ? 1 : 0), NULL, !!only_var, 0, vc, 0, 0, NULL, - size-1); - if (scheme_is_simple_make_struct_type(val, size-1, 1, 1)) + size-1, NULL); + + if (is_struct) { + if (_st_ht && (field_count == field_icount)) { + /* record `struct:' binding as constant across invocations, + so that it can be recognized for sub-struct declarations */ + if (!*_st_ht) { + Scheme_Hash_Table *ht; + ht = scheme_make_hash_table_eqv(); + *_st_ht = ht; + } + scheme_hash_set(*_st_ht, + scheme_make_integer(SCHEME_TOPLEVEL_POS(SCHEME_VEC_ELS(data)[1])), + scheme_make_integer(field_count)); + } + /* In any case, treat the bindings as constant */ result = 2; + } flags = SCHEME_TOPLEVEL_READY; if (result == 2) { @@ -373,7 +407,7 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port, that's good enough for ensuring safety. */ flags = SCHEME_TOPLEVEL_CONST; } - + for (i = 1; i < size; i++) { int ts = (tl_timestamp + (result ? 0 : 1)); if (tl_state) { @@ -422,7 +456,7 @@ static int set_validate(Scheme_Object *data, Mz_CPort *port, r1 = validate_expr(port, sb->val, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 0, 0, vc, 0, 0, procs, 1); + NULL, 0, 0, vc, 0, 0, procs, 1, NULL); r2 = validate_toplevel(sb->var, port, stack, tls, depth, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, @@ -472,12 +506,12 @@ static int apply_values_validate(Scheme_Object *data, Mz_CPort *port, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 0, 0, vc, 0, 0, procs, 1); + NULL, 0, 0, vc, 0, 0, procs, 1, NULL); r2 = validate_expr(port, e, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 0, 0, vc, 0, 0, procs, -1); + NULL, 0, 0, vc, 0, 0, procs, -1, NULL); return validate_join(r1, r2); } @@ -501,12 +535,12 @@ static void inline_variant_validate(Scheme_Object *data, Mz_CPort *port, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 0, 0, vc, 0, 0, procs, 1); + NULL, 0, 0, vc, 0, 0, procs, 1, NULL); validate_expr(port, f2, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 0, 0, vc, 0, 0, procs, 1); + NULL, 0, 0, vc, 0, 0, procs, 1, NULL); } static void case_lambda_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, @@ -533,7 +567,7 @@ static void case_lambda_validate(Scheme_Object *data, Mz_CPort *port, char *stac validate_expr(port, e, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 0, 0, vc, 0, 0, procs, 1); + NULL, 0, 0, vc, 0, 0, procs, 1, NULL); } } @@ -564,7 +598,7 @@ static int bangboxenv_validate(Scheme_Object *data, Mz_CPort *port, return validate_expr(port, SCHEME_PTR2_VAL(data), stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 0, result_ignored, vc, tailpos, 0, procs, expected_results); + NULL, 0, result_ignored, vc, tailpos, 0, procs, expected_results, NULL); } static int begin0_validate(Scheme_Object *data, Mz_CPort *port, @@ -591,7 +625,7 @@ static int begin0_validate(Scheme_Object *data, Mz_CPort *port, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, i > 0, vc, 0, 0, procs, - (i > 0) ? -1 : expected_results); + (i > 0) ? -1 : expected_results, NULL); result = validate_join_seq(r, result); } @@ -701,6 +735,7 @@ static Scheme_Object *validate_k(void) struct Validate_Clearing *vc = (struct Validate_Clearing *)p->ku.k.p4; void *tl_use_map = (((void **)p->ku.k.p5)[4]); mzshort *tl_state = (((void **)p->ku.k.p5)[5]); + Scheme_Hash_Table **_st_ht = (((void **)p->ku.k.p5)[6]); int r; p->ku.k.p1 = NULL; @@ -714,7 +749,8 @@ static Scheme_Object *validate_k(void) args[3], args[4], args[5], tl_use_map, tl_state, args[10], app_rator, args[6], args[7], vc, args[8], - args[9], procs, args[11]); + args[9], procs, args[11], + _st_ht); return scheme_make_integer(r); } @@ -903,7 +939,7 @@ void scheme_validate_closure(Mz_CPort *port, Scheme_Object *expr, validate_expr(port, data->code, new_stack, tls, sz, sz, base, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 0, 0, vc, 1, 0, procs, -1); + NULL, 0, 0, vc, 1, 0, procs, -1, NULL); } static Scheme_Hash_Tree *as_nonempty_procs(Scheme_Hash_Tree *procs) @@ -1142,7 +1178,8 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, int result_ignored, struct Validate_Clearing *vc, int tailpos, int need_flonum, Scheme_Hash_Tree *procs, - int expected_results) + int expected_results, + Scheme_Hash_Table **_st_ht) /* result is 1 if result is `expected_results' values with no exceptions and no use of any non-ready binding; it's 2 if the result is furthermore a "constant" (i.e., the same shape result for @@ -1158,7 +1195,13 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, Scheme_Object *r; void **pr; int *args; + Scheme_Hash_Table **_2st_ht = NULL; + if (_st_ht) { + _2st_ht = MALLOC_N(Scheme_Hash_Table*, 1); + *_2st_ht = *_st_ht; + } + args = MALLOC_N_ATOMIC(int, 11); p->ku.k.p1 = (void *)port; @@ -1179,18 +1222,23 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, args[10] = tl_timestamp; args[11] = expected_results; - pr = MALLOC_N(void*, 5); + pr = MALLOC_N(void*, 6); pr[0] = (void *)args; pr[1] = (void *)app_rator; pr[2] = (void *)tls; pr[3] = (void *)procs; pr[4] = tl_use_map; pr[5] = tl_state; + pr[6] = _2st_ht; p->ku.k.p5 = (void *)pr; r = scheme_handle_stack_overflow(validate_k); + if (_st_ht) { + *_st_ht = *_2st_ht; + } + return SCHEME_INT_VAL(r); } #endif @@ -1406,7 +1454,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, r = validate_expr(port, app->args[i], stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - i ? app->args[0] : NULL, i + 1, 0, vc, 0, 0, procs, 1); + i ? app->args[0] : NULL, i + 1, 0, vc, 0, 0, procs, 1, NULL); result = validate_join(result, r); } @@ -1414,10 +1462,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, check_self_call_valid(app->args[0], port, vc, delta, stack); if (result) { - if (scheme_is_simple_make_struct_type((Scheme_Object *)app, expected_results, 1, 1)) - r = 2; - else - r = scheme_is_functional_primitive(app->args[0], app->num_args, expected_results); + r = scheme_is_functional_primitive(app->args[0], app->num_args, expected_results); result = validate_join(result, r); } } @@ -1437,12 +1482,12 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, r = validate_expr(port, app->rator, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 1, 0, vc, 0, 0, procs, 1); + NULL, 1, 0, vc, 0, 0, procs, 1, NULL); result = validate_join(r, result); r = validate_expr(port, app->rand, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - app->rator, 2, 0, vc, 0, 0, procs, 1); + app->rator, 2, 0, vc, 0, 0, procs, 1, NULL); result = validate_join(r, result); if (tailpos) @@ -1470,17 +1515,17 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, r = validate_expr(port, app->rator, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 1, 0, vc, 0, 0, procs, 1); + NULL, 1, 0, vc, 0, 0, procs, 1, NULL); result = validate_join(r, result); r = validate_expr(port, app->rand1, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - app->rator, 2, 0, vc, 0, 0, procs, 1); + app->rator, 2, 0, vc, 0, 0, procs, 1, NULL); result = validate_join(r, result); r = validate_expr(port, app->rand2, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - app->rator, 3, 0, vc, 0, 0, procs, 1); + app->rator, 3, 0, vc, 0, 0, procs, 1, NULL); result = validate_join(r, result); if (tailpos) @@ -1507,7 +1552,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, r = validate_expr(port, seq->array[i], stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 0, 1, vc, 0, 0, procs, -1); + NULL, 0, 1, vc, 0, 0, procs, -1, NULL); result = validate_join_seq(result, r); } @@ -1526,7 +1571,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, r = validate_expr(port, b->test, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 0, 0, vc, 0, 0, procs, 1); + NULL, 0, 0, vc, 0, 0, procs, 1, NULL); result = validate_join(r, result); /* This is where letlimit is useful. It prevents let-assignment in the @@ -1539,7 +1584,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, result_ignored, vc, tailpos, 0, procs, - expected_results); + expected_results, NULL); result = validate_join_seq(result, r); /* since we're branchig, the result isn't constant: */ @@ -1583,12 +1628,12 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, r = validate_expr(port, wcm->key, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 0, 0, vc, 0, 0, procs, 1); + NULL, 0, 0, vc, 0, 0, procs, 1, NULL); result = validate_join_seq(result, r); r = validate_expr(port, wcm->val, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 0, 0, vc, 0, 0, procs, 1); + NULL, 0, 0, vc, 0, 0, procs, 1, NULL); result = validate_join_seq(result, r); expr = wcm->body; @@ -1633,7 +1678,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, r = validate_expr(port, lv->value, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 0, 0, vc, 0, 0, procs, lv->count); + NULL, 0, 0, vc, 0, 0, procs, lv->count, NULL); result = validate_join_seq(r, result); /* memset(stack, VALID_NOT, delta); <-- seems unnecessary (and slow) */ @@ -1740,7 +1785,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_FLONUM, procs, - 1); + 1, NULL); result = validate_join_seq(r, result); #if !CAN_RESET_STACK_SLOT @@ -1767,7 +1812,8 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, define_values_validate(expr, port, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - result_ignored, vc, tailpos, procs)); + result_ignored, vc, tailpos, procs, + _st_ht)); break; case scheme_define_syntaxes_type: no_flo(need_flonum, port); @@ -1879,7 +1925,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, validate_expr(port, seq->array[i], stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 0, 0, vc, 0, 0, procs, 1); + NULL, 0, 0, vc, 0, 0, procs, 1, NULL); } } else if (need_flonum) { if (!SCHEME_FLOATP(expr)) From b56574e4d56d4abc991dee201a93d92dfd613817 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Fri, 26 Oct 2012 14:24:10 -0400 Subject: [PATCH 043/221] scribble: add examples for most def* forms --- collects/scribblings/scribble/manual.scrbl | 148 +++++++++++++++++++-- 1 file changed, 136 insertions(+), 12 deletions(-) diff --git a/collects/scribblings/scribble/manual.scrbl b/collects/scribblings/scribble/manual.scrbl index 3c55a1d2b4..84065b0ef5 100644 --- a/collects/scribblings/scribble/manual.scrbl +++ b/collects/scribblings/scribble/manual.scrbl @@ -757,7 +757,28 @@ If @racket[#:id [src-id dest-id-expr]] is supplied, then @racket[dest-id-expr] produces the identifier to be documented in place of @racket[src-id]. This split between @racket[src-id] and @racket[dest-id-expr] roles is useful for functional abstraction of -@racket[defproc].} +@racket[defproc]. + +Examples: +@codeblock[#:keep-lang-line? #f]|{ +#lang scribble/manual +@defproc[(make-sandwich [ingredients (listof ingredient?)]) + sandwich?]{ + Returns a sandwich given the right ingredients. +} + +@defproc[#:kind "sandwich-maker" + (make-reuben [ingredient sauerkraut?] ... + [#:veggie? veggie? any/c #f]) + sandwich?]{ + Produces a reuben given some number of @racket[ingredient]s. + + If @racket[veggie?] is @racket[#f], produces a standard + reuben with corned beef. Otherwise, produces a vegetable + reuben. +} +}| +} @defform[(defproc* maybe-kind maybe-id ([prototype @@ -765,16 +786,29 @@ place of @racket[src-id]. This split between @racket[src-id] and pre-flow ...)]{ Like @racket[defproc], but for multiple cases with the same -@racket[id]. +@racket[id]. When an @racket[id] has multiple calling cases, they must be defined with a single @racket[defproc*], so that a single definition point exists for the @racket[id]. However, multiple distinct @racket[id]s can also be defined by a single @racket[defproc*], for the case that -it's best to document a related group of procedures at once.} +it's best to document a related group of procedures at once. + +Examples: +@codeblock[#:keep-lang-line? #f]|{ +#lang scribble/manual +@defproc[((make-pb&j) + (make-pb&j [jelly jelly?])) + sandwich?]{ + Returns a peanut butter and jelly sandwich. If @racket[jelly] + is provided, then it is used instead of the standard (grape) + jelly. +} +}| +} -@defform/subs[(defform maybe-kind maybe-id maybe-literals form-datum +@defform/subs[(defform maybe-kind maybe-id maybe-literals form-datum maybe-contracts pre-flow ...) ([maybe-kind code:blank @@ -831,14 +865,48 @@ auxiliary grammar specified using @racket[defform/subs]. The typesetting of @racket[form-datum], @racket[subform-datum], and @racket[contract-expr-datum] preserves the source layout, like -@racket[racketblock].} +@racket[racketblock]. -@defform[(defform* maybe-kind maybe-id maybe-literals [form-datum ...+] +Examples: +@codeblock[#:keep-lang-line? #f]|{ +#lang scribble/manual +@defform[(sandwich-promise sandwich-expr) + #:contracts ([sandwich-expr sandwich?])]{ + Returns a promise to construct a sandwich. When forced, the promise + will produce the result of @racket[sandwich-expr]. +} + +@defform[#:literals (sandwich mixins) + (sandwich-promise* [sandwich sandwich-expr] + [mixins ingredient-expr ...]) + #:contracts ([sandwich-expr sandwich?] + [ingreient-expr ingredient?])]{ + Returns a promise to construct a sandwich. When forced, the promise + will produce the result of @racket[sandwich-expr]. Each result of + the @racket[ingredient-expr]s will be mixed into the resulting + sandwich. +} +}| +} + +@defform[(defform* maybe-kind maybe-id maybe-literals [form-datum ...+] maybe-contracts pre-flow ...)]{ Like @racket[defform], but for multiple forms using the same -@racket[_id].} +@racket[_id]. + +Examples: +@codeblock[#:keep-lang-line? #f]|{ +#lang scribble/manual +@defform*[((call-with-current-sandwich expr) + (call-with-current-sandwich expr sandwich-handler-expr))]{ + Runs @racket[expr] and passes it the value of the current + sandwich. If @racket[sandwich-handler-expr] is provided, its result + is invoked when the current sandwich is eaten. +} +}| +} @defform[(defform/subs maybe-kind maybe-id maybe-literals form-datum ([nonterm-id clause-datum ...+] ...) @@ -849,7 +917,22 @@ Like @racket[defform], but including an auxiliary grammar of non-terminals shown with the @racket[_id] form. Each @racket[nonterm-id] is specified as being any of the corresponding @racket[clause-datum]s, where the formatting of each -@racket[clause-datum] is preserved.} +@racket[clause-datum] is preserved. + +Examples: +@codeblock[#:keep-lang-line? #f]|{ +#lang scribble/manual +@defform/subs[(sandwich-factory maybe-name factory-component ...) + [(maybe-name (code:line) + name) + (factory-component (code:line #:protein protein-expr) + [vegetable vegetable-expr])]]{ + Constructs a sandwich factory. If @racket[maybe-name] is provided, + the factory will be named. Each of the @racket[factory-component] + clauses adds an additional ingredient to the sandwich pipeline. +} +}| +} @defform[(defform*/subs maybe-kind maybe-id maybe-literals [form-datum ...+] @@ -935,7 +1018,17 @@ Like @racket[specspecsubform], but with a grammar like Like @racket[defproc], but for a parameter. The @racket[contract-expr-datum] serves as both the result contract on the parameter and the contract on values supplied for the parameter. The -@racket[arg-id] refers to the parameter argument in the latter case.} +@racket[arg-id] refers to the parameter argument in the latter case. + +Examples: +@codeblock[#:keep-lang-line? #f]|{ +#lang scribble/manual +@defparam[current-sandwich sandwich sandwich?]{ + A parameter that defines the current sandwich for operations that + involve eating a sandwich. +} +}| +} @defform[(defboolparam id arg-id pre-flow ...)]{ @@ -950,7 +1043,16 @@ Like @racket[defproc], but for a non-procedure binding. If @racket[#:kind kind-string-expr] is supplied as @racket[maybe-kind], it is used in the same way as for -@racket[defproc], but the default kind is @racket["value"].} +@racket[defproc], but the default kind is @racket["value"]. + +Examples: +@codeblock[#:keep-lang-line? #f]|{ +#lang scribble/manual +@defthing[moldy-sandwich sandwich?] + Don't eat this. Provided for backwards compatibility. +} +}| +} @deftogether[( @@ -974,7 +1076,18 @@ If @racket[#:kind kind-string-expr] is supplied as Similar to @racket[defform] or @racket[defproc], but for a structure definition. The @racket[defstruct*] form corresponds to @racket[struct], -while @racket[defstruct] corresponds to @racket[define-struct].} +while @racket[defstruct] corresponds to @racket[define-struct]. + +Examples: +@codeblock[#:keep-lang-line? #f]|{ +#lang scribble/manual +@defstruct[sandwich ([protein ingredient?] [sauce ingredient?])]{ + A strucure type for sandwiches. Sandwiches are a pan-human foodstuff + composed of a partially-enclosing bread material and various + ingredients. +} +}| +} @defform[(deftogether [def-expr ...] pre-flow ...)]{ @@ -984,7 +1097,18 @@ single definition box. Each @racket[def-expr] should produce a definition point via @racket[defproc], @racket[defform], etc. Each @racket[def-expr] should have an empty @racket[pre-flow]; the @tech{decode}d @racket[pre-flow] sequence for the @racket[deftogether] -form documents the collected bindings.} +form documents the collected bindings. + +Examples: +@codeblock[#:keep-lang-line? #f]|{ +#lang scribble/manual +@deftogether[(@defthing[test-sandwich-1 sandwich?] + @defthing[test-sandwich-2 sandwich?])]{ + Two high-quality sandwiches. These are provided for convenience + in writing test cases +} +}| +} @defform/subs[(racketgrammar maybe-literals id clause-datum ...+) From 24592a08007426b7d5810e36311b93210e00921d Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 27 Oct 2012 09:57:40 -0500 Subject: [PATCH 044/221] adjust drracket gui test suite infrastructure so that it waits for pending events to finish when looking for new frames --- .../drracket/private/drracket-test-util.rkt | 65 ++++++++++--------- 1 file changed, 36 insertions(+), 29 deletions(-) diff --git a/collects/tests/drracket/private/drracket-test-util.rkt b/collects/tests/drracket/private/drracket-test-util.rkt index e1f69725ef..b5aa08cc36 100644 --- a/collects/tests/drracket/private/drracket-test-util.rkt +++ b/collects/tests/drracket/private/drracket-test-util.rkt @@ -100,42 +100,48 @@ (method-in-interface? 'get-execute-button (object-interface frame))) (define (wait-for-drracket-frame [print-message? #f]) - (let ([wait-for-drracket-frame-pred - (lambda () - (let ([active (fw:test:get-active-top-level-window)]) - (if (and active - (drracket-frame? active)) - active - #f)))]) + (define (wait-for-drracket-frame-pred) + (define active (fw:test:get-active-top-level-window)) + (if (and active + (drracket-frame? active)) + active + #f)) + (define drr-fr (or (wait-for-drracket-frame-pred) (begin (when print-message? (printf "Select DrRacket frame\n")) - (poll-until wait-for-drracket-frame-pred))))) + (poll-until wait-for-drracket-frame-pred)))) + (when drr-fr + (wait-for-events-in-frame-eventspace drr-fr)) + drr-fr) ;; wait-for-new-frame : frame [(listof eventspace) = null] -> frame ;; returns the newly opened frame, waiting until old-frame ;; is no longer frontmost. Optionally checks other eventspaces ;; waits until the new frame has a focus'd window, too. - (define wait-for-new-frame - (case-lambda - [(old-frame) (wait-for-new-frame old-frame null)] - [(old-frame extra-eventspaces) - (wait-for-new-frame old-frame extra-eventspaces 10)] - [(old-frame extra-eventspaces timeout) - (let ([wait-for-new-frame-pred - (lambda () - (let ([active (or (fw:test:get-active-top-level-window) - (ormap - (lambda (eventspace) - (parameterize ([current-eventspace eventspace]) - (fw:test:get-active-top-level-window))) - extra-eventspaces))]) - (if (and active - (not (eq? active old-frame))) - active - #f)))]) - (poll-until wait-for-new-frame-pred timeout))])) + (define (wait-for-new-frame old-frame [extra-eventspaces '()] [timeout 10]) + (define (wait-for-new-frame-pred) + (define active (or (fw:test:get-active-top-level-window) + (for/or ([eventspace (in-list extra-eventspaces)]) + (parameterize ([current-eventspace eventspace]) + (fw:test:get-active-top-level-window))))) + (if (and active + (not (eq? active old-frame))) + active + #f)) + (define fr (poll-until wait-for-new-frame-pred timeout)) + (when fr (wait-for-events-in-frame-eventspace fr)) + (sleep 1) + fr) + + (define (wait-for-events-in-frame-eventspace fr) + (define sema (make-semaphore 0)) + (parameterize ([current-eventspace (send fr get-eventspace)]) + (queue-callback + (λ () (semaphore-post sema)) + #f)) + (semaphore-wait sema)) ;; wait-for-computation : frame -> void ;; waits until the drracket frame finishes some computation. @@ -377,8 +383,9 @@ child))) (send list-item get-items))]) (when (null? which) - (error 'set-language-level! "couldn't find language: ~e, no match at ~e" - in-language-spec name)) + (error 'set-language-level! "couldn't find language: ~e, no match at ~e, poss: ~s" + in-language-spec name (map (λ (child) (send (send child get-editor) get-text)) + (send list-item get-items)))) (unless (= 1 (length which)) (error 'set-language-level! "couldn't find language: ~e, double match ~e" in-language-spec name)) From c7d3de435f8c817bd7ccbe9c89678af21ec2d253 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 27 Oct 2012 09:04:28 -0600 Subject: [PATCH 045/221] scribble Latex/PDF: use the `tocstyle' package Fixes the spacing of section numbers for a section like N.M where both N and M have two digits. --- collects/scribble/scribble.tex | 2 ++ 1 file changed, 2 insertions(+) diff --git a/collects/scribble/scribble.tex b/collects/scribble/scribble.tex index 773b745a19..179f099db5 100644 --- a/collects/scribble/scribble.tex +++ b/collects/scribble/scribble.tex @@ -11,6 +11,8 @@ \usepackage[htt]{hyphenat} \usepackage[usenames,dvipsnames]{color} \hypersetup{bookmarks=true,bookmarksopen=true,bookmarksnumbered=true} +\usepackage{tocstyle} +\usetocstyle{standard} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Configuration that is especially meant to be overridden: From 847360aa602306071d44488099896f51cb5441e2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 27 Oct 2012 09:23:10 -0600 Subject: [PATCH 046/221] avoid compiler warning --- src/racket/src/jitcommon.c | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/racket/src/jitcommon.c b/src/racket/src/jitcommon.c index da8c7b9731..f3af854d10 100644 --- a/src/racket/src/jitcommon.c +++ b/src/racket/src/jitcommon.c @@ -1566,12 +1566,15 @@ int scheme_generate_struct_op(mz_jit_state *jitter, int kind, int for_branch, # endif #endif } - if (pop_and_jump) + if (pop_and_jump) { mz_epilog(JIT_V1); - else if (!for_branch) { + refdone = NULL; + } else if (!for_branch) { __START_INNER_TINY__(1); refdone = jit_jmpi(jit_forward()); __END_INNER_TINY__(1); + } else { + refdone = NULL; } /* False branch: */ From 616d49124cc248eb5ec48412d8d47d273b133552 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 27 Oct 2012 09:23:23 -0600 Subject: [PATCH 047/221] fix testing prop --- collects/meta/props | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/meta/props b/collects/meta/props index f002d64de9..83d8a0eb62 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1184,6 +1184,7 @@ path/s is either such a string or a list of them. "collects/tests/racket/benchmarks/rx/auto.rkt" drdr:command-line (racket * "racket" "simple") drdr:timeout 600 "collects/tests/racket/benchmarks/shootout/ackermann.rkt" drdr:command-line (racket * "10") "collects/tests/racket/benchmarks/shootout/auto.rkt" drdr:command-line (racket * "hello") +"collects/tests/racket/benchmarks/shootout/binarytrees-normal.rkt" drdr:command-line (racket * "10") "collects/tests/racket/benchmarks/shootout/binarytrees-places.rkt" drdr:command-line (racket * "10") "collects/tests/racket/benchmarks/shootout/binarytrees.rkt" drdr:command-line (racket * "10") "collects/tests/racket/benchmarks/shootout/chameneos.rkt" drdr:command-line (racket * "10") From 0d30c43a68c0a4291c2b7194824cd44fc7ff925b Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Thu, 18 Oct 2012 23:29:58 -0400 Subject: [PATCH 048/221] Add call/cc contracts to prompt-tag/c --- collects/racket/contract/private/misc.rkt | 74 +++++++++++++------ .../scribblings/reference/contracts.scrbl | 11 ++- collects/tests/racket/contract-test.rktl | 52 +++++++++++++ 3 files changed, 112 insertions(+), 25 deletions(-) diff --git a/collects/racket/contract/private/misc.rkt b/collects/racket/contract/private/misc.rkt index 294fe59a35..64c3d93692 100644 --- a/collects/racket/contract/private/misc.rkt +++ b/collects/racket/contract/private/misc.rkt @@ -957,34 +957,56 @@ (define/final-prop none/c (make-none/c 'none/c)) ;; prompt-tag/c -(define/subexpression-pos-prop (prompt-tag/c . ctc-args) - (define ctcs - (map (λ (ctc-arg) - (coerce-contract 'prompt-tag/c ctc-arg)) - ctc-args)) - (cond [(andmap chaperone-contract? ctcs) - (chaperone-prompt-tag/c ctcs)] +(define-syntax prompt-tag/c + (syntax-rules (values) + [(_ ?ctc ... #:call/cc (values ?call/cc ...)) + (-prompt-tag/c (list ?ctc ...) (list ?call/cc ...))] + [(_ ?ctc ... #:call/cc ?call/cc) + (-prompt-tag/c (list ?ctc ...) (list ?call/cc))] + [(_ ?ctc ...) (-prompt-tag/c (list ?ctc ...) (list))])) + +;; procedural part of the contract +;; takes two lists of contracts (abort & call/cc contracts) +(define/subexpression-pos-prop (-prompt-tag/c ctc-args call/ccs) + (define ctcs (coerce-contracts 'prompt-tag/c ctc-args)) + (define call/cc-ctcs (coerce-contracts 'prompt-tag/c call/ccs)) + (cond [(and (andmap chaperone-contract? ctcs) + (andmap chaperone-contract? call/cc-ctcs)) + (chaperone-prompt-tag/c ctcs call/cc-ctcs)] [else - (impersonator-prompt-tag/c ctcs)])) + (impersonator-prompt-tag/c ctcs call/cc-ctcs)])) (define (prompt-tag/c-name ctc) (apply build-compound-type-name - (cons 'prompt-tag/c (base-prompt-tag/c-ctcs ctc)))) + (append (list 'prompt-tag/c) (base-prompt-tag/c-ctcs ctc) + (list '#:call/cc) (base-prompt-tag/c-call/ccs ctc)))) -(define ((prompt-tag/c-proj proxy) ctc) +;; build a projection for prompt tags +(define ((prompt-tag/c-proj chaperone?) ctc) + (define proxy (if chaperone? chaperone-prompt-tag impersonate-prompt-tag)) + (define proc-proxy (if chaperone? chaperone-procedure impersonate-procedure)) (define ho-projs (map contract-projection (base-prompt-tag/c-ctcs ctc))) + (define call/cc-projs + (map contract-projection (base-prompt-tag/c-call/ccs ctc))) (λ (blame) - (define proj1 + (define (make-proj projs swap?) (λ vs - (define vs2 (for/list ([proj ho-projs] [v vs]) - ((proj blame) v))) - (apply values vs2))) - (define proj2 - (λ vs - (define vs2 (for/list ([proj ho-projs] [v vs]) - ((proj (blame-swap blame)) v))) - (apply values vs2))) + (define vs2 (for/list ([proj projs] [v vs]) + ((proj (if swap? (blame-swap blame) blame)) v))) + (apply values vs2))) + ;; prompt/abort projections + (define proj1 (make-proj ho-projs #f)) + (define proj2 (make-proj ho-projs #t)) + ;; call/cc projections + (define call/cc-guard (make-proj call/cc-projs #f)) + (define call/cc-proxy + (λ (f) + (proc-proxy + f + (λ args + (apply values (make-proj call/cc-projs #t) args))))) + ;; now do the actual wrapping (λ (val) (unless (contract-first-order-passes? ctc val) (raise-blame-error @@ -992,7 +1014,7 @@ '(expected: "~s" given: "~e") (contract-name ctc) val)) - (proxy val proj1 proj2)))) + (proxy val proj1 proj2 call/cc-guard call/cc-proxy)))) (define ((prompt-tag/c-first-order ctc) v) (continuation-prompt-tag? v)) @@ -1001,14 +1023,18 @@ (and (base-prompt-tag/c? that) (andmap (λ (this that) (contract-stronger? this that)) (base-prompt-tag/c-ctcs this) - (base-prompt-tag/c-ctcs that)))) + (base-prompt-tag/c-ctcs that)) + (andmap (λ (this that) (contract-stronger? this that)) + (base-prompt-tag/c-call/ccs this) + (base-prompt-tag/c-call/ccs that)))) -(define-struct base-prompt-tag/c (ctcs)) +;; (listof contract) (listof contract) +(define-struct base-prompt-tag/c (ctcs call/ccs)) (define-struct (chaperone-prompt-tag/c base-prompt-tag/c) () #:property prop:chaperone-contract (build-chaperone-contract-property - #:projection (prompt-tag/c-proj chaperone-prompt-tag) + #:projection (prompt-tag/c-proj #t) #:first-order prompt-tag/c-first-order #:stronger prompt-tag/c-stronger? #:name prompt-tag/c-name)) @@ -1016,7 +1042,7 @@ (define-struct (impersonator-prompt-tag/c base-prompt-tag/c) () #:property prop:contract (build-contract-property - #:projection (prompt-tag/c-proj impersonate-prompt-tag) + #:projection (prompt-tag/c-proj #f) #:first-order prompt-tag/c-first-order #:stronger prompt-tag/c-stronger? #:name prompt-tag/c-name)) diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 87fb37d644..fa453dc8df 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -520,7 +520,12 @@ to the input. The result will be a copy for immutable hash tables, and either a } -@defproc[(prompt-tag/c [contract contract?] ...) contract?]{ +@defform/subs[#:literals (values) + (prompt-tag/c contract ... maybe-call/cc) + ([maybe-call/cc (code:line) + (code:line #:call/cc contract) + (code:line #:call/cc (values contract ...))]) + #:contracts ([contract contract?])]{ Takes any number of contracts and returns a contract that recognizes continuation prompt tags and will check any aborts or prompt handlers that use the contracted prompt tag. @@ -533,6 +538,10 @@ If all of the @racket[contract]s are chaperone contracts, the resulting contract will also be a @tech{chaperone} contract. Otherwise, the contract is an @tech{impersonator} contract. +If @racket[maybe-call/cc] is provided, then the provided contracts +are used to check the return values from a continuation captured with +@racket[call-with-current-continuation]. + @examples[#:eval (contract-eval) (define/contract tag (prompt-tag/c (-> number? string?)) diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 77a2317ae8..dd93b870c4 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -4166,6 +4166,58 @@ pt (λ (x y) (values x y))))) + (test/spec-passed + 'prompt-tag/c-call/cc-1 + '(let* ([pt (contract (prompt-tag/c string? + #:call/cc string?) + (make-continuation-prompt-tag) + 'pos + 'neg)] + [abort-k (call-with-continuation-prompt + (λ () (call/cc (λ (k) k) pt)) + pt)]) + (call-with-continuation-prompt + (λ () (abort-k "ok")) + pt + (λ (s) (string-append s "post"))))) + + (test/spec-passed + 'prompt-tag/c-call/cc-2 + '(let* ([pt (contract (prompt-tag/c string? + #:call/cc (values string? integer?)) + (make-continuation-prompt-tag) + 'pos + 'neg)] + [abort-k (call-with-continuation-prompt + (λ () (call/cc (λ (k) k) pt)) + pt)]) + (call-with-continuation-prompt + (λ () (abort-k "ok" 5)) + pt + (λ (s n) (string-append s "post"))))) + + (test/neg-blame + 'prompt-tag/c-call/cc-2 + '(letrec ([pt (make-continuation-prompt-tag)] + [do-test (λ () + (+ 1 + (call-with-continuation-prompt + (lambda () + (+ 1 (abort-k 1))) + pt)))] + [cpt (contract (prompt-tag/c #:call/cc number?) + pt + 'pos + 'neg)] + [abort-k (call-with-continuation-prompt + (λ () + (let ([v (call/cc (lambda (k) k) cpt)]) + (if (procedure? v) + v + (format "~a" v)))) + pt)]) + (do-test))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; continuation-mark-key/c From 789ab0d9f00734c1c866cf4ace093f758bee0773 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 27 Oct 2012 13:04:06 -0500 Subject: [PATCH 049/221] add missing docs for color:misspelled-text-color-style-name --- collects/framework/main.rkt | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/collects/framework/main.rkt b/collects/framework/main.rkt index c55824aebd..c383944b42 100644 --- a/collects/framework/main.rkt +++ b/collects/framework/main.rkt @@ -72,6 +72,12 @@ in a GUI, and the color to use. The colors are used to show the nesting structure in the parens.}) + (thing-doc + color:misspelled-text-color-style-name + string? + @{The name of the style used to color misspelled words. See also + @method[color:text<%> get-spell-check-strings].}) + (proc-doc/names text:range? (-> any/c boolean?) (arg) @{Determines if @racket[arg] is an instance of the @tt{range} struct.}) From 117fde68571b9a355d18c24456ee83f14edba3d9 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 27 Oct 2012 16:45:44 -0500 Subject: [PATCH 050/221] adjust the online check syntax frame/tab leak test case so that it waits until online check syntax actually finishes (otherwise, there actually is a leak; the link is broken when the message comes back from the other place) --- collects/drracket/private/module-language.rkt | 1 + .../drracket/no-write-and-frame-leak.rkt | 21 +++++++++++++------ 2 files changed, 16 insertions(+), 6 deletions(-) diff --git a/collects/drracket/private/module-language.rkt b/collects/drracket/private/module-language.rkt index b44142e5c0..b1d7b94128 100644 --- a/collects/drracket/private/module-language.rkt +++ b/collects/drracket/private/module-language.rkt @@ -937,6 +937,7 @@ ;; colors : (or/c #f (listof string?) 'parens) (define colors #f) (define tooltip-labels #f) + (define/public (get-online-expansion-colors) colors) (super-new) diff --git a/collects/tests/drracket/no-write-and-frame-leak.rkt b/collects/tests/drracket/no-write-and-frame-leak.rkt index ce8a622bec..0ab24883f7 100644 --- a/collects/tests/drracket/no-write-and-frame-leak.rkt +++ b/collects/tests/drracket/no-write-and-frame-leak.rkt @@ -16,6 +16,7 @@ This test checks: |# (require "private/drracket-test-util.rkt" + drracket/private/local-member-names racket/gui/base framework) @@ -35,13 +36,20 @@ This test checks: (λ () (check-menus (wait-for-drracket-frame)) - (try-to-find-leak "online compilation disabled:") + (try-to-find-leak "online compilation disabled:" void) (preferences:set 'drracket:online-compilation-default-on #t) - (try-to-find-leak "online compilation enabled:"))))) + (try-to-find-leak "online compilation enabled:" wait-for-online-compilation-to-finish))))) -(define (try-to-find-leak online-compilation-string) +(define (wait-for-online-compilation-to-finish frame) + (let loop ([i 0]) + (define current-colors (send frame get-online-expansion-colors)) + (unless (equal? current-colors '("forestgreen")) + (sleep 1) + (loop (+ i 1))))) + +(define (try-to-find-leak online-compilation-string extra-waiting) (define drs-frame1 (wait-for-drracket-frame)) (sync (system-idle-evt)) @@ -63,8 +71,9 @@ This test checks: (queue-callback/res (λ () (send (send (send (weak-box-value drs-frame2b) get-current-tab) get-defs) load-file - (collection-file-path "unit.rkt" "drracket" "private")))) + (collection-file-path "rep.rkt" "drracket" "private")))) (sleep 2) + (extra-waiting (weak-box-value drs-frame2b)) (sync (system-idle-evt)) (test:menu-select "File" (if (eq? (system-type) 'unix) "Close" "Close Window")) @@ -74,9 +83,9 @@ This test checks: (cond [(zero? n) (when (weak-box-value drs-tabb) - (eprintf "~a frame leak!\n" online-compilation-string)) - (when (weak-box-value drs-frame2b) (eprintf "~a tab leak!\n" online-compilation-string)) + (when (weak-box-value drs-frame2b) + (eprintf "~a frame leak!\n" online-compilation-string)) (when (weak-box-value tab-nsb) (eprintf "~a tab namespace leak!\n" online-compilation-string)) (when (weak-box-value frame2-nsb) From 54301ad5ede34fc5000e1a0effa342036b9c0ba9 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 27 Oct 2012 18:36:55 -0500 Subject: [PATCH 051/221] fix apparent type error in the definition of in-plt? --- collects/scribble/html-render.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribble/html-render.rkt b/collects/scribble/html-render.rkt index cf33a00481..e8f8ad4d4b 100644 --- a/collects/scribble/html-render.rkt +++ b/collects/scribble/html-render.rkt @@ -1597,7 +1597,7 @@ (list name))))))) (define in-plt? - (let ([roots (map explode (list (find-doc-dir) (find-collects-dir)))]) + (let ([roots (map explode (filter values (list (find-doc-dir) (find-collects-dir))))]) (lambda (path) (ormap (lambda (root) (let loop ([path path] [root root]) From 7573fd7ee0f61b45dcff96d85e0cc6aab1982e6f Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 27 Oct 2012 17:28:56 -0700 Subject: [PATCH 052/221] Formatting. --- collects/typed-racket/utils/any-wrap.rkt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/typed-racket/utils/any-wrap.rkt b/collects/typed-racket/utils/any-wrap.rkt index fcac9b5334..4cecd411b5 100644 --- a/collects/typed-racket/utils/any-wrap.rkt +++ b/collects/typed-racket/utils/any-wrap.rkt @@ -6,7 +6,9 @@ (define (traverse b) (define (fail v) - (raise-blame-error (blame-swap b) v "Attempted to use a higher-order value passed as `Any` in untyped code")) + (raise-blame-error + (blame-swap b) v + "Attempted to use a higher-order value passed as `Any` in untyped code")) (define (t v) (define (wrap-struct s) From 4124c9a41b26092aa0dd7a33916fd8e080aa626f Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 27 Oct 2012 17:44:12 -0700 Subject: [PATCH 053/221] Add more specific class types instead of `Any`. Fixes Insert Large Letters dialog. Merge to 5.3.1. --- .../drracket/private/insert-large-letters.rkt | 10 +++--- collects/typed/framework/framework.rkt | 17 +--------- collects/typed/mred/mred.rkt | 34 ++++++++++++++----- 3 files changed, 32 insertions(+), 29 deletions(-) diff --git a/collects/drracket/private/insert-large-letters.rkt b/collects/drracket/private/insert-large-letters.rkt index 7bdbc81a1d..8bcde0a4ee 100644 --- a/collects/drracket/private/insert-large-letters.rkt +++ b/collects/drracket/private/insert-large-letters.rkt @@ -7,7 +7,7 @@ (define-type-alias Bitmap-Message% (Class () - ([parent Any]) + ([parent (Instance Horizontal-Panel%)]) ([set-bm ((Instance Bitmap%) -> Void)]))) @@ -16,7 +16,7 @@ (provide insert-large-letters) -(: insert-large-letters (String Char (Instance Racket:Text%) Any -> Void)) +(: insert-large-letters (String Char (Instance Text:Basic%) Any -> Void)) (define (insert-large-letters comment-prefix comment-character edit parent) (let ([str (make-large-letters-dialog comment-prefix comment-character #f)]) (when (and str @@ -90,7 +90,7 @@ (: pane2 (Instance Horizontal-Pane%)) (define pane2 (new horizontal-pane% (parent info-bar))) - (: txt (Instance Racket:Text%)) + (: txt (Instance Text:Basic%)) (define txt (new racket:text%)) (: ec (Instance Editor-Canvas%)) (define ec (new editor-canvas% [parent dlg] [editor txt])) @@ -145,7 +145,7 @@ (format " (~a)" (floor (inexact->exact w)))))) -(: get-max-line-width ((Instance Racket:Text%) -> Real)) +(: get-max-line-width ((Instance Text:Basic%) -> Real)) (define (get-max-line-width txt) (let loop ([i (+ (send txt last-paragraph) 1)] [#{m : Integer} 0]) @@ -156,7 +156,7 @@ (send txt paragraph-start-position (- i 1)))))]))) -(: render-large-letters (String Char (Instance Font%) String (Instance Racket:Text%) -> (Instance Bitmap%))) +(: render-large-letters (String Char (Instance Font%) String (Instance Text:Basic%) -> (Instance Bitmap%))) (define (render-large-letters comment-prefix comment-character the-font str edit) (define bdc (make-object bitmap-dc% (make-object bitmap% 1 1 #t))) (define-values (tw raw-th td ta) (send bdc get-text-extent str the-font)) diff --git a/collects/typed/framework/framework.rkt b/collects/typed/framework/framework.rkt index d03ebffe95..8501d9b091 100644 --- a/collects/typed/framework/framework.rkt +++ b/collects/typed/framework/framework.rkt @@ -9,28 +9,13 @@ () ([get-font (-> (Instance Font%))]))))]))) -(dt Racket:Text% (Class () - () - ([begin-edit-sequence (-> Void)] - [end-edit-sequence (-> Void)] - [lock (Boolean -> Void)] - [last-position (-> Number)] - [last-paragraph (-> Exact-Nonnegative-Integer)] - [delete (Number Number -> Void)] - [auto-wrap (Any -> Void)] - [paragraph-end-position (Number -> Natural)] - [paragraph-start-position (Number -> Natural)] - [get-start-position (-> Number)] - [get-end-position (-> Number)] - [insert (String Number Number -> Void)]))) - (require/typed/provide framework/framework [preferences:set-default (Symbol Sexp (Any -> Boolean) -> Void)] [preferences:set (Symbol Sexp -> Void)] [editor:get-standard-style-list (-> (Instance Style-List%))] - [racket:text% Racket:Text%] + [racket:text% Text:Basic%] [gui-utils:ok/cancel-buttons ((Instance Horizontal-Panel%) ((Instance Button%) (Instance Event%) -> Void) diff --git a/collects/typed/mred/mred.rkt b/collects/typed/mred/mred.rkt index 9b1ca81a75..2fa0519ea9 100644 --- a/collects/typed/mred/mred.rkt +++ b/collects/typed/mred/mred.rkt @@ -20,28 +20,30 @@ ([parent Any] [width Integer] [label String]) ([show (Any -> Void)]))) (dt Text-Field% (Class () - ([parent Any] [callback Any] [label String]) - ([get-value (-> String)] - [focus (-> Void)]))) + ([parent (Instance Dialog%)] + [callback (Any Any -> Any)] + [label String]) + ([get-value (-> String)] + [focus (-> Void)]))) (dt Horizontal-Panel% (Class () - ([parent Any] + ([parent (Instance Dialog%)] [stretchable-height Any #t] [alignment (List Symbol Symbol) #t]) ())) (dt Choice% (Class () - ([parent Any] [label String] [choices (Listof Any)] [callback Any]) + ([parent (Instance Horizontal-Panel%)] [label String] [choices (Listof Any)] [callback (Any Any -> Any)]) ([get-selection (-> (Option Natural))] [set-selection (Integer -> Any)] [get-string-selection (-> (Option String))] [set-string-selection (String -> Void)]))) (dt Message% (Class () - ([parent Any] [label String]) + ([parent (Instance Horizontal-Panel%)] [label String]) ([set-label ((U String (Instance Bitmap%)) -> Void)]))) (dt Horizontal-Pane% (Class () - ([parent Any]) + ([parent (Instance Horizontal-Panel%)]) ())) (dt Editor-Canvas% (Class () - ([parent Any] [editor Any]) + ([parent (Instance Dialog%)] [editor (Instance Text:Basic%)]) ([set-line-count ((U #f Integer) -> Void)]))) (dt Bitmap-DC% (Class ((Instance Bitmap%)) () @@ -55,6 +57,22 @@ (dt Snip% (Class () () ([get-count (-> Integer)]))) +(dt Text:Basic% (Class () + () + ([begin-edit-sequence (-> Void)] + [end-edit-sequence (-> Void)] + [lock (Boolean -> Void)] + [last-position (-> Number)] + [last-paragraph (-> Exact-Nonnegative-Integer)] + [delete (Number Number -> Void)] + [auto-wrap (Any -> Void)] + [paragraph-end-position (Number -> Integer)] + [paragraph-start-position (Number -> Integer)] + [get-start-position (-> Integer)] + [get-end-position (-> Integer)] + [get-text (Integer (U Integer 'eof) -> String)] + [insert (String Number Number -> Void)]))) + (dt Text% (Class () () ([begin-edit-sequence (-> Void)] From 19f88c0f80a092b16d5006e13bcf96dd091f71f4 Mon Sep 17 00:00:00 2001 From: Stephen Chang Date: Sat, 27 Oct 2012 21:09:02 -0400 Subject: [PATCH 054/221] add heap sequencing fns to data/heap --- collects/data/heap.rkt | 20 +++++++++++------- collects/data/scribblings/heap.scrbl | 31 ++++++++++++++++++++++++++++ collects/tests/data/heap.rkt | 18 ++++++++++++++++ 3 files changed, 61 insertions(+), 8 deletions(-) diff --git a/collects/data/heap.rkt b/collects/data/heap.rkt index 49dcfbc965..7cf3d81254 100644 --- a/collects/data/heap.rkt +++ b/collects/data/heap.rkt @@ -160,13 +160,14 @@ (in-heap/consume! (heap-copy h))) (define (in-heap/consume! h) - (lambda () - (values (lambda () (heap-min h)) - (lambda () (heap-remove-min! h) #t) - #t - (lambda (_) (> (heap-count h) 0)) - (lambda _ #t) - (lambda _ #t)))) + (make-do-sequence + (lambda () + (values (lambda (_) (heap-min h)) + (lambda (_) (heap-remove-min! h) #t) + #t + (lambda (_) (> (heap-count h) 0)) + (lambda _ #t) + (lambda _ #t))))) ;; -------- @@ -204,4 +205,7 @@ [heap->vector (-> heap? vector?)] [heap-copy (-> heap? heap?)] - [heap-sort! (-> procedure? vector? void?)]) + [heap-sort! (-> procedure? vector? void?)] + + [in-heap (-> heap? sequence?)] + [in-heap/consume! (-> heap? sequence?)]) diff --git a/collects/data/scribblings/heap.scrbl b/collects/data/scribblings/heap.scrbl index 1bcffc8480..d48858cc08 100644 --- a/collects/data/scribblings/heap.scrbl +++ b/collects/data/scribblings/heap.scrbl @@ -78,3 +78,34 @@ Makes a copy of heap @racket[h]. Sorts vector @racket[v] using the comparison function @racket[<=?]. } + + + +@defproc[(in-heap/consume! [heap heap?]) sequence?]{ +Returns a sequence equivalent to @racket[heap], maintaining the heap's ordering. +The heap is consumed in the process. Equivalent to repeated calling +@racket[heap-min], then @racket[heap-remove-min!]. + + @examples[#:eval the-eval + (define h (make-heap <=)) + (heap-add-all! h '(50 40 10 20 30)) + + (for ([x (in-heap/consume! h)]) + (displayln x)) + + (heap-count h)] +} +@defproc[(in-heap [heap heap?]) sequence?]{ +Returns a sequence equivalent to @racket[heap], maintaining the heap's ordering. +Equivalent to @racket[in-heap/consume!] except the heap is copied first. + + @examples[#:eval the-eval + (define h (make-heap <=)) + (heap-add-all! h '(50 40 10 20 30)) + + (for ([x (in-heap h)]) + (displayln x)) + + (heap-count h)] +} + diff --git a/collects/tests/data/heap.rkt b/collects/tests/data/heap.rkt index 256478d55f..542d2ec64a 100644 --- a/collects/tests/data/heap.rkt +++ b/collects/tests/data/heap.rkt @@ -67,3 +67,21 @@ (test-case "heap random dense" (rand-test 20 100 50 100)) + +(test-equal? "in-heap" + (for/list ([x (in-heap (mkheap))]) x) + '(2 4 6 8 10)) +(test-equal? "post in-heap count" + (let* ([h (mkheap)] + [lst (for/list ([x (in-heap h)]) x)]) + (heap-count h)) + (heap-count (mkheap))) +(test-equal? "in-heap/consume!" + (for/list ([x (in-heap/consume! (mkheap))]) x) + '(2 4 6 8 10)) +(test-equal? "post in-heap/consume! count" + (let* ([h (mkheap)] + [lst (for/list ([x (in-heap/consume! h)]) x)]) + (heap-count h)) + 0) + \ No newline at end of file From 10a8a625fae5feb185060c3f37dd50cc6be21c3e Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 27 Oct 2012 20:37:43 -0500 Subject: [PATCH 055/221] record the (uncompiled) domain pattern with a reduction relation so that context-closure can adjust the domain closes PR 13204 --- collects/redex/private/reduction-semantics.rkt | 15 +++++++++++++-- collects/redex/private/struct.rkt | 12 +++++++----- collects/redex/tests/tl-test.rkt | 11 +++++++++++ 3 files changed, 31 insertions(+), 7 deletions(-) diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt index 5649703c66..edbcb74af1 100644 --- a/collects/redex/private/reduction-semantics.rkt +++ b/collects/redex/private/reduction-semantics.rkt @@ -202,7 +202,16 @@ (reduction-relation-make-procs red)) (reduction-relation-rule-names red) (reduction-relation-lws red) - `any))) + (let ([orig-pat (reduction-relation-domain-pat red)]) + (cond + [(equal? orig-pat `any) + ;; special case for backwards compatibility: + ;; if there was no #:domain argument, then we + ;; probably should let the compatible closure also + ;; not have a domain + `any] + [else + `(in-hole ,pat ,orig-pat)]))))) (define (apply-reduction-relation/tagged p v) (let loop ([procs (reduction-relation-procs p)] @@ -941,7 +950,9 @@ (reverse (apply append (map reduction-relation-make-procs lst))) (map car (sort (hash-map name-ht list) < #:key cadr)) (apply append (map reduction-relation-lws lst)) - (reverse (apply append (map reduction-relation-procs lst)))))) + (reverse (apply append (map reduction-relation-procs lst))) + ;; not clear what the contract is here. + `any))) (define (do-node-match lhs-frm-id lhs-to-id pat rhs-proc child-make-proc rhs-from) (define (subst from to in) diff --git a/collects/redex/private/struct.rkt b/collects/redex/private/struct.rkt index 6fb89c6340..b449ab5acb 100644 --- a/collects/redex/private/struct.rkt +++ b/collects/redex/private/struct.rkt @@ -8,6 +8,7 @@ reduction-relation-rule-names reduction-relation-lws reduction-relation-procs + reduction-relation-domain-pat build-reduction-relation make-reduction-relation reduction-relation? empty-reduction-relation @@ -40,13 +41,14 @@ ;; make-procs = (listof (compiled-lang -> proc)) ;; rule-names : (listof sym) ;; procs : (listof proc) -(define-struct reduction-relation (lang make-procs rule-names lws procs)) +(define-struct reduction-relation (lang make-procs rule-names lws procs domain-pat)) (define empty-reduction-relation (make-reduction-relation 'empty-reduction-relations-language '() '() '() - '())) + '() + #f)) (define (build-reduction-relation original language rules rule-names lws domain) (define combined-rules @@ -62,8 +64,7 @@ (if original (remove-duplicates (append rule-names (reduction-relation-rule-names original))) rule-names)) - (define compiled-domain - (compile-pattern language domain #f)) + (define compiled-domain (compile-pattern language domain #f)) (make-reduction-relation language combined-rules combined-rule-names lws (map (λ (rule) @@ -81,4 +82,5 @@ (unless (match-pattern compiled-domain exp) (error 'reduction-relation "relation not defined for ~s" exp)) (specialized exp exp checked-rewrite acc))) - combined-rules))) + combined-rules) + domain)) diff --git a/collects/redex/tests/tl-test.rkt b/collects/redex/tests/tl-test.rkt index d848fdbe13..cbf2c0f620 100644 --- a/collects/redex/tests/tl-test.rkt +++ b/collects/redex/tests/tl-test.rkt @@ -1722,6 +1722,17 @@ '(4 2)) (list '8)) + (test (with-handlers ((exn:fail? exn-message)) + (apply-reduction-relation + (context-closure + (reduction-relation + empty-language #:domain #f + (--> #f #f)) + empty-language hole) + #t) + "exn not raised") + #rx"^reduction-relation:") + (test (apply-reduction-relation (context-closure (context-closure From fa743d705844d8a5d0953f61b9f1acf78d0c2e99 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 27 Oct 2012 19:43:59 -0600 Subject: [PATCH 056/221] remove obsolete "based on" entry --- collects/drracket/private/app.rkt | 5 ----- 1 file changed, 5 deletions(-) diff --git a/collects/drracket/private/app.rkt b/collects/drracket/private/app.rkt index 8590b0cae1..8c5b628651 100644 --- a/collects/drracket/private/app.rkt +++ b/collects/drracket/private/app.rkt @@ -187,11 +187,6 @@ (insert ".\n\nBased on:\n ") (insert (banner))) - (when (or (eq? (system-type) 'macos) - (eq? (system-type) 'macosx)) - (send* e - (insert " The A List (c) 1997-2001 Kyle Hammond\n"))) - (let ([tools (sort (drracket:tools:get-successful-tools) (lambda (a b) (stringstring (drracket:tools:successful-tool-spec a)) From fadf8a8860b3a2df7162eef4d67fa0a04a0279d6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 27 Oct 2012 19:54:52 -0600 Subject: [PATCH 057/221] avoid compiler warnings --- src/racket/src/jitcall.c | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/src/racket/src/jitcall.c b/src/racket/src/jitcall.c index ba264b9805..c1bdc1bf5a 100644 --- a/src/racket/src/jitcall.c +++ b/src/racket/src/jitcall.c @@ -1591,7 +1591,9 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ int i, offset, need_safety = 0, apply_to_list = 0; int direct_prim = 0, need_non_tail = 0, direct_native = 0, direct_self = 0, nontail_self = 0; Scheme_Native_Closure *inline_direct_native = NULL; +#ifdef USE_FLONUM_UNBOXING Scheme_Closure_Data *direct_data = NULL; +#endif int direct_flostack_offset = 0, unboxed_non_tail_args = 0; jit_direct_arg *inline_direct_args = NULL; int proc_already_in_place = 0; @@ -1700,13 +1702,15 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ if (is_tail) { if (nc->code->max_let_depth > jitter->max_tail_depth) jitter->max_tail_depth = nc->code->max_let_depth; - - direct_data = data; /* for flonum handling */ - - inline_direct_native = nc; + inline_direct_native = nc; +#ifdef USE_FLONUM_UNBOXING + direct_data = data; +#endif } else { if (num_rands < MAX_SHARED_CALL_RANDS) { +#ifdef USE_FLONUM_UNBOXING direct_data = data; +#endif unboxed_non_tail_args = 1; } } @@ -1830,8 +1834,10 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ } /* not sync'd...*/ +#ifdef USE_FLONUM_UNBOXING if (direct_self && is_tail) direct_data = jitter->self_data; +#endif for (i = 0; i < num_rands; i++) { PAUSE_JIT_DATA(); @@ -2016,11 +2022,14 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ } } else { int mo = (multi_ok ? 1 : 0); +#ifdef USE_FLONUM_UNBOXING void *unboxed_code; +#endif if (unboxed_non_tail_args && !direct_flostack_offset) unboxed_non_tail_args = 0; +#ifdef USE_FLONUM_UNBOXING if (unboxed_non_tail_args) { if (!sjc.shared_non_tail_code[4][num_rands][mo]) { scheme_ensure_retry_available(jitter, multi_ok); @@ -2030,6 +2039,7 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ unboxed_code = sjc.shared_non_tail_code[4][num_rands][mo]; } else unboxed_code = NULL; +#endif if (!sjc.shared_non_tail_code[dp][num_rands][mo]) { scheme_ensure_retry_available(jitter, multi_ok); From ba6e383963de1c5e64058d99efceb799171827a9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 27 Oct 2012 21:31:08 -0600 Subject: [PATCH 058/221] racket/gui gtk: fix on-subwindow-... handling Handling was broken by changes to fix enter and leave events (in commit a5d7812732) Merge to v5.3.1 --- collects/mred/private/wx/gtk/frame.rkt | 2 +- collects/mred/private/wx/gtk/window.rkt | 8 ++++++-- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index e9fc5a56b5..fc041d70d6 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -169,7 +169,7 @@ (values vbox-gtk panel-gtk)))) (gtk_widget_show vbox-gtk) (gtk_widget_show panel-gtk) - (connect-key-and-mouse gtk) + (connect-enter-and-leave gtk) (unless is-dialog? (gtk_window_set_icon_list gtk (cdr (force icon-pixbufs+glist)))) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 87c0d0e66b..643f5a13be 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -35,6 +35,7 @@ connect-focus connect-key-and-mouse + connect-enter-and-leave do-button-event (struct-out GtkRequisition) _GtkRequisition-pointer @@ -293,6 +294,10 @@ (let ([wx (gtk->wx gtk)]) (when wx (send wx leave-window))) (do-button-event gtk event #f #t))) +(define (connect-enter-and-leave gtk) + (connect-enter gtk) + (connect-leave gtk)) + (define (connect-key-and-mouse gtk [skip-press? #f]) (connect-key-press gtk) (connect-key-release gtk) @@ -300,8 +305,7 @@ (connect-button-press gtk) (unless skip-press? (connect-button-release gtk)) (connect-pointer-motion gtk) - (connect-enter gtk) - (connect-leave gtk)) + (connect-enter-and-leave gtk)) (define (do-button-event gtk event motion? crossing?) (let ([type (if motion? From cdf7cad8acc8552a92cfe6d50cbf88718447c2a6 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 28 Oct 2012 03:35:15 -0400 Subject: [PATCH 059/221] New Racket version 5.3.1.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.manifest | 2 +- src/worksp/racket/racket.rc | 8 ++++---- src/worksp/starters/start.rc | 8 ++++---- 7 files changed, 21 insertions(+), 21 deletions(-) diff --git a/src/worksp/gracket/gracket.manifest b/src/worksp/gracket/gracket.manifest index ad97d878c8..554cc91d26 100644 --- a/src/worksp/gracket/gracket.manifest +++ b/src/worksp/gracket/gracket.manifest @@ -1,6 +1,6 @@ - diff --git a/src/worksp/gracket/gracket.rc b/src/worksp/gracket/gracket.rc index 8baa177099..b181b0e526 100644 --- a/src/worksp/gracket/gracket.rc +++ b/src/worksp/gracket/gracket.rc @@ -11,8 +11,8 @@ APPLICATION ICON DISCARDABLE "gracket.ico" // VS_VERSION_INFO VERSIONINFO - FILEVERSION 5,3,1,2 - PRODUCTVERSION 5,3,1,2 + FILEVERSION 5,3,1,3 + PRODUCTVERSION 5,3,1,3 FILEFLAGSMASK 0x3fL #ifdef _DEBUG FILEFLAGS 0x1L @@ -30,11 +30,11 @@ BEGIN VALUE "CompanyName", "PLT Scheme Inc.\0" VALUE "FileDescription", "Racket GUI application\0" VALUE "InternalName", "GRacket\0" - VALUE "FileVersion", "5, 3, 1, 2\0" + VALUE "FileVersion", "5, 3, 1, 3\0" VALUE "LegalCopyright", "Copyright 1995-2012\0" VALUE "OriginalFilename", "GRacket.exe\0" VALUE "ProductName", "Racket\0" - VALUE "ProductVersion", "5, 3, 1, 2\0" + VALUE "ProductVersion", "5, 3, 1, 3\0" END END BLOCK "VarFileInfo" diff --git a/src/worksp/mzcom/mzcom.rc b/src/worksp/mzcom/mzcom.rc index 43117e66fd..de1aa178d9 100644 --- a/src/worksp/mzcom/mzcom.rc +++ b/src/worksp/mzcom/mzcom.rc @@ -53,8 +53,8 @@ END // VS_VERSION_INFO VERSIONINFO - FILEVERSION 5,3,1,2 - PRODUCTVERSION 5,3,1,2 + FILEVERSION 5,3,1,3 + PRODUCTVERSION 5,3,1,3 FILEFLAGSMASK 0x3fL #ifdef _DEBUG FILEFLAGS 0x1L @@ -70,12 +70,12 @@ BEGIN BLOCK "040904b0" BEGIN VALUE "FileDescription", "MzCOM Module" - VALUE "FileVersion", "5, 3, 1, 2" + VALUE "FileVersion", "5, 3, 1, 3" VALUE "InternalName", "MzCOM" VALUE "LegalCopyright", "Copyright 2000-2012 PLT (Paul Steckler)" VALUE "OriginalFilename", "MzCOM.EXE" VALUE "ProductName", "MzCOM Module" - VALUE "ProductVersion", "5, 3, 1, 2" + VALUE "ProductVersion", "5, 3, 1, 3" END END BLOCK "VarFileInfo" diff --git a/src/worksp/mzcom/mzobj.rgs b/src/worksp/mzcom/mzobj.rgs index 12d872df61..4e22bbca1d 100644 --- a/src/worksp/mzcom/mzobj.rgs +++ b/src/worksp/mzcom/mzobj.rgs @@ -1,19 +1,19 @@ HKCR { - MzCOM.MzObj.5.3.1.2 = s 'MzObj Class' + MzCOM.MzObj.5.3.1.3 = s 'MzObj Class' { CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}' } MzCOM.MzObj = s 'MzObj Class' { CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}' - CurVer = s 'MzCOM.MzObj.5.3.1.2' + CurVer = s 'MzCOM.MzObj.5.3.1.3' } NoRemove CLSID { ForceRemove {A3B0AF9E-2AB0-11D4-B6D2-0060089002FE} = s 'MzObj Class' { - ProgID = s 'MzCOM.MzObj.5.3.1.2' + ProgID = s 'MzCOM.MzObj.5.3.1.3' VersionIndependentProgID = s 'MzCOM.MzObj' ForceRemove 'Programmable' LocalServer32 = s '%MODULE%' diff --git a/src/worksp/racket/racket.manifest b/src/worksp/racket/racket.manifest index 2d6cafb699..679d7ea6b0 100644 --- a/src/worksp/racket/racket.manifest +++ b/src/worksp/racket/racket.manifest @@ -1,6 +1,6 @@ - diff --git a/src/worksp/racket/racket.rc b/src/worksp/racket/racket.rc index f1ade426ed..fdd1c324b9 100644 --- a/src/worksp/racket/racket.rc +++ b/src/worksp/racket/racket.rc @@ -11,8 +11,8 @@ APPLICATION ICON DISCARDABLE "racket.ico" // VS_VERSION_INFO VERSIONINFO - FILEVERSION 5,3,1,2 - PRODUCTVERSION 5,3,1,2 + FILEVERSION 5,3,1,3 + PRODUCTVERSION 5,3,1,3 FILEFLAGSMASK 0x3fL #ifdef _DEBUG FILEFLAGS 0x1L @@ -30,11 +30,11 @@ BEGIN VALUE "CompanyName", "PLT Scheme Inc.\0" VALUE "FileDescription", "Racket application\0" VALUE "InternalName", "Racket\0" - VALUE "FileVersion", "5, 3, 1, 2\0" + VALUE "FileVersion", "5, 3, 1, 3\0" VALUE "LegalCopyright", "Copyright 1995-2012\0" VALUE "OriginalFilename", "racket.exe\0" VALUE "ProductName", "Racket\0" - VALUE "ProductVersion", "5, 3, 1, 2\0" + VALUE "ProductVersion", "5, 3, 1, 3\0" END END BLOCK "VarFileInfo" diff --git a/src/worksp/starters/start.rc b/src/worksp/starters/start.rc index c2ac25e045..c9066fa134 100644 --- a/src/worksp/starters/start.rc +++ b/src/worksp/starters/start.rc @@ -22,8 +22,8 @@ APPLICATION ICON DISCARDABLE "mzstart.ico" // VS_VERSION_INFO VERSIONINFO - FILEVERSION 5,3,1,2 - PRODUCTVERSION 5,3,1,2 + FILEVERSION 5,3,1,3 + PRODUCTVERSION 5,3,1,3 FILEFLAGSMASK 0x3fL #ifdef _DEBUG FILEFLAGS 0x1L @@ -45,7 +45,7 @@ BEGIN #ifdef MZSTART VALUE "FileDescription", "Racket Launcher\0" #endif - VALUE "FileVersion", "5, 3, 1, 2\0" + VALUE "FileVersion", "5, 3, 1, 3\0" #ifdef MRSTART VALUE "InternalName", "mrstart\0" #endif @@ -60,7 +60,7 @@ BEGIN VALUE "OriginalFilename", "MzStart.exe\0" #endif VALUE "ProductName", "Racket\0" - VALUE "ProductVersion", "5, 3, 1, 2\0" + VALUE "ProductVersion", "5, 3, 1, 3\0" END END BLOCK "VarFileInfo" From 5861bf0b9fc5ff3b237619d02dc6d5eb4a55837e Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 28 Oct 2012 13:55:02 -0400 Subject: [PATCH 060/221] Make Typed Racket name printing more deterministic. --- collects/typed-racket/types/printer.rkt | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/collects/typed-racket/types/printer.rkt b/collects/typed-racket/types/printer.rkt index 20df7bdae6..41eaaf40d8 100644 --- a/collects/typed-racket/types/printer.rkt +++ b/collects/typed-racket/types/printer.rkt @@ -36,10 +36,16 @@ ;; does t have a type name associated with it currently? ;; has-name : Type -> Maybe[Symbol] (define (has-name? t) - (and print-aliases - (for/first ([(n t*) (in-pairs (in-list (force (current-type-names))))] - #:when (and (Type? t*) (type-equal? t t*))) - n))) + (cond + [print-aliases + (define candidates + (for/list ([(n t*) (in-pairs (in-list (force (current-type-names))))] + #:when (and (Type? t*) (type-equal? t t*))) + n)) + (if (null? candidates) + #f + (car (sort candidates string>? #:key symbol->string)))] + [else #f])) (define (print-filter c port write?) (define (fp . args) (apply fprintf port args)) From cfb256fe16b9b673d36f3e672b0ef6b9b9e53188 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 28 Oct 2012 11:43:13 -0600 Subject: [PATCH 061/221] cocoa: update PSMTabBarControl for x86_64 The update avoids a now-deprecated method. --- src/README | 9 +++++++-- src/download-libs.rkt | 2 +- src/get-libs.rkt | 12 ++++++++++-- src/mac/README.txt | 14 ++++++++++---- 4 files changed, 28 insertions(+), 9 deletions(-) diff --git a/src/README b/src/README index 278dd29917..275c83de8d 100644 --- a/src/README +++ b/src/README @@ -35,8 +35,13 @@ Win32). Compiling for Mac OS X ======================================================================== -First, install the Mac OS X Developer Tools from Apple. Then, follow -the Unix instructions below, but note the following: +First, install developer command-line tools from Apple. As of this +writing, install by getting "Xcode" from the AppStore; then, in +Xcode's preferences window and in the "Downloads" panel, install +"Command Line Tools". + +After installing developer tools, follow the Unix instructions below, +but note the following: * The Racket build creates a framework, "Racket.framework", which is installed into "racket/lib". This framework is used by the `racket' diff --git a/src/download-libs.rkt b/src/download-libs.rkt index ea18ab6422..37bd6dc066 100644 --- a/src/download-libs.rkt +++ b/src/download-libs.rkt @@ -4,7 +4,7 @@ (provide do-download) (define url-host "download.racket-lang.org") -(define url-path "/libs/8/") +(define url-path "/libs/9/") (define url-base (string-append "http://" url-host url-path)) (define architecture #f) ;; set in `do-download' diff --git a/src/get-libs.rkt b/src/get-libs.rkt index b04a8ae9e0..745c49c73b 100644 --- a/src/get-libs.rkt +++ b/src/get-libs.rkt @@ -53,7 +53,7 @@ ["libpixman-1.0.dylib" 633368] ["libgthread-2.0.0.dylib" 8592] ["libpng15.15.dylib" 214836] - ["PSMTabBarControl.tgz" 107267 "PSMTabBarControl.framework" 316528]] + ["PSMTabBarControl.tgz" 156265 "PSMTabBarControl.framework" 450751]] '[ppc-macosx ["libcairo.2.dylib" 2620616] ["libffi.5.dylib" 67920] @@ -173,11 +173,19 @@ (directory-size path) 0)))) + (define-values (path-size/show) + (lambda (path) + (let-values ([(sz) (path-size path)]) + (if (getenv "PLT_SHOW_PATH_SIZES") + (printf "~s ~s\n" path sz) + (void)) + sz))) + (define-values (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))])) + (equal? size (path-size/show path))])) ;; not provided by #%kernel (define-values (filter) diff --git a/src/mac/README.txt b/src/mac/README.txt index aa30e6a3fe..e895fd5869 100644 --- a/src/mac/README.txt +++ b/src/mac/README.txt @@ -11,8 +11,13 @@ Get these packages (or newer, if compatible): pango-1.29.5.tar.gz [PowerPC: pango-1.28.0.tar.gz] libjpeg62 (maybe in binary form) - PSMTabBarControl, probably from "maccode.googlecode.com", - and handled differently + PSMTabBarControl, probably from + https://github.com/dorianj/PSMTabBarControl + [PowerPC: maccode.googlecode.com] + and handled differently; note that the version + at from maccode has a bug on dealloc() and + uses methods that are now deprecated + Patches: cairo/src/cairo-path-fixed.c:1295: [from Cairo repo, 3/18/11] @@ -36,7 +41,7 @@ Patches: apply "coretext.patch" (64-bit only) gettext/gettext-tools/gnulib-lib/stpncpy.c:28: may need to comment out // # define __stpncpy stpncpy - PSMTabBarControl/PSMTabBarControl.m:216: change to + PowerPC: PSMTabBarControl/PSMTabBarControl.m:216: change to // copy _cells because removing a cell // can modify the array (which is not allowed) NSArray *copyOfCells = [NSArray arrayWithArray: _cells]; @@ -72,7 +77,8 @@ Configures (where is some temporary area): XCode: Build PSMTabBarControl. You only need the Framework target, and - in Release mode. + in Release mode (which is "Build for Archiving" in Xcode 4.5). + Use `ditto' to reduce the framework to one architecture. Install: racket install-libs.rkt /lib From 55b358f2014409c36962c3dc46031ea049a07efb Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 28 Oct 2012 12:01:41 -0600 Subject: [PATCH 062/221] list PSMTabBarControl among included software --- collects/scribblings/main/license.scrbl | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/collects/scribblings/main/license.scrbl b/collects/scribblings/main/license.scrbl index 571afd23f4..f44d5059ef 100644 --- a/collects/scribblings/main/license.scrbl +++ b/collects/scribblings/main/license.scrbl @@ -90,6 +90,12 @@ Racket software includes or extends the following copyrighted material: Copyright (c) 2003-2005 Hewlett-Packard Development Company, L.P. } +@copyright{ + PSMTabBarControl + John Pannell, Robert Payne, Adam Strzelecki, Dorian Johnson + https://github.com/dorianj/PSMTabBarControl +} + @copyright{ Clanbomber icon and Stop icons Everaldo Coelho From 995af02c11c248a959e694b285b832012d8955c2 Mon Sep 17 00:00:00 2001 From: James Swaine Date: Sun, 28 Oct 2012 15:47:42 -0300 Subject: [PATCH 063/221] Make future trace docs point to the right place when discussing gc-info --- .../scribblings/futures-trace.scrbl | 25 +++++-------------- 1 file changed, 6 insertions(+), 19 deletions(-) diff --git a/collects/future-visualizer/scribblings/futures-trace.scrbl b/collects/future-visualizer/scribblings/futures-trace.scrbl index b934d98782..00d002d456 100644 --- a/collects/future-visualizer/scribblings/futures-trace.scrbl +++ b/collects/future-visualizer/scribblings/futures-trace.scrbl @@ -1,5 +1,7 @@ #lang scribble/doc -@(require "common.rkt" (for-label racket/future future-visualizer/trace)) +@(require "common.rkt" + (for-label racket/future + future-visualizer/trace)) @title[#:tag "futures-trace"]{Futures Tracing} @@ -63,10 +65,11 @@ the execution of parallel programs written using @racket[future]. } @defstruct[indexed-future-event ([index exact-nonnegative-integer?] - [event (or future-event? gc-info?)])]{ + [event any])]{ Represents an individual log message in a program trace. In addition to future events, the tracing code also records garbage collection events; hence - the @racket[event] field may contain either a @racket[future-event] or @racket[gc-info], + the @racket[event] field may contain either a @racket[future-event] or gc-info + @(tech "prefab" #:doc '(lib "scribblings/reference/reference.scrbl")) struct (see @refsecref["garbagecollection"]), where the latter describes a GC operation. Because multiple @racket[future-event] structures may contain identical timestamps, the @racket[index] field ranks them in the order in which they were recorded @@ -82,19 +85,3 @@ the execution of parallel programs written using @racket[future]. #:prefab]{ Represents a future event as logged by the run-time system. See @refsecref["future-logging"] for more information.} - -@defstruct[gc-info ([major? boolean?] - [pre-used integer?] - [pre-admin integer?] - [code-page-total integer?] - [post-used integer?] - [post-admin integer?] - [start-time integer?] - [end-time integer?] - [start-real-time real?] - [end-real-time real?]) - #:prefab]{ - Represents a garbage collection. The only fields used by the visualizer - are @racket[start-real-time] and @racket[end-real-time], which are inexact - numbers representing time in the same way as @racket[current-inexact-milliseconds]. -} From 47a33f2edf8a5125a16a1b5e98359ccafdb0fb5d Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Thu, 25 Oct 2012 14:14:52 -0600 Subject: [PATCH 064/221] Added another example for for/fold/derived: for/max. Updated example for for/digits to avoid confusion: it's not clear otherwise that the intentional syntax error wasn't just a casual mistake. Added an example for sequence-add-between. --- collects/scribblings/reference/for.scrbl | 20 +++++++++++++++++++ .../scribblings/reference/sequences.scrbl | 13 +++++++++++- 2 files changed, 32 insertions(+), 1 deletion(-) diff --git a/collects/scribblings/reference/for.scrbl b/collects/scribblings/reference/for.scrbl index c9dfd08728..a0f31af166 100644 --- a/collects/scribblings/reference/for.scrbl +++ b/collects/scribblings/reference/for.scrbl @@ -364,6 +364,8 @@ source for all syntax errors. (values (+ n (* d k)) (* k 10)))]) n))])) +@code:comment{If we misuse for/digits, we can get good error reporting} +@code:comment{because the use of orig-datum allows for source correlation:} (for/digits [a (in-list '(1 2 3))] [b (in-list '(4 5 6))] @@ -373,6 +375,24 @@ source for all syntax errors. ([a (in-list '(1 2 3))] [b (in-list '(2 4 6))]) (+ a b)) + + +@code:comment{Another example: compute the max during iteration:} +(define-syntax (for/max stx) + (syntax-case stx () + [(_ clauses . defs+exprs) + (with-syntax ([original stx]) + #'(for/fold/derived original + ([current-max -inf.0]) + clauses + (define maybe-new-max + (let () . defs+exprs)) + (if (> maybe-new-max current-max) + maybe-new-max + current-max)))])) +(for/max ([n '(3.14159 2.71828 1.61803)] + [s '(-1 1 1)]) + (* n s)) ] } diff --git a/collects/scribblings/reference/sequences.scrbl b/collects/scribblings/reference/sequences.scrbl index f2da82ba8b..5a5da08e18 100644 --- a/collects/scribblings/reference/sequences.scrbl +++ b/collects/scribblings/reference/sequences.scrbl @@ -25,7 +25,7 @@ vice-versa. @(define sequence-evaluator (let ([evaluator (make-base-eval)]) - (evaluator '(require racket/generic racket/list racket/stream)) + (evaluator '(require racket/generic racket/list racket/stream racket/sequence)) evaluator)) @guideintro["sequences"]{sequences} @@ -699,6 +699,17 @@ each element in the sequence. If @racket[s] is a @tech{stream}, then the result is also a @tech{stream}. + + @examples[#:eval sequence-evaluator + (let* ([all-reds (in-cycle '("red"))] + [red-and-blues (sequence-add-between all-reds "blue")]) + (for/list ([n (in-range 10)] + [elt red-and-blues]) + elt)) + + (for ([text (sequence-add-between '("veni" "vidi" "duci") ", ")]) + (display text)) + ] } @; ====================================================================== From b7681e08078d2edef9f6abb1c9f9d73e02c1c1ff Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 29 Oct 2012 06:21:35 -0500 Subject: [PATCH 065/221] adjust racket/engine so that it logs the time that various things happen (and remove the commented out printfs that seem to be printing out that same information) --- collects/racket/engine.rkt | 32 +++++++++++++++++---- collects/scribblings/reference/engine.scrbl | 14 +++++++++ 2 files changed, 40 insertions(+), 6 deletions(-) diff --git a/collects/racket/engine.rkt b/collects/racket/engine.rkt index 8efdeed095..8f2fef74c1 100644 --- a/collects/racket/engine.rkt +++ b/collects/racket/engine.rkt @@ -13,7 +13,7 @@ ;; An X-engine-object is ;; (make-engine-object thread semaphore channel channel X) -(define-struct engine-object (worker can-stop-lock done-ch ex-ch result) +(define-struct engine-object (worker can-stop-lock done-ch ex-ch result name) #:mutable) ;; engine : ((bool ->) -> X) -> X-engine-object @@ -46,16 +46,18 @@ (let ([v (f enable-stop)]) (enable-stop #t) (channel-put done-ch v)))))]) - (begin0 (make-engine-object tid can-stop-lock done-ch ex-ch #f) + (begin0 (make-engine-object tid can-stop-lock done-ch ex-ch #f + (and (object-name f) + (symbol->string (object-name f)))) (thread-suspend tid) (semaphore-post proceed-sema)))) ;; engine : real-number X-engine-object -> bool (define (engine-run timeout w) + (log "engine-run called" w) (if (engine-object-worker w) (let ([can-stop-lock (engine-object-can-stop-lock w)] [worker (engine-object-worker w)]) - #;(printf "2. starting engine\n") (thread-resume worker) (dynamic-wind void @@ -65,25 +67,27 @@ timeout (alarm-evt (+ timeout (current-inexact-milliseconds)))) (lambda (x) - #;(printf "2. alarm-evt\n") + (log "alarm woke up, waiting to suspend engine" w) (semaphore-wait can-stop-lock) + (log "suspending engine" w) (thread-suspend worker) (semaphore-post can-stop-lock) #f)) (wrap-evt (engine-object-done-ch w) (lambda (res) - #;(printf "2. engine-done-evt\n") + (log "engine done" w) (set-engine-object-result! w res) (engine-kill w) #t)) (wrap-evt (engine-object-ex-ch w) (lambda (exn) - #;(printf "2. ex-evt\n") + (log "engine raised exn" w) (engine-kill w) (raise exn)))))) ;; In case we escape through a break: (lambda () (when (thread-running? worker) + (log "engine escape via break" w) (semaphore-wait can-stop-lock) (thread-suspend worker) (semaphore-post can-stop-lock))))) @@ -104,3 +108,19 @@ (define (engine? x) (engine-object? x)) + +(define engine-logger (make-logger 'racket/engine (current-logger))) +(define-syntax-rule + (log msg w) + (when (log-level? engine-logger 'debug) + (do-log msg w))) +(define (do-log msg w) + (define name (engine-object-name w)) + (log-message engine-logger 'debug + (if name + (string-append "racket/engine: " name ": " msg) + (string-append "racket/engine: " msg)) + (engine-info (current-inexact-milliseconds) + name))) +(struct engine-info (msec name) #:prefab) + diff --git a/collects/scribblings/reference/engine.scrbl b/collects/scribblings/reference/engine.scrbl index a8cdd274d4..8843c97e6c 100644 --- a/collects/scribblings/reference/engine.scrbl +++ b/collects/scribblings/reference/engine.scrbl @@ -10,6 +10,20 @@ An @deftech{engine} is an abstraction that models processes that can be preempted by a timer or other external trigger. They are inspired by the work of Haynes and Friedman @cite["Haynes84"]. +Engines log their behavior via a logger with the name +@racket['racket/engine]. The logger is created when the module +is instantiated and uses the result of @racket[(current-logger)] +as its parent. The library adds logs a @racket['debug] level +message: when @racket[engine-run] +is called, when the engine timeout expires, and when the engine is +stopped (either because it terminated or it reached a safe point to +stop). Each log message holds a value of the struct: +@racketblock[(struct engine-info (msec name) #:prefab)] +where the @racket[_msec] field holds the result of +@racket[(current-inexact-milliseconds)] at the moment of logging, +and the @racket[_name] field holds the name of the procedure +passed to @racket[engine]. + @defproc[(engine [proc ((any/c . -> . void?) . -> . any/c)]) engine?]{ From 33eba697a0d1fe354768dd8d7c77bacbe9b7ab14 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 29 Oct 2012 06:43:24 -0500 Subject: [PATCH 066/221] adjust the fields of the gui-event struct --- collects/mred/private/wx/common/queue.rkt | 6 +++--- collects/scribblings/gui/win-overview.scrbl | 16 +++++++--------- 2 files changed, 10 insertions(+), 12 deletions(-) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 546efb2cb6..35ba24af97 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -442,7 +442,7 @@ ;; start? : boolean -- indicates if this is a start of an event being handled or not ;; msec : start time if start? is #t, delta from start to end if start? is #f ;; name : (or/c #f symbol?) -(struct gui-event (start? msec name) #:prefab) +(struct gui-event (start end name) #:prefab) (define (handle-event thunk e) (call-with-continuation-prompt ; to delimit continuations @@ -454,7 +454,7 @@ (when (log-level? event-logger 'debug) (log-message event-logger 'debug "starting to handle an event" - (gui-event #t before (object-name thunk)))) + (gui-event before #f (object-name thunk)))) (let ([b (box thunk)]) ;; use the event-dispatch handler: (with-continuation-mark dispatch-event-key b @@ -469,7 +469,7 @@ (log-message event-logger 'debug (format "handled an event: ~a msec" (- after before)) - (gui-event #f (- after before) (object-name thunk))))) + (gui-event before after (object-name thunk))))) dispatch-event-prompt)))) (define yield diff --git a/collects/scribblings/gui/win-overview.scrbl b/collects/scribblings/gui/win-overview.scrbl index 1ce753c017..5c2a5e9d5f 100644 --- a/collects/scribblings/gui/win-overview.scrbl +++ b/collects/scribblings/gui/win-overview.scrbl @@ -957,15 +957,13 @@ The GUI system logs the timing of when events are handled and how long they take to be handled. Each event that involves a callback into Racket code has two events logged, both of which use the @racket[gui-event] struct: -@racketblock[(struct gui-event (start? msec name) #:prefab)] -The @racket[start?] field is a boolean indicating if this -event is logging the time when an event is starting to be handled, -or when it finishes. In the case that @racket[start?] is @racket[#t], -the @racket[msec] field is the result of -@racket[current-inexact-milliseconds]; when @racket[start?] is @racket[#f], -then the @racket[msec] field is the number of milliseconds that the -event handling took (the difference between @racket[current-inexact-milliseconds]'s -results before and after the handling). The @racket[name] field is +@racketblock[(struct gui-event (start end name) #:prefab)] +The @racket[_start] field is the result of @racket[(current-inexact-milliseconds)] +when the event handling starts. The @racket[_end] field is +@racket[#f] for the log message when the event handling starts, +and the result of @racket[(current-inexact-milliseconds)] when +it finishes for the log message when an event finishes. +The @racket[_name] field is the name of the function that handled the event; in the case of a @racket[queue-callback]-based event, it is the name of the thunk passed to @racket[queue-callback]. From 93aea7036becf181a1a43a6a32d0131653acef6f Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 29 Oct 2012 06:44:38 -0500 Subject: [PATCH 067/221] hide the get-online-expansion-colors method --- collects/drracket/private/local-member-names.rkt | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/collects/drracket/private/local-member-names.rkt b/collects/drracket/private/local-member-names.rkt index 68fb3f23f0..411eab9d60 100644 --- a/collects/drracket/private/local-member-names.rkt +++ b/collects/drracket/private/local-member-names.rkt @@ -24,3 +24,8 @@ ;; defined in module-language.rkt (define-local-member-name set-lang-wants-big-defs/ints-labels?) + +;; used by the test suite to tell when the +;; online check syntax has finished +(define-local-member-name + get-online-expansion-colors) \ No newline at end of file From eb97b2f193024b1314c5ecc058ab449b228723fc Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 29 Oct 2012 07:31:54 -0600 Subject: [PATCH 068/221] fix in srfi/1 Closes PR 13214 --- collects/srfi/1/fold.rkt | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/collects/srfi/1/fold.rkt b/collects/srfi/1/fold.rkt index 4939b7f1b9..aa897ae936 100644 --- a/collects/srfi/1/fold.rkt +++ b/collects/srfi/1/fold.rkt @@ -54,7 +54,7 @@ (check-arg procedure? p 'unfold-right) (check-arg procedure? f 'unfold-right) (check-arg procedure? g 'unfold-right) - (let lp ((seed seed) (ans maybe-tail)) + (let lp ((seed seed) (ans (if (pair? maybe-tail) (car maybe-tail) '()))) (if (p seed) ans (lp (g seed) (cons (f seed) ans))))) @@ -249,3 +249,9 @@ (recur (cdr lis)))))) ;;; fold.rkt ends here + +(module+ test + (define (test a b) + (unless (equal? a b) (error 'test "failed: ~e vs. ~e" a b))) + (test (unfold-right null? car cdr '(2 3) '(4 5)) + '(3 2 4 5))) From 78d48160b6fb952b42fa9f6b6d41ff2b8f7a12f8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 29 Oct 2012 07:46:10 -0600 Subject: [PATCH 069/221] add SRFI 1's `unfold-right' to doc index --- collects/srfi/srfi.scrbl | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/srfi/srfi.scrbl b/collects/srfi/srfi.scrbl index 275c17f113..26043809f5 100644 --- a/collects/srfi/srfi.scrbl +++ b/collects/srfi/srfi.scrbl @@ -152,6 +152,7 @@ functions. (reduce #f "reduce") (reduce-right #f "reduce-right") (unfold #f "unfold") + (unfold-right #f "unfold-right") (map #f "map") (for-each #f "srfi-1.html") (append-map #f "append-map") From 7cca723382fbe1a2355ebb1487c1a921a9d797db Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 29 Oct 2012 07:56:42 -0600 Subject: [PATCH 070/221] fix SRFI 1 testing of `unfold-right' --- collects/srfi/1/fold.rkt | 6 ------ collects/tests/srfi/1/fold-test.rkt | 13 +++++++++++-- 2 files changed, 11 insertions(+), 8 deletions(-) diff --git a/collects/srfi/1/fold.rkt b/collects/srfi/1/fold.rkt index aa897ae936..443d918d1e 100644 --- a/collects/srfi/1/fold.rkt +++ b/collects/srfi/1/fold.rkt @@ -249,9 +249,3 @@ (recur (cdr lis)))))) ;;; fold.rkt ends here - -(module+ test - (define (test a b) - (unless (equal? a b) (error 'test "failed: ~e vs. ~e" a b))) - (test (unfold-right null? car cdr '(2 3) '(4 5)) - '(3 2 4 5))) diff --git a/collects/tests/srfi/1/fold-test.rkt b/collects/tests/srfi/1/fold-test.rkt index 63d9a5db49..4e818cadbc 100644 --- a/collects/tests/srfi/1/fold-test.rkt +++ b/collects/tests/srfi/1/fold-test.rkt @@ -73,7 +73,7 @@ (lambda (seed) (* seed 2)) (lambda (seed) (* seed 3)) (lambda (seed) (* seed 5)) - 1) + '(1)) (list 1))) (test-case @@ -82,8 +82,17 @@ (unfold-right (lambda (seed) (= seed 729)) (lambda (seed) (* seed 2)) (lambda (seed) (* seed 3)) - 1 1) + '(486 162 54 18 6 2))) + + (test-case + "unfold-right:normal-case-opt-arg" + (check-equal? + (unfold-right (lambda (seed) (= seed 729)) + (lambda (seed) (* seed 2)) + (lambda (seed) (* seed 3)) + 1 + '(1)) '(486 162 54 18 6 2 1))) ;; FOLD From 9f66a39794be4f656fc00c0601f36194760a9f37 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 29 Oct 2012 13:44:45 -0600 Subject: [PATCH 071/221] removing unnecessary grackets --- collects/meta/props | 1 - 1 file changed, 1 deletion(-) diff --git a/collects/meta/props b/collects/meta/props index 83d8a0eb62..8c325d32b7 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -649,7 +649,6 @@ path/s is either such a string or a list of them. "collects/2htdp/tests/record-stop-when.rkt" drdr:command-line (gracket *) "collects/2htdp/tests/record.rkt" drdr:command-line (gracket *) "collects/2htdp/tests/release.rkt" drdr:command-line (gracket *) -"collects/2htdp/tests/stop.rkt" drdr:command-line (gracket *) "collects/2htdp/tests/test-image.rkt" responsible (robby) "collects/2htdp/tests/ufo-rename.rkt" drdr:command-line (gracket *) "collects/2htdp/tests/universe-receive.rkt" drdr:command-line (raco "make" *) From 9773d89a447920147f53156f6f1d78dc31203c98 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 29 Oct 2012 16:34:42 -0400 Subject: [PATCH 072/221] Clean up `drdr:random` props. --- collects/meta/props | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/collects/meta/props b/collects/meta/props index 8c325d32b7..6181d6293d 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -896,8 +896,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 240 drdr:random #t -"collects/redex/examples/delim-cont/randomized-tests.rkt" drdr:command-line (racket * "--rules" "2250" "--size" "3") drdr:timeout 240 drdr:random #t +"collects/redex/examples/delim-cont/randomized-tests-test.rkt" drdr:timeout 240 +"collects/redex/examples/delim-cont/randomized-tests.rkt" drdr:command-line (racket * "--rules" "2250" "--size" "3") drdr:timeout 240 "collects/redex/examples/delim-cont/test.rkt" drdr:command-line (mzc *) "collects/redex/examples/letrec.rkt" drdr:command-line (mzc *) "collects/redex/examples/list-machine/slides.rkt" drdr:command-line (raco "make" *) @@ -1005,7 +1005,7 @@ path/s is either such a string or a list of them. "collects/tests/compiler/regression.rkt" responsible (mflatt) "collects/tests/compiler/test" drdr:command-line (raco "test" "-r" "--" *) "collects/tests/compiler/zo-test-worker.rkt" drdr:command-line #f -"collects/tests/compiler/zo-test.rkt" drdr:command-line (racket * "-I" "-S" "-t" "60" "-v" "-R") drdr:random #t +"collects/tests/compiler/zo-test.rkt" drdr:command-line (racket * "-I" "-S" "-t" "60" "-v" "-R") "collects/tests/data" responsible (ryanc) "collects/tests/datalog" responsible (jay) "collects/tests/db" responsible (ryanc) @@ -1063,7 +1063,7 @@ path/s is either such a string or a list of them. "collects/tests/framework/text.rkt" drdr:command-line (mzc "-k" *) "collects/tests/frtime" responsible (gcooper jay) "collects/tests/future" responsible (jamesswaine mflatt robby) -"collects/tests/future/future.rkt" drdr:timeout 200 +"collects/tests/future/future.rkt" drdr:timeout 200 drdr:random #t "collects/tests/future/random-future.rkt" drdr:timeout 480 "collects/tests/generic" responsible (asumu stamourv) "collects/tests/gracket" responsible (mflatt) @@ -1073,12 +1073,12 @@ path/s is either such a string or a list of them. "collects/tests/gracket/flush-stress.rkt" drdr:command-line #f "collects/tests/gracket/item.rkt" drdr:command-line (mzc *) "collects/tests/gracket/mem.rkt" drdr:command-line #f -"collects/tests/gracket/paramz.rktl" drdr:command-line (gracket "-f" *) +"collects/tests/gracket/paramz.rktl" drdr:command-line (gracket "-f" *) drdr:random #t "collects/tests/gracket/png.rktl" drdr:command-line #f "collects/tests/gracket/showkey.rkt" drdr:command-line #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/windowing.rktl" drdr:command-line (gracket "-f" *) drdr:random #t "collects/tests/gracket/wxme-doc-random.rkt" drdr:command-line (mzc *) "collects/tests/gracket/wxme-random.rkt" drdr:command-line #f "collects/tests/honu" responsible (rafkind) @@ -1364,7 +1364,7 @@ path/s is either such a string or a list of them. "collects/tests/racket/pconvert.rktl" drdr:command-line #f "collects/tests/racket/place" responsible (tewk) "collects/tests/racket/place-chan-rand-help.rkt" responsible (tewk) -"collects/tests/racket/place-chan-rand.rkt" responsible (tewk) drdr:random #t +"collects/tests/racket/place-chan-rand.rkt" responsible (tewk) "collects/tests/racket/place-channel-fd.rkt" responsible (tewk) "collects/tests/racket/place-channel-fd2.rkt" responsible (tewk) "collects/tests/racket/place-channel-ffi.rkt" responsible (tewk) @@ -1388,7 +1388,6 @@ path/s is either such a string or a list of them. "collects/tests/racket/stress/dict.rkt" drdr:timeout 180 "collects/tests/racket/stress/fuzz.rkt" responsible (samth mflatt) drdr:command-line (racket * "-c") drdr:timeout 300 drdr:random #t "collects/tests/racket/stress/module-stack.rkt" drdr:timeout 180 -"collects/tests/racket/subprocess.rktl" drdr:random #t "collects/tests/racket/sync.rktl" drdr:command-line #f "collects/tests/racket/syntax.rktl" drdr:command-line #f "collects/tests/racket/thread.rktl" drdr:command-line #f From 203a7a660c866fd93974387a72516806f47336b0 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Tue, 30 Oct 2012 12:32:31 -0400 Subject: [PATCH 073/221] db: fix another sqlite3 finalization bug --- collects/db/private/sqlite3/connection.rkt | 4 ++-- collects/db/private/sqlite3/ffi.rkt | 5 ++++- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/collects/db/private/sqlite3/connection.rkt b/collects/db/private/sqlite3/connection.rkt index a4d04423fb..6cd800e641 100644 --- a/collects/db/private/sqlite3/connection.rkt +++ b/collects/db/private/sqlite3/connection.rkt @@ -206,7 +206,7 @@ (let loop () (let ([stmt (sqlite3_next_stmt db #f)]) (when stmt - (HANDLE 'disconnect (sqlite3_finalize stmt)) + (sqlite3_finalize stmt) (loop)))) (HANDLE 'disconnect (sqlite3_close db)) (void)))))) @@ -225,7 +225,7 @@ (let ([stmt (send pst get-handle)]) (send pst set-handle #f) (when (and stmt -db) - (HANDLE fsym (sqlite3_finalize stmt))) + (sqlite3_finalize stmt)) (void))))) ;; Internal query diff --git a/collects/db/private/sqlite3/ffi.rkt b/collects/db/private/sqlite3/ffi.rkt index af7260cfbb..fa6baa0cb5 100644 --- a/collects/db/private/sqlite3/ffi.rkt +++ b/collects/db/private/sqlite3/ffi.rkt @@ -58,7 +58,10 @@ (define-sqlite sqlite3_finalize (_fun _sqlite3_statement - -> _int)) + -> _int + ;; sqlite3_finalize returns error code of last stmt execution, + ;; not of finalization; so just ignore + -> (void))) (define-sqlite sqlite3_bind_parameter_count (_fun _sqlite3_statement From 832d90bf93b5d44185b4bf31fb0e8a18353b7606 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Tue, 30 Oct 2012 12:43:41 -0400 Subject: [PATCH 074/221] fix doc typo closes PR 13216 --- collects/scribblings/reference/syntax-util.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/reference/syntax-util.scrbl b/collects/scribblings/reference/syntax-util.scrbl index f31f449105..d4125b3507 100644 --- a/collects/scribblings/reference/syntax-util.scrbl +++ b/collects/scribblings/reference/syntax-util.scrbl @@ -79,7 +79,7 @@ creates pattern variable definitions for the pattern variables of (define/with-syntax (px ...) #'(a b c)) (define/with-syntax (tmp ...) (generate-temporaries #'(px ...))) #'([tmp px] ...) -(define-pattern-variable name #'Alice) +(define/with-syntax name #'Alice) #'(hello name) ] } From 6b436cac5a8e28c3436b30816966e8d50207cd87 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 30 Oct 2012 14:05:59 -0400 Subject: [PATCH 075/221] Try running universe test with gracket on DrDr. Maybe serialization on the display will cause it to stop failing. --- collects/meta/props | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/meta/props b/collects/meta/props index 6181d6293d..b688fac53f 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -641,6 +641,7 @@ path/s is either such a string or a list of them. "collects/2htdp/tests/mouse-evt.rkt" drdr:command-line #f "collects/2htdp/tests/mp.rkt" drdr:command-line #f "collects/2htdp/tests/on-release-no-key.rkt" drdr:command-line (raco "make" *) +"collects/2htdp/tests/on-tick-universe-with-limit.rkt" drdr:command-line (gracket *) "collects/2htdp/tests/pad1.rkt" drdr:command-line (raco "make" *) "collects/2htdp/tests/perform-record.rkt" drdr:command-line (gracket *) "collects/2htdp/tests/perform-robby.rkt" drdr:command-line (gracket *) From d7bf6776450abf0524975a2b09e8568760621e77 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 30 Oct 2012 09:28:15 -0600 Subject: [PATCH 076/221] track import "shapes" as procedure or structure type Shape information allows the linker to check the importing module's compile-time expectation against the run-time value of its imports. The JIT, in turn, can rely on that checking to better inline structure-type predicates, etc., and to more directy call JIT-generated code across module boundaries. In addition to checking the "shape" of an import, the import's JITted vs. non-JITted state must be consistent. To prevent shifts in JIT state, the `eval-jit-enabled' parameter is now restricted in its effect to top-level bindings. --- collects/compiler/decompile.rkt | 15 +- collects/compiler/zo-marshal.rkt | 42 +++- collects/compiler/zo-parse.rkt | 28 +++ collects/compiler/zo-structs.rkt | 15 +- collects/scribblings/raco/decompile.scrbl | 14 +- collects/scribblings/raco/zo-struct.scrbl | 34 +++- collects/scribblings/reference/eval.scrbl | 3 +- collects/tests/racket/module.rktl | 2 +- collects/tests/racket/optimize.rktl | 20 ++ src/racket/src/compenv.c | 26 ++- src/racket/src/compile.c | 6 +- src/racket/src/cstartup.inc | 223 +++++++++++----------- src/racket/src/error.c | 4 +- src/racket/src/eval.c | 91 ++++----- src/racket/src/fun.c | 187 +++++++++++++----- src/racket/src/jit.c | 52 ++--- src/racket/src/jitcall.c | 2 +- src/racket/src/jitinline.c | 2 +- src/racket/src/jitprep.c | 4 +- src/racket/src/module.c | 59 ++++-- src/racket/src/mzclpf_post.inc | 1 - src/racket/src/mzmark_type.inc | 4 +- src/racket/src/mzmarksrc.c | 2 +- src/racket/src/optimize.c | 147 ++++++++------ src/racket/src/print.c | 3 +- src/racket/src/read.c | 4 +- src/racket/src/regexp.c | 7 - src/racket/src/resolve.c | 2 +- src/racket/src/schpriv.h | 39 ++-- src/racket/src/schrx.h | 1 - src/racket/src/schvers.h | 4 +- src/racket/src/struct.c | 74 ++++++- src/racket/src/stypes.h | 149 ++++++++------- src/racket/src/type.c | 1 + src/racket/src/validate.c | 46 +++-- 35 files changed, 870 insertions(+), 443 deletions(-) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index 1411e6d50f..2217060f65 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -78,7 +78,20 @@ (let-values ([(n b) (module-path-index-split modidx)]) (and (not n) (not b)))) (string->symbol (format "_~a" sym)) - (string->symbol (format "_~s@~s~a" sym (mpi->string modidx) + (string->symbol (format "_~s~a@~s~a" + sym + (match constantness + ['constant ":c"] + ['fixed ":f"] + [(function-shape a pm?) + (if pm? ":P" ":p")] + [(struct-type-shape c) ":t"] + [(constructor-shape a) ":mk"] + [(predicate-shape) ":?"] + [(accessor-shape c) ":ref"] + [(mutator-shape c) ":set!"] + [else ""]) + (mpi->string modidx) (if (zero? phase) "" (format "/~a" phase)))))] diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 9f39c208ad..b9e1333a99 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -604,13 +604,51 @@ [(? void?) (out-byte CPT_VOID out)] [(struct module-variable (modidx sym pos phase constantness)) + (define (to-sym n) (string->symbol (format "struct~a" n))) (out-byte CPT_MODULE_VAR out) (out-anything modidx out) (out-anything sym out) + (out-anything (cond + [(function-shape? constantness) + (let ([a (function-shape-arity constantness)]) + (cond + [(arity-at-least? a) + (bitwise-ior (arithmetic-shift (- (add1 (arity-at-least-value a))) 1) + (if (function-shape-preserves-marks? constantness) 1 0))] + [(list? a) + (string->symbol (apply + string-append + (add-between + (for/list ([a (in-list a)]) + (define n (if (arity-at-least? a) + (- (add1 (arity-at-least-value a))) + a)) + (number->string n)) + ":")))] + [else + (bitwise-ior (arithmetic-shift a 1) + (if (function-shape-preserves-marks? constantness) 1 0))]))] + [(struct-type-shape? constantness) + (to-sym (arithmetic-shift (struct-type-shape-field-count constantness) + 4))] + [(constructor-shape? constantness) + (to-sym (bitwise-ior 1 (arithmetic-shift (constructor-shape-arity constantness) + 4)))] + [(predicate-shape? constantness) (to-sym 2)] + [(accessor-shape? constantness) + (to-sym (bitwise-ior 3 (arithmetic-shift (accessor-shape-field-count constantness) + 4)))] + [(mutator-shape? constantness) + (to-sym (bitwise-ior 4 (arithmetic-shift (mutator-shape-field-count constantness) + 4)))] + [(struct-other-shape? constantness) + (to-sym 5)] + [else #f]) + out) (case constantness - [(constant) (out-number -4 out)] + [(#f) (void)] [(fixed) (out-number -5 out)] - [else (void)]) + [else (out-number -4 out)]) (unless (zero? phase) (out-number -2 out) (out-number phase out)) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 13856e48e0..18e7426b01 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -856,6 +856,7 @@ [(module-var) (let ([mod (read-compact cp)] [var (read-compact cp)] + [shape (read-compact cp)] [pos (read-compact-number cp)]) (let-values ([(flags mod-phase pos) (let loop ([pos pos]) @@ -869,6 +870,33 @@ [else (values 0 0 pos)]))]) (make-module-variable mod var pos mod-phase (cond + [shape + (cond + [(number? shape) + (define n (arithmetic-shift shape -1)) + (make-function-shape (if (negative? n) + (make-arity-at-least (sub1 (- n))) + n) + (odd? shape))] + [(and (symbol? shape) + (regexp-match? #rx"^struct" (symbol->string shape))) + (define n (string->number (substring (symbol->string shape) 6))) + (case (bitwise-and n #x7) + [(0) (make-struct-type-shape (arithmetic-shift n -3))] + [(1) (make-constructor-shape (arithmetic-shift n -3))] + [(2) (make-predicate-shape)] + [(3) (make-accessor-shape (arithmetic-shift n -3))] + [(4) (make-mutator-shape (arithmetic-shift n -3))] + [else (make-struct-other-shape)])] + [else + ;; parse symbol as ":"-separated sequence of arities + (make-function-shape + (for/list ([s (regexp-split #rx":" (symbol->string shape))]) + (define i (string->number s)) + (if (negative? i) + (make-arity-at-least (sub1 (- i))) + i)) + #f)])] [(not (zero? (bitwise-and #x1 flags))) 'constant] [(not (zero? (bitwise-and #x2 flags))) 'fixed] [else #f]))))] diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 3fc6b2c11d..a2aa9c284b 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -38,13 +38,26 @@ [(_ id . rest) (define-form-struct* id (id zo) . rest)])) +(define-form-struct function-shape ([arity procedure-arity?] + [preserves-marks? boolean?])) + +(define-form-struct struct-shape ()) +(define-form-struct (constructor-shape struct-shape) ([arity exact-nonnegative-integer?])) +(define-form-struct (predicate-shape struct-shape) ()) +(define-form-struct (accessor-shape struct-shape) ([field-count exact-nonnegative-integer?])) +(define-form-struct (mutator-shape struct-shape) ([field-count exact-nonnegative-integer?])) +(define-form-struct (struct-type-shape struct-shape) ([field-count exact-nonnegative-integer?])) +(define-form-struct (struct-other-shape struct-shape) ()) + ;; In toplevels of resove prefix: (define-form-struct global-bucket ([name symbol?])) ; top-level binding (define-form-struct module-variable ([modidx module-path-index?] [sym symbol?] [pos exact-integer?] [phase exact-nonnegative-integer?] - [constantness (or/c #f 'constant 'fixed)])) + [constantness (or/c #f 'constant 'fixed + function-shape? + struct-shape?)])) ;; Syntax object (define ((alist/c k? v?) l) diff --git a/collects/scribblings/raco/decompile.scrbl b/collects/scribblings/raco/decompile.scrbl index 8dd3d15d60..6ec50a4959 100644 --- a/collects/scribblings/raco/decompile.scrbl +++ b/collects/scribblings/raco/decompile.scrbl @@ -25,7 +25,19 @@ Many forms in the decompiled code, such as @racket[module], variables imported from other modules are prefixed with @litchar{_}, which helps expose the difference between uses of local variables versus other variables. Variables imported from other modules, - moreover, have a suffix that indicates the source module. + moreover, have a suffix starting with @litchar["@"] that indicates + the source module. Finally, imported variables with constantness + have a midfix: + @litchar{:c} to indicate constant shape across all instantiations, + @litchar{:f} to indicate a fixed value after initialization, + @litchar{:p} to indicate a procedure, + @litchar{:P} to indicate a procedure that preserves continuation + marks on return, + @litchar{:t} to indicate a structure type, + @litchar{:mk} to indicate a structure constructor, + @litchar{:?} to indicate a structure predicate, + @litchar{:ref} to indicate a structure accessor, or + @litchar{:set!} to indicate a structure mutator. Non-local variables are always accessed indirectly though an implicit @racketidfont{#%globals} or @racketidfont{#%modvars} variable that diff --git a/collects/scribblings/raco/zo-struct.scrbl b/collects/scribblings/raco/zo-struct.scrbl index 8114c00927..bfdb580fe4 100644 --- a/collects/scribblings/raco/zo-struct.scrbl +++ b/collects/scribblings/raco/zo-struct.scrbl @@ -73,19 +73,43 @@ structures that are produced by @racket[zo-parse] and consumed by [sym symbol?] [pos exact-integer?] [phase exact-nonnegative-integer?] - [constantness (or/c #f 'constant 'fixed)])]{ + [constantness (or/c #f 'constant 'fixed + function-shape? struct-shape?)])]{ Represents a top-level variable, and used only in a @racket[prefix]. The @racket[pos] may record the variable's offset within its module, or it can be @racket[-1] if the variable is always located by name. The @racket[phase] indicates the phase level of the definition within - its module. The @racket[constantness] field is either @racket['constant] + its module. The @racket[constantness] field is either @racket['constant], + a @racket[function-shape] value, or a @racket[struct-shape] value to indicate that - variable's value is always the same for every instantiation of its module, + variable's value is always the same for every instantiation of its module; @racket['fixed] to indicate - that it doesn't change within a particular instantiation of the module, + that it doesn't change within a particular instantiation of the module; or @racket[#f] to indicate that the variable's value - can change even for one particular instantiation of its module.} + can change even for one particular instantiation of its module.} +@defstruct+[function-shape + ([arity procedure-arity?] + [preserves-marks? boolean?])]{ + +Represents the shape of an expected import, which should be a function +having the arity specified by @racket[arity]. The +@racket[preserves-marks?] field is true if calling the function is +expected to leave continuation marks unchanged by the time it +returns.} + +@deftogether[( +@defstruct+[struct-shape ()] +@defstruct+[(struct-type-shape struct-shape) ([field-count exact-nonnegative-integer?])] +@defstruct+[(constructor-shape struct-shape) ([arity exact-nonnegative-integer?])] +@defstruct+[(predicate-shape struct-shape) ()] +@defstruct+[(accessor-shape struct-shape) ([field-count exact-nonnegative-integer?])] +@defstruct+[(mutator-shape struct-shape) ([field-count exact-nonnegative-integer?])] +@defstruct+[(struct-other-shape struct-shape) ()] +)]{ + +Represents the shape of an expected import as a structure-type +binding, constructor, etc.} @defstruct+[(stx zo) ([encoded wrapped?])]{ Wraps a syntax object in a @racket[prefix].} diff --git a/collects/scribblings/reference/eval.scrbl b/collects/scribblings/reference/eval.scrbl index d904eec47a..2e53ef1cb6 100644 --- a/collects/scribblings/reference/eval.scrbl +++ b/collects/scribblings/reference/eval.scrbl @@ -531,7 +531,8 @@ which allows such optimizations.} A @tech{parameter} that determines whether the native-code just-in-time compiler (@deftech{JIT}) is enabled for code (compiled or not) that is passed to the default evaluation handler. A true parameter value is effective -only on platforms for which the JIT is supported. +only on platforms for which the JIT is supported, and changing the value +from its initial setting affects only forms that are outside of @racket[module]. The default is @racket[#t], unless the JIT is not supported by the current platform, unless it is disabled through the diff --git a/collects/tests/racket/module.rktl b/collects/tests/racket/module.rktl index 4b616d2f8e..5be611c03b 100644 --- a/collects/tests/racket/module.rktl +++ b/collects/tests/racket/module.rktl @@ -875,7 +875,7 @@ ;; Triger JIT generation with constant function as `a': (go a-s) ;; Check that we don't crash when trying to use a different `a': - (err/rt-test (go am-s))) + (err/rt-test (go am-s) exn:fail?)) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/collects/tests/racket/optimize.rktl b/collects/tests/racket/optimize.rktl index 494a505208..9e47596018 100644 --- a/collects/tests/racket/optimize.rktl +++ b/collects/tests/racket/optimize.rktl @@ -1808,6 +1808,11 @@ (struct a (x y)) (struct b a (z))) +(module struct-c-for-optimize racket/base + (require 'struct-a-for-optimize) + (provide (struct-out c)) + (struct c a (q))) + (test-comp '(module m racket/base (require 'struct-a-for-optimize) (begin0 @@ -1830,6 +1835,21 @@ (b? (b-z (b 1 2 3)))) 5))) +(test-comp '(module m racket/base + (require 'struct-c-for-optimize) + (begin0 + (list (c? (c-q (c 1 2 3)))) + c? + c + c-q + (c 1 2 3) + 5)) + '(module m racket/base + (require 'struct-c-for-optimize) + (begin0 + (list (c? (c-q (c 1 2 3)))) + 5))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Check bytecode verification of lifted functions diff --git a/src/racket/src/compenv.c b/src/racket/src/compenv.c index fa036b7690..cf9d550c9c 100644 --- a/src/racket/src/compenv.c +++ b/src/racket/src/compenv.c @@ -925,7 +925,8 @@ static Scheme_Local *get_frame_loc(Scheme_Comp_Env *frame, Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modidx, Scheme_Object *stxsym, Scheme_Object *insp, - int pos, intptr_t mod_phase, int is_constant) + int pos, intptr_t mod_phase, int is_constant, + Scheme_Object *shape) /* is_constant == 2 => constant over all instantiations and phases */ { Scheme_Object *val; @@ -961,6 +962,7 @@ Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modid mv->insp = insp; mv->pos = pos; mv->mod_phase = (int)mod_phase; + mv->shape = shape; if (is_constant > 1) SCHEME_MODVAR_FLAGS(mv) |= SCHEME_MODVAR_CONST; @@ -1669,6 +1671,11 @@ static void check_taint(Scheme_Object *find_id) "cannot use identifier tainted by macro transformation"); } +static Scheme_Object *intern_struct_proc_shape(int shape) { + char buf[20]; + sprintf(buf, "struct%d", shape); + return scheme_intern_symbol(buf); +} /*********************************************************************/ /* @@ -1703,7 +1710,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, int j = 0, p = 0, modpos, skip_stops = 0, module_self_reference = 0, is_constant; Scheme_Bucket *b; Scheme_Object *val, *modidx, *modname, *src_find_id, *find_global_id, *mod_defn_phase; - Scheme_Object *find_id_sym = NULL, *rename_insp = NULL, *mod_constant = NULL; + Scheme_Object *find_id_sym = NULL, *rename_insp = NULL, *mod_constant = NULL, *shape; Scheme_Env *genv; intptr_t phase; @@ -1987,7 +1994,8 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, check_taint(src_find_id); return scheme_hash_module_variable(genv, genv->module->self_modidx, find_id, genv->module->insp, - -1, genv->mod_phase, 0); + -1, genv->mod_phase, 0, + NULL); } } else return NULL; @@ -1995,19 +2003,25 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, check_taint(src_find_id); + shape = NULL; if (mod_constant) { if (SAME_OBJ(mod_constant, scheme_constant_key)) is_constant = 2; else if (SAME_OBJ(mod_constant, scheme_fixed_key)) is_constant = 1; - else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_struct_proc_shape_type)) { + else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_proc_shape_type)) { + is_constant = 2; + shape = SCHEME_PTR_VAL(mod_constant); + } else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_struct_proc_shape_type)) { if (_inline_variant) *_inline_variant = mod_constant; is_constant = 2; + shape = intern_struct_proc_shape(SCHEME_PROC_SHAPE_MODE(mod_constant)); } else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_inline_variant_type)) { if (_inline_variant) *_inline_variant = mod_constant; is_constant = 2; + shape = scheme_get_or_check_procedure_shape(mod_constant, NULL); } else { if (flags & SCHEME_ELIM_CONST) return mod_constant; @@ -2028,7 +2042,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, return scheme_hash_module_variable(env->genv, modidx, find_id, (rename_insp ? rename_insp : genv->module->insp), modpos, SCHEME_INT_VAL(mod_defn_phase), - is_constant); + is_constant, shape); } if (!modname @@ -2039,7 +2053,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, return scheme_hash_module_variable(env->genv, genv->module->self_modidx, find_global_id, genv->module->insp, modpos, genv->mod_phase, - is_constant); + is_constant, shape); } b = scheme_bucket_from_table(genv->toplevel, (char *)find_global_id); diff --git a/src/racket/src/compile.c b/src/racket/src/compile.c index 21aa3e330d..9826dbb8e9 100644 --- a/src/racket/src/compile.c +++ b/src/racket/src/compile.c @@ -756,7 +756,8 @@ defn_targets_syntax (Scheme_Object *var, Scheme_Comp_Env *env, Scheme_Compile_In /* Create a module variable reference, so that idx is preserved: */ bucket = scheme_hash_module_variable(env->genv, env->genv->module->self_modidx, name, env->genv->module->insp, - -1, env->genv->mod_phase, 0); + -1, env->genv->mod_phase, 0, + NULL); } /* Get indirection through the prefix: */ bucket = scheme_register_toplevel_in_prefix(bucket, env, rec, drec, 0, NULL); @@ -5269,7 +5270,8 @@ top_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, preserved within the module. */ c = scheme_hash_module_variable(env->genv, env->genv->module->self_modidx, c, env->genv->module->insp, - -1, env->genv->mod_phase, 0); + -1, env->genv->mod_phase, 0, + NULL); } else { c = (Scheme_Object *)scheme_global_bucket(c, env->genv); } diff --git a/src/racket/src/cstartup.inc b/src/racket/src/cstartup.inc index e08d4734b2..83534ecb81 100644 --- a/src/racket/src/cstartup.inc +++ b/src/racket/src/cstartup.inc @@ -1,5 +1,5 @@ { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,51,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,52,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,51,0,0,0,1,0,0,10,0,14,0, 21,0,25,0,29,0,36,0,41,0,54,0,61,0,66,0,69,0,74,0,83, 0,87,0,93,0,107,0,121,0,124,0,130,0,134,0,136,0,147,0,149,0, @@ -99,7 +99,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 2028); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,51,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,52,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,126,0,0,0,1,0,0,8,0,21,0, 26,0,43,0,55,0,77,0,106,0,121,0,139,0,151,0,167,0,181,0,203, 0,219,0,236,0,2,1,13,1,19,1,28,1,35,1,42,1,54,1,70,1, @@ -112,7 +112,7 @@ 161,17,224,17,226,17,82,18,142,18,147,18,14,19,25,19,162,19,172,19,98, 21,120,21,129,21,122,22,140,22,154,22,175,22,187,22,232,22,239,22,1,23, 49,23,62,23,124,25,35,26,180,26,165,27,147,28,154,28,161,28,23,29,141, -29,241,30,66,31,149,31,234,31,169,32,195,32,68,33,0,0,241,37,0,0, +29,241,30,66,31,149,31,234,31,169,32,195,32,68,33,0,0,245,37,0,0, 67,35,37,117,116,105,108,115,72,112,97,116,104,45,115,116,114,105,110,103,63, 64,98,115,98,115,76,110,111,114,109,97,108,45,99,97,115,101,45,112,97,116, 104,71,114,101,114,111,111,116,45,112,97,116,104,1,20,102,105,110,100,45,101, @@ -373,7 +373,7 @@ 95,23,195,1,23,197,1,249,22,164,2,195,88,163,8,36,38,48,11,9,223, 3,33,96,28,197,86,94,20,18,159,11,80,158,42,49,193,20,18,159,11,80, 158,42,50,196,86,94,20,18,159,11,80,158,42,55,193,20,18,159,11,80,158, -42,56,196,193,28,193,80,158,38,49,80,158,38,55,248,22,9,88,163,8,32, +42,56,196,193,28,193,80,158,38,49,80,158,38,55,248,22,8,88,163,8,32, 37,8,40,8,240,0,240,94,0,9,224,1,2,33,97,0,7,35,114,120,34, 47,43,34,28,248,22,142,7,23,195,2,27,249,22,175,15,2,99,196,28,192, 28,249,22,191,3,248,22,103,195,248,22,181,3,248,22,145,7,198,249,22,7, @@ -522,64 +522,64 @@ 0,20,26,144,9,2,1,2,1,29,11,11,11,9,9,11,11,11,10,43,80, 158,36,36,20,113,159,40,16,30,2,2,2,3,2,4,2,5,2,6,2,7, 2,8,2,9,2,10,2,11,2,12,2,13,2,14,2,15,2,16,2,17,30, -2,20,76,102,105,110,100,45,108,105,110,107,115,45,112,97,116,104,33,4,30, -2,21,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,45, -107,101,121,6,30,2,21,1,23,101,120,116,101,110,100,45,112,97,114,97,109, -101,116,101,114,105,122,97,116,105,111,110,3,2,22,2,23,2,24,30,2,20, -1,21,101,120,99,101,112,116,105,111,110,45,104,97,110,100,108,101,114,45,107, -101,121,2,2,25,2,26,2,27,2,28,2,29,2,30,2,31,16,0,37,39, -36,16,0,36,16,13,2,9,2,10,2,8,2,3,2,26,2,24,2,22,2, -17,2,23,2,25,2,15,2,14,2,16,49,11,11,11,16,13,2,13,2,11, -2,31,2,12,2,6,2,30,2,29,2,4,2,28,2,7,2,27,2,2,2, -5,16,13,11,11,11,11,11,11,11,11,11,11,11,11,11,16,13,2,13,2, -11,2,31,2,12,2,6,2,30,2,29,2,4,2,28,2,7,2,27,2,2, -2,5,49,49,37,12,11,11,16,0,16,0,16,0,36,36,11,12,11,11,16, -0,16,0,16,0,36,36,16,30,20,15,16,2,32,0,88,163,36,37,45,11, -2,2,222,33,57,80,159,36,36,37,20,15,16,2,249,22,144,7,7,92,7, -92,80,159,36,37,37,20,15,16,2,88,163,36,37,54,38,2,4,223,0,33, -62,80,159,36,38,37,20,15,16,2,88,163,36,38,58,38,2,5,223,0,33, -64,80,159,36,39,37,20,15,16,2,20,25,96,2,6,88,163,8,36,39,8, -25,8,32,9,223,0,33,71,88,163,36,38,47,52,9,223,0,33,72,88,163, -36,37,46,52,9,223,0,33,73,80,159,36,40,37,20,15,16,2,27,248,22, -169,15,248,22,156,8,27,28,249,22,152,9,247,22,164,8,2,34,6,1,1, -59,6,1,1,58,250,22,190,7,6,14,14,40,91,94,126,97,93,42,41,126, -97,40,46,42,41,23,196,2,23,196,1,88,163,8,36,38,48,11,2,7,223, -0,33,77,80,159,36,41,37,20,15,16,2,32,0,88,163,8,36,38,47,11, -2,8,222,33,78,80,159,36,42,37,20,15,16,2,32,0,88,163,8,36,39, -48,11,2,9,222,33,80,80,159,36,43,37,20,15,16,2,32,0,88,163,8, -36,38,46,11,2,10,222,33,81,80,159,36,44,37,20,15,16,2,88,163,45, -39,49,8,128,16,2,11,223,0,33,83,80,159,36,45,37,20,15,16,2,88, -163,45,40,50,8,128,16,2,13,223,0,33,85,80,159,36,47,37,20,15,16, -2,248,22,160,15,70,108,105,110,107,115,45,102,105,108,101,80,159,36,48,37, -20,15,16,2,247,22,140,2,80,158,36,49,20,15,16,2,2,86,80,158,36, -50,20,15,16,2,248,80,159,37,52,37,88,163,36,36,49,8,240,16,0,6, -0,9,223,1,33,87,80,159,36,51,37,20,15,16,2,247,22,140,2,80,158, -36,55,20,15,16,2,2,86,80,158,36,56,20,15,16,2,88,163,36,37,44, -8,240,0,240,94,0,2,24,223,0,33,98,80,159,36,57,37,20,15,16,2, -88,163,36,38,56,8,240,0,0,128,0,2,25,223,0,33,100,80,159,36,59, -37,20,15,16,2,88,163,36,40,59,8,240,0,128,160,0,2,12,223,0,33, -111,80,159,36,46,37,20,15,16,2,32,0,88,163,36,39,50,11,2,26,222, -33,112,80,159,36,8,24,37,20,15,16,2,32,0,88,163,36,38,53,11,2, -27,222,33,113,80,159,36,8,25,37,20,15,16,2,32,0,88,163,36,38,54, -11,2,28,222,33,114,80,159,36,8,26,37,20,15,16,2,20,27,158,32,0, -88,163,36,37,44,11,2,29,222,33,115,32,0,88,163,36,37,44,11,2,29, -222,33,116,80,159,36,8,27,37,20,15,16,2,88,163,8,36,37,51,16,2, -52,8,240,0,64,0,0,2,41,223,0,33,117,80,159,36,8,30,39,20,15, -16,2,88,163,8,36,37,51,16,2,52,8,240,0,128,0,0,2,41,223,0, -33,118,80,159,36,8,31,39,20,15,16,2,88,163,8,36,37,56,16,4,52, -36,37,36,2,41,223,0,33,119,80,159,36,8,32,39,20,15,16,2,20,25, -96,2,30,88,163,36,36,53,16,2,8,32,8,240,0,64,0,0,9,223,0, -33,120,88,163,36,37,54,16,2,8,32,8,240,0,128,0,0,9,223,0,33, -121,88,163,36,38,55,16,4,8,32,36,37,36,9,223,0,33,122,80,159,36, -8,28,37,20,15,16,2,88,163,8,36,37,55,16,4,36,42,38,36,2,41, -223,0,33,123,80,159,36,8,33,39,20,15,16,2,88,163,8,36,39,54,16, -4,52,36,38,36,2,31,223,0,33,125,80,159,36,8,29,37,95,29,94,2, -18,68,35,37,107,101,114,110,101,108,11,29,94,2,18,69,35,37,109,105,110, -45,115,116,120,11,2,20,9,9,9,36,0}; - EVAL_ONE_SIZED_STR((char *)expr, 10007); +2,20,76,102,105,110,100,45,108,105,110,107,115,45,112,97,116,104,33,11,4, +30,2,21,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110, +45,107,101,121,11,6,30,2,21,1,23,101,120,116,101,110,100,45,112,97,114, +97,109,101,116,101,114,105,122,97,116,105,111,110,11,3,2,22,2,23,2,24, +30,2,20,1,21,101,120,99,101,112,116,105,111,110,45,104,97,110,100,108,101, +114,45,107,101,121,11,2,2,25,2,26,2,27,2,28,2,29,2,30,2,31, +16,0,37,39,36,16,0,36,16,13,2,9,2,10,2,8,2,3,2,26,2, +24,2,22,2,17,2,23,2,25,2,15,2,14,2,16,49,11,11,11,16,13, +2,13,2,11,2,31,2,12,2,6,2,30,2,29,2,4,2,28,2,7,2, +27,2,2,2,5,16,13,11,11,11,11,11,11,11,11,11,11,11,11,11,16, +13,2,13,2,11,2,31,2,12,2,6,2,30,2,29,2,4,2,28,2,7, +2,27,2,2,2,5,49,49,37,12,11,11,16,0,16,0,16,0,36,36,11, +12,11,11,16,0,16,0,16,0,36,36,16,30,20,15,16,2,32,0,88,163, +36,37,45,11,2,2,222,33,57,80,159,36,36,37,20,15,16,2,249,22,144, +7,7,92,7,92,80,159,36,37,37,20,15,16,2,88,163,36,37,54,38,2, +4,223,0,33,62,80,159,36,38,37,20,15,16,2,88,163,36,38,58,38,2, +5,223,0,33,64,80,159,36,39,37,20,15,16,2,20,25,96,2,6,88,163, +8,36,39,8,25,8,32,9,223,0,33,71,88,163,36,38,47,52,9,223,0, +33,72,88,163,36,37,46,52,9,223,0,33,73,80,159,36,40,37,20,15,16, +2,27,248,22,169,15,248,22,156,8,27,28,249,22,152,9,247,22,164,8,2, +34,6,1,1,59,6,1,1,58,250,22,190,7,6,14,14,40,91,94,126,97, +93,42,41,126,97,40,46,42,41,23,196,2,23,196,1,88,163,8,36,38,48, +11,2,7,223,0,33,77,80,159,36,41,37,20,15,16,2,32,0,88,163,8, +36,38,47,11,2,8,222,33,78,80,159,36,42,37,20,15,16,2,32,0,88, +163,8,36,39,48,11,2,9,222,33,80,80,159,36,43,37,20,15,16,2,32, +0,88,163,8,36,38,46,11,2,10,222,33,81,80,159,36,44,37,20,15,16, +2,88,163,45,39,49,8,128,16,2,11,223,0,33,83,80,159,36,45,37,20, +15,16,2,88,163,45,40,50,8,128,16,2,13,223,0,33,85,80,159,36,47, +37,20,15,16,2,248,22,160,15,70,108,105,110,107,115,45,102,105,108,101,80, +159,36,48,37,20,15,16,2,247,22,140,2,80,158,36,49,20,15,16,2,2, +86,80,158,36,50,20,15,16,2,248,80,159,37,52,37,88,163,36,36,49,8, +240,16,0,6,0,9,223,1,33,87,80,159,36,51,37,20,15,16,2,247,22, +140,2,80,158,36,55,20,15,16,2,2,86,80,158,36,56,20,15,16,2,88, +163,36,37,44,8,240,0,240,94,0,2,24,223,0,33,98,80,159,36,57,37, +20,15,16,2,88,163,36,38,56,8,240,0,0,128,0,2,25,223,0,33,100, +80,159,36,59,37,20,15,16,2,88,163,36,40,59,8,240,0,128,160,0,2, +12,223,0,33,111,80,159,36,46,37,20,15,16,2,32,0,88,163,36,39,50, +11,2,26,222,33,112,80,159,36,8,24,37,20,15,16,2,32,0,88,163,36, +38,53,11,2,27,222,33,113,80,159,36,8,25,37,20,15,16,2,32,0,88, +163,36,38,54,11,2,28,222,33,114,80,159,36,8,26,37,20,15,16,2,20, +27,158,32,0,88,163,36,37,44,11,2,29,222,33,115,32,0,88,163,36,37, +44,11,2,29,222,33,116,80,159,36,8,27,37,20,15,16,2,88,163,8,36, +37,51,16,2,52,8,240,0,64,0,0,2,41,223,0,33,117,80,159,36,8, +30,39,20,15,16,2,88,163,8,36,37,51,16,2,52,8,240,0,128,0,0, +2,41,223,0,33,118,80,159,36,8,31,39,20,15,16,2,88,163,8,36,37, +56,16,4,52,36,37,36,2,41,223,0,33,119,80,159,36,8,32,39,20,15, +16,2,20,25,96,2,30,88,163,36,36,53,16,2,8,32,8,240,0,64,0, +0,9,223,0,33,120,88,163,36,37,54,16,2,8,32,8,240,0,128,0,0, +9,223,0,33,121,88,163,36,38,55,16,4,8,32,36,37,36,9,223,0,33, +122,80,159,36,8,28,37,20,15,16,2,88,163,8,36,37,55,16,4,36,42, +38,36,2,41,223,0,33,123,80,159,36,8,33,39,20,15,16,2,88,163,8, +36,39,54,16,4,52,36,38,36,2,31,223,0,33,125,80,159,36,8,29,37, +95,29,94,2,18,68,35,37,107,101,114,110,101,108,11,29,94,2,18,69,35, +37,109,105,110,45,115,116,120,11,2,20,9,9,9,36,0}; + EVAL_ONE_SIZED_STR((char *)expr, 10011); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,51,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,52,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,12,0,0,0,1,0,0,15,0,40,0, 57,0,75,0,97,0,120,0,140,0,162,0,169,0,176,0,183,0,0,0,179, 1,0,0,74,35,37,112,108,97,99,101,45,115,116,114,117,99,116,1,23,115, @@ -606,7 +606,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 501); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,51,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,52,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,89,0,0,0,1,0,0,7,0,18,0, 45,0,51,0,60,0,67,0,89,0,102,0,128,0,145,0,167,0,175,0,187, 0,202,0,218,0,236,0,0,1,12,1,28,1,51,1,63,1,94,1,101,1, @@ -616,7 +616,7 @@ 12,186,12,249,12,12,13,26,13,184,13,197,13,75,14,117,15,199,15,63,16, 120,16,128,16,137,16,160,17,166,17,194,17,207,17,113,18,120,18,174,18,196, 18,216,18,15,19,25,19,39,19,76,19,174,19,176,19,26,20,213,27,10,28, -34,28,58,28,0,0,46,32,0,0,66,35,37,98,111,111,116,70,100,108,108, +34,28,58,28,0,0,56,32,0,0,66,35,37,98,111,111,116,70,100,108,108, 45,115,117,102,102,105,120,1,25,100,101,102,97,117,108,116,45,108,111,97,100, 47,117,115,101,45,99,111,109,112,105,108,101,100,65,113,117,111,116,101,68,35, 37,112,97,114,97,109,122,29,94,2,4,2,5,11,1,20,112,97,114,97,109, @@ -962,57 +962,58 @@ 249,22,33,11,80,159,39,57,37,20,18,159,11,80,158,36,55,248,80,159,37, 8,27,37,249,22,33,11,80,159,39,57,37,159,36,20,113,159,36,16,1,11, 16,0,20,26,144,9,2,1,2,1,29,11,11,11,9,9,11,11,11,10,38, -80,158,36,36,20,113,159,41,16,28,2,2,2,3,30,2,6,2,7,6,30, -2,6,1,23,101,120,116,101,110,100,45,112,97,114,97,109,101,116,101,114,105, -122,97,116,105,111,110,3,30,2,8,72,112,97,116,104,45,115,116,114,105,110, -103,63,196,11,2,9,30,2,8,71,114,101,114,111,111,116,45,112,97,116,104, -196,12,30,2,8,75,112,97,116,104,45,97,100,100,45,115,117,102,102,105,120, -196,8,2,10,2,11,2,12,2,13,2,14,2,15,2,16,2,17,2,18,2, -19,2,20,2,21,2,22,30,2,23,2,7,6,30,2,8,79,112,97,116,104, -45,114,101,112,108,97,99,101,45,115,117,102,102,105,120,196,10,30,2,8,73, -102,105,110,100,45,99,111,108,45,102,105,108,101,196,3,30,2,8,76,110,111, -114,109,97,108,45,99,97,115,101,45,112,97,116,104,196,7,2,24,2,25,30, -2,23,74,114,101,112,97,114,97,109,101,116,101,114,105,122,101,7,16,0,37, -39,36,16,0,36,16,15,2,16,2,17,2,9,2,13,2,18,2,19,2,12, -2,3,2,11,2,2,2,14,2,15,2,10,2,20,2,22,51,11,11,11,16, -3,2,24,2,21,2,25,16,3,11,11,11,16,3,2,24,2,21,2,25,39, -39,37,12,11,11,16,0,16,0,16,0,36,36,11,12,11,11,16,0,16,0, -16,0,36,36,16,23,20,15,16,2,248,22,164,8,69,115,111,45,115,117,102, -102,105,120,80,159,36,36,37,20,15,16,2,88,163,36,38,8,43,8,189,3, -2,3,223,0,33,54,80,159,36,37,37,20,15,16,2,32,0,88,163,8,36, -41,52,11,2,10,222,33,55,80,159,36,44,37,20,15,16,2,20,27,158,32, -0,88,163,8,36,37,42,11,2,11,222,192,32,0,88,163,8,36,37,42,11, -2,11,222,192,80,159,36,45,37,20,15,16,2,247,22,143,2,80,159,36,41, -37,20,15,16,2,8,128,8,80,159,36,46,37,20,15,16,2,249,22,168,8, -8,128,8,11,80,159,36,47,37,20,15,16,2,88,163,8,36,37,50,8,128, -32,2,14,223,0,33,56,80,159,36,48,37,20,15,16,2,88,163,8,36,38, -55,8,128,32,2,15,223,0,33,57,80,159,36,49,37,20,15,16,2,247,22, -75,80,159,36,50,37,20,15,16,2,248,22,18,74,109,111,100,117,108,101,45, -108,111,97,100,105,110,103,80,159,36,51,37,20,15,16,2,11,80,158,36,52, -20,15,16,2,11,80,158,36,53,20,15,16,2,32,0,88,163,36,38,8,25, -11,2,20,222,33,63,80,159,36,54,37,20,15,16,2,11,80,158,36,55,20, -15,16,2,88,164,8,34,37,45,8,240,0,0,40,0,1,21,112,114,101,112, -45,112,108,97,110,101,116,45,114,101,115,111,108,118,101,114,33,37,224,1,0, -33,64,80,159,36,8,28,39,20,15,16,2,88,163,36,37,50,8,240,0,0, -3,0,67,103,101,116,45,100,105,114,223,0,33,65,80,159,36,8,29,39,20, -15,16,2,88,163,36,37,49,8,240,0,0,64,0,72,112,97,116,104,45,115, -115,45,62,114,107,116,223,0,33,66,80,159,36,8,30,39,20,15,16,2,88, -163,8,36,37,45,8,240,0,0,4,0,9,223,0,33,67,80,159,36,8,31, -39,20,15,16,2,88,163,36,37,45,8,240,0,128,0,0,9,223,0,33,68, -80,159,36,8,32,39,20,15,16,2,27,11,20,19,158,36,90,159,37,10,89, -161,37,36,10,20,25,96,2,22,88,163,8,36,38,54,8,32,9,224,2,1, -33,69,88,163,36,39,49,11,9,223,0,33,70,88,163,36,40,8,32,16,4, -8,240,44,240,0,0,8,240,204,241,0,0,37,36,9,224,2,1,33,85,207, -80,159,36,56,37,20,15,16,2,88,163,36,36,45,16,2,8,130,8,8,184, -32,2,24,223,0,33,86,80,159,36,8,25,37,20,15,16,2,20,27,158,88, -163,8,36,36,45,16,2,36,8,168,32,2,25,223,0,33,87,88,163,8,36, -36,45,16,2,36,8,168,32,2,25,223,0,33,88,80,159,36,8,26,37,96, -29,94,2,4,68,35,37,107,101,114,110,101,108,11,29,94,2,4,69,35,37, -109,105,110,45,115,116,120,11,2,8,2,23,9,9,9,36,0}; - EVAL_ONE_SIZED_STR((char *)expr, 8458); +80,158,36,36,20,113,159,41,16,28,2,2,2,3,30,2,6,2,7,11,6, +30,2,6,1,23,101,120,116,101,110,100,45,112,97,114,97,109,101,116,101,114, +105,122,97,116,105,111,110,11,3,30,2,8,72,112,97,116,104,45,115,116,114, +105,110,103,63,38,196,11,2,9,30,2,8,71,114,101,114,111,111,116,45,112, +97,116,104,40,196,12,30,2,8,75,112,97,116,104,45,97,100,100,45,115,117, +102,102,105,120,40,196,8,2,10,2,11,2,12,2,13,2,14,2,15,2,16, +2,17,2,18,2,19,2,20,2,21,2,22,30,2,23,2,7,11,6,30,2, +8,79,112,97,116,104,45,114,101,112,108,97,99,101,45,115,117,102,102,105,120, +40,196,10,30,2,8,73,102,105,110,100,45,99,111,108,45,102,105,108,101,44, +196,3,30,2,8,76,110,111,114,109,97,108,45,99,97,115,101,45,112,97,116, +104,38,196,7,2,24,2,25,30,2,23,74,114,101,112,97,114,97,109,101,116, +101,114,105,122,101,11,7,16,0,37,39,36,16,0,36,16,15,2,16,2,17, +2,9,2,13,2,18,2,19,2,12,2,3,2,11,2,2,2,14,2,15,2, +10,2,20,2,22,51,11,11,11,16,3,2,24,2,21,2,25,16,3,11,11, +11,16,3,2,24,2,21,2,25,39,39,37,12,11,11,16,0,16,0,16,0, +36,36,11,12,11,11,16,0,16,0,16,0,36,36,16,23,20,15,16,2,248, +22,164,8,69,115,111,45,115,117,102,102,105,120,80,159,36,36,37,20,15,16, +2,88,163,36,38,8,43,8,189,3,2,3,223,0,33,54,80,159,36,37,37, +20,15,16,2,32,0,88,163,8,36,41,52,11,2,10,222,33,55,80,159,36, +44,37,20,15,16,2,20,27,158,32,0,88,163,8,36,37,42,11,2,11,222, +192,32,0,88,163,8,36,37,42,11,2,11,222,192,80,159,36,45,37,20,15, +16,2,247,22,143,2,80,159,36,41,37,20,15,16,2,8,128,8,80,159,36, +46,37,20,15,16,2,249,22,168,8,8,128,8,11,80,159,36,47,37,20,15, +16,2,88,163,8,36,37,50,8,128,32,2,14,223,0,33,56,80,159,36,48, +37,20,15,16,2,88,163,8,36,38,55,8,128,32,2,15,223,0,33,57,80, +159,36,49,37,20,15,16,2,247,22,75,80,159,36,50,37,20,15,16,2,248, +22,18,74,109,111,100,117,108,101,45,108,111,97,100,105,110,103,80,159,36,51, +37,20,15,16,2,11,80,158,36,52,20,15,16,2,11,80,158,36,53,20,15, +16,2,32,0,88,163,36,38,8,25,11,2,20,222,33,63,80,159,36,54,37, +20,15,16,2,11,80,158,36,55,20,15,16,2,88,164,8,34,37,45,8,240, +0,0,40,0,1,21,112,114,101,112,45,112,108,97,110,101,116,45,114,101,115, +111,108,118,101,114,33,37,224,1,0,33,64,80,159,36,8,28,39,20,15,16, +2,88,163,36,37,50,8,240,0,0,3,0,67,103,101,116,45,100,105,114,223, +0,33,65,80,159,36,8,29,39,20,15,16,2,88,163,36,37,49,8,240,0, +0,64,0,72,112,97,116,104,45,115,115,45,62,114,107,116,223,0,33,66,80, +159,36,8,30,39,20,15,16,2,88,163,8,36,37,45,8,240,0,0,4,0, +9,223,0,33,67,80,159,36,8,31,39,20,15,16,2,88,163,36,37,45,8, +240,0,128,0,0,9,223,0,33,68,80,159,36,8,32,39,20,15,16,2,27, +11,20,19,158,36,90,159,37,10,89,161,37,36,10,20,25,96,2,22,88,163, +8,36,38,54,8,32,9,224,2,1,33,69,88,163,36,39,49,11,9,223,0, +33,70,88,163,36,40,8,32,16,4,8,240,44,240,0,0,8,240,204,241,0, +0,37,36,9,224,2,1,33,85,207,80,159,36,56,37,20,15,16,2,88,163, +36,36,45,16,2,8,130,8,8,184,32,2,24,223,0,33,86,80,159,36,8, +25,37,20,15,16,2,20,27,158,88,163,8,36,36,45,16,2,36,8,168,32, +2,25,223,0,33,87,88,163,8,36,36,45,16,2,36,8,168,32,2,25,223, +0,33,88,80,159,36,8,26,37,96,29,94,2,4,68,35,37,107,101,114,110, +101,108,11,29,94,2,4,69,35,37,109,105,110,45,115,116,120,11,2,8,2, +23,9,9,9,36,0}; + EVAL_ONE_SIZED_STR((char *)expr, 8468); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,51,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,52,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,11,0,0,0,1,0,0,10,0,16,0, 29,0,44,0,58,0,78,0,90,0,104,0,118,0,170,0,0,0,98,1,0, 0,69,35,37,98,117,105,108,116,105,110,65,113,117,111,116,101,29,94,2,2, diff --git a/src/racket/src/error.c b/src/racket/src/error.c index 837ac566ce..c4b02768ec 100644 --- a/src/racket/src/error.c +++ b/src/racket/src/error.c @@ -1307,7 +1307,7 @@ void scheme_wrong_count_m(const char *name, int minc, int maxc, #ifdef MZ_USE_JIT } else if (SAME_TYPE(SCHEME_TYPE((Scheme_Object *)name), scheme_native_closure_type)) { Scheme_Object *pa; - pa = scheme_get_native_arity((Scheme_Object *)name); + pa = scheme_get_native_arity((Scheme_Object *)name, -1); if (SCHEME_BOXP(pa)) { pa = SCHEME_BOX_VAL(pa); is_method = 1; @@ -1405,7 +1405,7 @@ char *scheme_make_arity_expect_string(Scheme_Object *proc, #ifdef MZ_USE_JIT } else if (SAME_TYPE(SCHEME_TYPE((Scheme_Object *)proc), scheme_native_closure_type)) { Scheme_Object *pa; - pa = scheme_get_native_arity((Scheme_Object *)proc); + pa = scheme_get_native_arity((Scheme_Object *)proc, -1); if (SCHEME_BOXP(pa)) { pa = SCHEME_BOX_VAL(pa); } diff --git a/src/racket/src/eval.c b/src/racket/src/eval.c index ac047cfc4b..ddd3e8223d 100644 --- a/src/racket/src/eval.c +++ b/src/racket/src/eval.c @@ -787,8 +787,7 @@ static Scheme_Object *link_module_variable(Scheme_Object *modidx, int pos, int mod_phase, Scheme_Env *env, Scheme_Object **exprs, int which, - char *import_map, - int flags) + int flags, Scheme_Object *shape) { Scheme_Object *modname; Scheme_Env *menv; @@ -831,11 +830,20 @@ static Scheme_Object *link_module_variable(Scheme_Object *modidx, if (self) { exprs[which] = varname; } else { - Scheme_Object *v = modname; - if (mod_phase != 0) - v = scheme_make_pair(v, scheme_make_integer(mod_phase)); - v = scheme_make_pair(varname, v); - exprs[which] = v; + if (flags & SCHEME_MODVAR_CONST) { + Scheme_Object *v; + v = scheme_make_vector((mod_phase != 0) ? 4 : 3, modname); + SCHEME_VEC_ELS(v)[1] = varname; + SCHEME_VEC_ELS(v)[2] = (shape ? shape : scheme_false); + if (mod_phase != 0) + SCHEME_VEC_ELS(v)[3] = scheme_make_integer(mod_phase); + } else { + Scheme_Object *v = modname; + if (mod_phase != 0) + v = scheme_make_pair(v, scheme_make_integer(mod_phase)); + v = scheme_make_pair(varname, v); + exprs[which] = v; + } } } @@ -844,17 +852,15 @@ static Scheme_Object *link_module_variable(Scheme_Object *modidx, const char *bad_reason = NULL; if (!bkt->val) { - bad_reason = "uninitialized"; + bad_reason = "is uninitialized"; } else if (flags) { if (flags & SCHEME_MODVAR_CONST) { - /* The fact that the link target is consistent is a fine - sanity check, but the check is not good enough for the JIT - to rely on it. To be useful for the JIT, we'd have to make - sure that every link goes to the same value. Since we can't - currently guarantee that, all the JIT assumes is that the - value is "fixed". */ if (!(((Scheme_Bucket_With_Flags *)bkt)->flags & GLOB_IS_CONSISTENT)) - bad_reason = "not constant across all instantiations"; + bad_reason = "is not a procedure or structure-type constant across all instantiations"; + else if (shape && SCHEME_TRUEP(shape)) { + if (!scheme_get_or_check_procedure_shape(bkt->val, shape)) + bad_reason = "has the wrong procedure or structure-type shape"; + } } else { if (!(((Scheme_Bucket_With_Flags *)bkt)->flags & GLOB_IS_IMMUTATED)) bad_reason = "not constant"; @@ -864,7 +870,7 @@ static Scheme_Object *link_module_variable(Scheme_Object *modidx, if (bad_reason) { scheme_wrong_syntax("link", NULL, varname, "bad variable linkage;\n" - " reference to a variable that is %s\n" + " reference to a variable that %s\n" " reference phase level: %d\n" " variable module: %D\n" " variable phase: %d\n" @@ -880,17 +886,13 @@ static Scheme_Object *link_module_variable(Scheme_Object *modidx, ((Scheme_Bucket_With_Flags *)bkt)->flags |= GLOB_IS_LINKED; } - if (!self && !(import_map[which >> 3] & (1 << (which & 0x7)))) - import_map[which >> 3] |= (1 << (which & 0x7)); - return (Scheme_Object *)bkt; } static Scheme_Object *link_toplevel(Scheme_Object **exprs, int which, Scheme_Env *env, Scheme_Object *src_modidx, Scheme_Object *dest_modidx, - Scheme_Object *insp, - char *import_map) + Scheme_Object *insp) { Scheme_Object *expr = exprs[which]; @@ -903,10 +905,10 @@ static Scheme_Object *link_toplevel(Scheme_Object **exprs, int which, Scheme_Env ((Scheme_Bucket_With_Home *)b)->home_link = (Scheme_Object *)env; } return (Scheme_Object *)b; - } else if (SCHEME_PAIRP(expr) || SCHEME_SYMBOLP(expr)) { - /* Simplified module reference */ - Scheme_Object *modname, *varname; - int mod_phase = 0; + } else if (SCHEME_PAIRP(expr) || SCHEME_SYMBOLP(expr) || SCHEME_VECTORP(expr)) { + /* Simplified module reference (as installed by link_module_variable) */ + Scheme_Object *modname, *varname, *shape; + int mod_phase = 0, flags = 0; if (SCHEME_SYMBOLP(expr)) { if (!env->module) { /* compiled as a module variable, but instantiated in a non-module @@ -917,13 +919,20 @@ static Scheme_Object *link_toplevel(Scheme_Object **exprs, int which, Scheme_Env modname = env->module->modname; mod_phase = env->mod_phase; } - } else { + } else if (SCHEME_PAIRP(expr)) { varname = SCHEME_CAR(expr); modname = SCHEME_CDR(expr); if (SCHEME_PAIRP(modname)) { mod_phase = SCHEME_INT_VAL(SCHEME_CDR(modname)); modname = SCHEME_CAR(modname); - } + } + } else { + modname = SCHEME_VEC_ELS(expr)[0]; + varname = SCHEME_VEC_ELS(expr)[1]; + flags = SCHEME_MODVAR_CONST; + shape = SCHEME_VEC_ELS(expr)[2]; + if (SCHEME_VEC_SIZE(expr) > 3) + mod_phase = SCHEME_INT_VAL(SCHEME_VEC_ELS(expr)[3]); } return link_module_variable(modname, varname, @@ -931,8 +940,7 @@ static Scheme_Object *link_toplevel(Scheme_Object **exprs, int which, Scheme_Env -1, mod_phase, env, NULL, 0, - import_map, - 0); + flags, shape); } else if (SAME_TYPE(SCHEME_TYPE(expr), scheme_variable_type)) { Scheme_Bucket *b = (Scheme_Bucket *)expr; Scheme_Env *home; @@ -948,7 +956,7 @@ static Scheme_Object *link_toplevel(Scheme_Object **exprs, int which, Scheme_Env -1, home->mod_phase, env, exprs, which, - import_map, 0); + 0, NULL); } else { Module_Variable *mv = (Module_Variable *)expr; @@ -962,8 +970,7 @@ static Scheme_Object *link_toplevel(Scheme_Object **exprs, int which, Scheme_Env mv->pos, mv->mod_phase, env, exprs, which, - import_map, - SCHEME_MODVAR_FLAGS(mv) & 0x3); + SCHEME_MODVAR_FLAGS(mv) & 0x3, mv->shape); } } @@ -1900,7 +1907,7 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro, is_st = 0; else is_st = !!scheme_is_simple_make_struct_type(vals_expr, g, 1, 1, - NULL, NULL, NULL, NULL, + NULL, NULL, NULL, NULL, MZ_RUNSTACK, 0, NULL, NULL, 5); @@ -5495,7 +5502,10 @@ Scheme_Object *scheme_eval_clone(Scheme_Object *expr) reduce the overhead of cross-module references. */ switch (SCHEME_TYPE(expr)) { case scheme_module_type: - return scheme_module_eval_clone(expr); + if (scheme_startup_use_jit) + return scheme_module_jit(expr); + else + return scheme_module_eval_clone(expr); break; case scheme_define_syntaxes_type: case scheme_begin_for_syntax_type: @@ -5543,8 +5553,7 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp, { Scheme_Object **rs_save, **rs, *v; Scheme_Prefix *pf; - char *import_map; - int i, j, tl_map_len, import_map_len; + int i, j, tl_map_len; rs_save = rs = MZ_RUNSTACK; @@ -5565,13 +5574,6 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp, i += rp->num_lifts; tl_map_len = ((rp->num_toplevels + rp->num_lifts) + 31) / 32; - import_map_len = (rp->num_toplevels + 7) / 8; - - if (import_map_len) { - import_map = GC_malloc_atomic(import_map_len); - memset(import_map, 0, import_map_len); - } else - import_map = NULL; pf = scheme_malloc_tagged(sizeof(Scheme_Prefix) + ((i-mzFLEX_DELTA) * sizeof(Scheme_Object *)) @@ -5580,7 +5582,6 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp, pf->num_slots = i; pf->num_toplevels = rp->num_toplevels; pf->num_stxes = rp->num_stxes; - pf->import_map = import_map; --rs; MZ_RUNSTACK = rs; rs[0] = (Scheme_Object *)pf; @@ -5588,7 +5589,7 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp, for (i = 0; i < rp->num_toplevels; i++) { v = rp->toplevels[i]; if (genv || SCHEME_FALSEP(v)) - v = link_toplevel(rp->toplevels, i, genv ? genv : dummy_env, src_modidx, now_modidx, insp, import_map); + v = link_toplevel(rp->toplevels, i, genv ? genv : dummy_env, src_modidx, now_modidx, insp); pf->a[i] = v; } diff --git a/src/racket/src/fun.c b/src/racket/src/fun.c index ffa773d5f0..a251f97e59 100644 --- a/src/racket/src/fun.c +++ b/src/racket/src/fun.c @@ -1918,14 +1918,18 @@ Scheme_Object *scheme_syntax_taint_rearm(Scheme_Object *stx, Scheme_Object *from /* arity */ /*========================================================================*/ -Scheme_Object *scheme_make_arity(mzshort mina, mzshort maxa) +static Scheme_Object *make_arity(mzshort mina, mzshort maxa, int mode) { if (mina == maxa) return scheme_make_integer(mina); else if (maxa == -1) { - Scheme_Object *p[1]; - p[0] = scheme_make_integer(mina); - return scheme_make_struct_instance(scheme_arity_at_least, 1, p); + if (mode == -3) { + return scheme_make_integer(-(mina+1)); + } else { + Scheme_Object *p[1]; + p[0] = scheme_make_integer(mina); + return scheme_make_struct_instance(scheme_arity_at_least, 1, p); + } } else { int i; Scheme_Object *l = scheme_null; @@ -1938,13 +1942,18 @@ Scheme_Object *scheme_make_arity(mzshort mina, mzshort maxa) } } -static Scheme_Object *clone_arity(Scheme_Object *a, int delta) +Scheme_Object *scheme_make_arity(mzshort mina, mzshort maxa) +{ + return make_arity(mina, maxa, -1); +} + +static Scheme_Object *clone_arity(Scheme_Object *a, int delta, int mode) { if (SCHEME_PAIRP(a)) { Scheme_Object *m, *l; m = scheme_copy_list(a); for (l = m; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - a = clone_arity(SCHEME_CAR(l), delta); + a = clone_arity(SCHEME_CAR(l), delta, mode); SCHEME_CAR(l) = a; } return m; @@ -1953,8 +1962,12 @@ static Scheme_Object *clone_arity(Scheme_Object *a, int delta) a = scheme_struct_ref(a, 0); if (delta) a = scheme_bin_minus(a, scheme_make_integer(delta)); - p[0] = a; - return scheme_make_struct_instance(scheme_arity_at_least, 1, p); + if (mode == -3) { + return scheme_make_integer(-(SCHEME_INT_VAL(a)+1)); + } else { + p[0] = a; + return scheme_make_struct_instance(scheme_arity_at_least, 1, p); + } } else if (SCHEME_NULLP(a)) return a; else if (delta) @@ -1965,7 +1978,8 @@ static Scheme_Object *clone_arity(Scheme_Object *a, int delta) static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Object *bign, int inc_ok) /* a == -1 => get arity - a == -2 => check for allowing bignum */ + a == -2 => check for allowing bignum + a == -3 => like -1, but alternate representation using negative numbers for arity-at-least */ { Scheme_Type type; mzshort mina, maxa; @@ -1995,20 +2009,25 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob } else if (type == scheme_cont_type || type == scheme_escaping_cont_type) { mina = 0; maxa = -1; - } else if (type == scheme_case_closure_type) { + } else if ((type == scheme_case_closure_type) + || (type == scheme_case_lambda_sequence_type)) { Scheme_Case_Lambda *seq; Scheme_Closure_Data *data; int i; Scheme_Object *first, *last = NULL, *v; - if (a == -1) + if ((a == -1) || (a == -3)) first = scheme_null; else first = scheme_false; seq = (Scheme_Case_Lambda *)p; for (i = 0; i < seq->count; i++) { - data = SCHEME_COMPILED_CLOS_CODE(seq->array[i]); + v = seq->array[i]; + if (SAME_TYPE(SCHEME_TYPE(v), scheme_unclosed_procedure_type)) + data = (Scheme_Closure_Data *)v; + else + data = SCHEME_COMPILED_CLOS_CODE(v); mina = maxa = data->num_params; if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) { if (mina) @@ -2028,7 +2047,7 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob if (maxa > 0) maxa -= drop; - v = scheme_make_pair(scheme_make_arity(mina, maxa), scheme_null); + v = scheme_make_pair(make_arity(mina, maxa, a), scheme_null); if (!last) first = v; else @@ -2052,8 +2071,8 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob if (drop) bign = scheme_bin_plus(bign, scheme_make_integer(drop)); } - if (a == -1) - return clone_arity(((Scheme_Structure *)p)->slots[1], drop); + if ((a == -1) || (a == -3)) + return clone_arity(((Scheme_Structure *)p)->slots[1], drop, a); else { /* Check arity (or for varargs) */ Scheme_Object *v; @@ -2089,7 +2108,7 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob } else { p = scheme_extract_struct_procedure(p, -1, NULL, &is_method); if (!SCHEME_PROCP(p)) { - if (a == -1) + if ((a == -1) || (a == -3)) return scheme_null; else return scheme_false; @@ -2104,7 +2123,7 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob if (a < 0) { Scheme_Object *pa; - pa = scheme_get_native_arity(p); + pa = scheme_get_native_arity(p, a); if (SCHEME_BOXP(pa)) { /* Is a method; pa already corrects for it */ @@ -2152,35 +2171,35 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob if (drop) { /* Need to adjust elements (e.g., because this procedure is a struct's apply handler) */ - Scheme_Object *first = scheme_null, *last = NULL, *a; + Scheme_Object *first = scheme_null, *last = NULL, *ae; int v; while (SCHEME_PAIRP(pa)) { - a = SCHEME_CAR(pa); - if (SCHEME_INTP(a)) { - v = SCHEME_INT_VAL(a); + ae = SCHEME_CAR(pa); + if (SCHEME_INTP(ae)) { + v = SCHEME_INT_VAL(ae); if (v < drop) - a = NULL; + ae = NULL; else { v -= drop; - a = scheme_make_integer(v); + ae = scheme_make_integer(v); } } else { /* arity-at-least */ - a = ((Scheme_Structure *)a)->slots[0]; - v = SCHEME_INT_VAL(a); + ae = ((Scheme_Structure *)ae)->slots[0]; + v = SCHEME_INT_VAL(ae); if (v >= drop) { - a = scheme_make_arity(v - drop, -1); + ae = make_arity(v - drop, -1, a); } else { - a = scheme_make_arity(0, -1); + ae = make_arity(0, -1, a); } } - if (a) { - a = scheme_make_pair(a, scheme_null); + if (ae) { + ae = scheme_make_pair(ae, scheme_null); if (last) - SCHEME_CDR(last) = a; + SCHEME_CDR(last) = ae; else - first = a; - last = a; + first = ae; + last = ae; } pa = SCHEME_CDR(pa); } @@ -2203,7 +2222,11 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob } else { Scheme_Closure_Data *data; - data = SCHEME_COMPILED_CLOS_CODE(p); + if (type == scheme_unclosed_procedure_type) + data = (Scheme_Closure_Data *)p; + else + data = SCHEME_COMPILED_CLOS_CODE(p); + mina = maxa = data->num_params; if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) { if (mina) @@ -2215,12 +2238,12 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob if (cases) { int count = cases_count, i; - if (a == -1) { - Scheme_Object *arity, *a, *last = NULL; + if ((a == -1) || (a == -3)) { + Scheme_Object *arity, *ae, *last = NULL; arity = scheme_alloc_list(count); - for (i = 0, a = arity; i < count; i++) { + for (i = 0, ae = arity; i < count; i++) { Scheme_Object *av; int mn, mx; mn = cases[2 * i]; @@ -2231,16 +2254,16 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob if (mx > 0) mx -= drop; - av = scheme_make_arity(mn, mx); + av = make_arity(mn, mx, a); - SCHEME_CAR(a) = av; - last = a; - a = SCHEME_CDR(a); + SCHEME_CAR(ae) = av; + last = ae; + ae = SCHEME_CDR(ae); } } /* If drop > 0, might have found no matches */ - if (!SCHEME_NULLP(a)) { + if (!SCHEME_NULLP(ae)) { if (last) SCHEME_CDR(last) = scheme_null; else @@ -2272,7 +2295,7 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob return scheme_false; } - if (a == -1) { + if ((a == -1) || (a == -3)) { if (mina < drop) return scheme_null; else @@ -2280,7 +2303,7 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob if (maxa > 0) maxa -= drop; - return scheme_make_arity(mina, maxa); + return make_arity(mina, maxa, a); } if (a == -2) @@ -2357,6 +2380,82 @@ int scheme_check_proc_arity(const char *where, int a, return scheme_check_proc_arity2(where, a, which, argc, argv, 0); } +int scheme_closure_preserves_marks(Scheme_Object *p) +{ + Scheme_Type type = SCHEME_TYPE(p); + Scheme_Closure_Data *data; + + if (type == scheme_native_closure_type) + return scheme_native_closure_preserves_marks(p); + else if (type == scheme_closure_type) { + data = SCHEME_COMPILED_CLOS_CODE(p); + } else if (type == scheme_unclosed_procedure_type) { + data = (Scheme_Closure_Data *)p; + } else + return 0; + + if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_PRESERVES_MARKS) + return 1; + + return 0; +} + +Scheme_Object *scheme_get_or_check_procedure_shape(Scheme_Object *e, Scheme_Object *expected) +/* result is interned --- a symbol or fixnum */ +{ + Scheme_Object *p; + + if (expected + && SCHEME_SYMBOLP(expected) + && SCHEME_SYM_VAL(expected)[0] == 's') { + return (scheme_check_structure_shape(e, expected) + ? expected + : NULL); + } + + if (SAME_TYPE(SCHEME_TYPE(e), scheme_inline_variant_type)) + e = SCHEME_VEC_ELS(e)[1]; + + p = scheme_get_or_check_arity(e, -3); + + if (SCHEME_PAIRP(p)) { + /* encode as a symbol */ + int sz = 32, c = 0; + char *b, *naya; + b = (char *)scheme_malloc_atomic(sz); + + while (SCHEME_PAIRP(p)) { + if (sz - c < 10) { + sz *= 2; + naya = (char *)scheme_malloc_atomic(sz); + memcpy(naya, b, c); + b = naya; + } + if (c) + b[c++] = ':'; + c += sprintf(b XFORM_OK_PLUS c, "%" PRIdPTR, SCHEME_INT_VAL(SCHEME_CAR(p))); + + p = SCHEME_CDR(p); + } + b[c] = c; + p = scheme_intern_exact_symbol(b, c); + } else { + /* Integer encoding, but shift to use low bit to indicate whether + it preserves marks, which is useful information for the JIT. */ + intptr_t i = SCHEME_INT_VAL(p); + i <<= 1; + if (scheme_closure_preserves_marks(e)) { + i |= 0x1; + } + p = scheme_make_integer(i); + } + + if (expected && !SAME_OBJ(expected, p)) + return NULL; + + return p; +} + /*========================================================================*/ /* basic function primitives */ /*========================================================================*/ @@ -2934,7 +3033,7 @@ static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[]) lists that include arity-at-least records. */ orig = get_or_check_arity(argv[0], -1, NULL, 1); - aty = clone_arity(argv[1], 0); + aty = clone_arity(argv[1], 0, -1); if (!is_subarity(aty, orig)) { scheme_contract_error("procedure-reduce-arity", diff --git a/src/racket/src/jit.c b/src/racket/src/jit.c index 5afd8cfdd7..a2015760b5 100644 --- a/src/racket/src/jit.c +++ b/src/racket/src/jit.c @@ -469,14 +469,9 @@ Scheme_Object *scheme_extract_global(Scheme_Object *o, Scheme_Native_Closure *nc pos = SCHEME_TOPLEVEL_POS(o); if (local_only) { - /* Usually, we look for local bindings only, because module caching means - that JIT-generated code can be linked to different other modules that - may have different bindings, even though we expect them binding to be - consistent. */ - if (pos < globs->num_toplevels) { - if (globs->import_map[pos >> 3] & (1 << (pos & 7))) - return NULL; - } + /* Look for local bindings when the JIT depends on information that is not + validated across module boundaries. */ + scheme_signal_error("internal error: import map not available"); } return globs->a[pos]; @@ -506,6 +501,23 @@ Scheme_Object *scheme_extract_closure_local(Scheme_Object *obj, mz_jit_state *ji return NULL; } +int scheme_native_closure_preserves_marks(Scheme_Object *p) +{ + Scheme_Native_Closure_Data *ndata = ((Scheme_Native_Closure *)p)->code; + + if (ndata->closure_size >= 0) { /* not case-lambda */ + if (lambda_has_been_jitted(ndata)) { + if (SCHEME_NATIVE_CLOSURE_DATA_FLAGS(ndata) & NATIVE_PRESERVES_MARKS) + return 1; + } else { + if (SCHEME_CLOSURE_DATA_FLAGS(ndata->u2.orig_code) & CLOS_PRESERVES_MARKS) + return 1; + } + } + + return 0; +} + int scheme_is_noncm(Scheme_Object *a, mz_jit_state *jitter, int depth, int stack_start) { if (SCHEME_PRIMP(a)) { @@ -525,20 +537,12 @@ int scheme_is_noncm(Scheme_Object *a, mz_jit_state *jitter, int depth, int stack && SAME_TYPE(SCHEME_TYPE(a), scheme_toplevel_type) && ((SCHEME_TOPLEVEL_FLAGS(a) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_CONST)) { Scheme_Object *p; - p = scheme_extract_global(a, jitter->nc, 1); + p = scheme_extract_global(a, jitter->nc, 0); if (p) { p = ((Scheme_Bucket *)p)->val; if (p && SAME_TYPE(SCHEME_TYPE(p), scheme_native_closure_type)) { - Scheme_Native_Closure_Data *ndata = ((Scheme_Native_Closure *)p)->code; - if (ndata->closure_size >= 0) { /* not case-lambda */ - if (lambda_has_been_jitted(ndata)) { - if (SCHEME_NATIVE_CLOSURE_DATA_FLAGS(ndata) & NATIVE_PRESERVES_MARKS) - return 1; - } else { - if (SCHEME_CLOSURE_DATA_FLAGS(ndata->u2.orig_code) & CLOS_PRESERVES_MARKS) - return 1; - } - } + if (scheme_native_closure_preserves_marks(p)) + return 1; } } } @@ -747,7 +751,7 @@ static int is_a_procedure(Scheme_Object *v, mz_jit_state *jitter) if (jitter->nc) { Scheme_Object *p; - p = scheme_extract_global(v, jitter->nc, 1); + p = scheme_extract_global(v, jitter->nc, 0); if (p) { p = ((Scheme_Bucket *)p)->val; return SAME_TYPE(SCHEME_TYPE(p), scheme_native_closure_type); @@ -3930,7 +3934,7 @@ int scheme_native_arity_check(Scheme_Object *closure, int argc) return sjc.check_arity_code(closure, argc + 1, 0 EXTRA_NATIVE_ARGUMENT); } -Scheme_Object *scheme_get_native_arity(Scheme_Object *closure) +Scheme_Object *scheme_get_native_arity(Scheme_Object *closure, int mode) { int cnt; @@ -3951,7 +3955,11 @@ Scheme_Object *scheme_get_native_arity(Scheme_Object *closure) has_rest = 1; } else has_rest = 0; - a = scheme_make_arity(v, has_rest ? -1 : v); + if (mode == -3) { + if (has_rest) v = -(v+1); + a = scheme_make_integer(v); + } else + a = scheme_make_arity(v, has_rest ? -1 : v); l = scheme_make_pair(a, l); } if (is_method) diff --git a/src/racket/src/jitcall.c b/src/racket/src/jitcall.c index c1bdc1bf5a..01a436e055 100644 --- a/src/racket/src/jitcall.c +++ b/src/racket/src/jitcall.c @@ -1652,7 +1652,7 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ && ((SCHEME_TOPLEVEL_FLAGS(rator) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_CONST)) { Scheme_Object *p; - p = scheme_extract_global(rator, jitter->nc, 1); + p = scheme_extract_global(rator, jitter->nc, 0); if (p) { p = ((Scheme_Bucket *)p)->val; if (can_direct_native(p, num_rands, &extract_case)) { diff --git a/src/racket/src/jitinline.c b/src/racket/src/jitinline.c index 7caeac63ff..44beb5a28c 100644 --- a/src/racket/src/jitinline.c +++ b/src/racket/src/jitinline.c @@ -356,7 +356,7 @@ static Scheme_Object *extract_struct_constant(mz_jit_state *jitter, Scheme_Objec { if (SAME_TYPE(SCHEME_TYPE(rator), scheme_toplevel_type) && (SCHEME_TOPLEVEL_FLAGS(rator) & SCHEME_TOPLEVEL_FLAGS_MASK) >= SCHEME_TOPLEVEL_CONST) { - rator = scheme_extract_global(rator, jitter->nc, 1); + rator = scheme_extract_global(rator, jitter->nc, 0); if (rator) return ((Scheme_Bucket *)rator)->val; } diff --git a/src/racket/src/jitprep.c b/src/racket/src/jitprep.c index da46ac3034..3de148bc0e 100644 --- a/src/racket/src/jitprep.c +++ b/src/racket/src/jitprep.c @@ -550,8 +550,8 @@ Scheme_Object *scheme_jit_closure(Scheme_Object *code, Scheme_Object *context) if (!context) data->u.jit_clone = data2; - } - + } + /* If it's zero-sized, then create closure now */ if (!data2->closure_size) return scheme_make_native_closure(data2->u.native_code); diff --git a/src/racket/src/module.c b/src/racket/src/module.c index 69b1a5f33f..0b8223c5fc 100644 --- a/src/racket/src/module.c +++ b/src/racket/src/module.c @@ -573,7 +573,7 @@ void scheme_finish_kernel(Scheme_Env *env) running[1] = 1; env->running = running; env->attached = 1; - + /* Since this is the first module rename, it's registered as the kernel module rename: */ rn = scheme_make_module_rename(scheme_make_integer(0), mzMOD_RENAME_NORMAL, NULL, NULL, NULL); @@ -4069,6 +4069,19 @@ static int is_procedure_expression(Scheme_Object *e) || (t == scheme_case_lambda_sequence_type)); } +static void get_procedure_shape(Scheme_Object *e, Scheme_Object **_c) +{ + Scheme_Object *p, *v; + + p = scheme_get_or_check_procedure_shape(e, NULL); + + v = scheme_alloc_small_object(); + v->type = scheme_proc_shape_type; + SCHEME_PTR_VAL(v) = p; + + *_c = v; +} + static void setup_accessible_table(Scheme_Module *m) { if (!m->exp_infos[0]->accessible) { @@ -4121,7 +4134,8 @@ static void setup_accessible_table(Scheme_Module *m) for (i = 0; i < cnt; i++) { form = SCHEME_VEC_ELS(m->bodies[0])[i]; if (SAME_TYPE(SCHEME_TYPE(form), scheme_define_values_type)) { - int checked_st = 0, is_st = 0, st_count = 0, st_icount = 0; + int checked_st = 0, is_st = 0; + Simple_Stuct_Type_Info stinfo; for (k = SCHEME_VEC_SIZE(form); k-- > 1; ) { tl = SCHEME_VEC_ELS(form)[k]; if (SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_SEAL) { @@ -4146,8 +4160,9 @@ static void setup_accessible_table(Scheme_Module *m) SCHEME_VEC_ELS(SCHEME_VEC_ELS(form)[0])[2] = (Scheme_Object *)m->prefix; v = scheme_make_pair(v, SCHEME_VEC_ELS(form)[0]); } else if (is_procedure_expression(SCHEME_VEC_ELS(form)[0])) { - /* record that it's constant across all instantiations: */ - v = scheme_make_pair(v, scheme_constant_key); + /* that it's a procedure: */ + v = scheme_make_vector(2, v); + SCHEME_VEC_ELS(v)[1] = SCHEME_VEC_ELS(form)[0]; } else { /* record that it's fixed for any given instantiation: */ v = scheme_make_pair(v, scheme_fixed_key); @@ -4156,15 +4171,18 @@ static void setup_accessible_table(Scheme_Module *m) if (!checked_st) { is_st = !!scheme_is_simple_make_struct_type(SCHEME_VEC_ELS(form)[0], SCHEME_VEC_SIZE(form)-1, - 1, 1, NULL, &st_count, &st_icount, - NULL, + 1, 1, NULL, &stinfo, NULL, NULL, NULL, 0, m->prefix->toplevels, ht, 5); checked_st = 1; } - if (is_st) - v = scheme_make_pair(v, scheme_make_struct_proc_shape(k-1, st_count, st_icount)); + if (is_st) { + intptr_t shape; + shape = scheme_get_struct_proc_shape(k-1, &stinfo); + v = scheme_make_vector(3, v); + SCHEME_VEC_ELS(v)[1] = scheme_make_integer(shape); + } } scheme_hash_set(ht, tl, v); } @@ -4376,6 +4394,20 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object if (SCHEME_PAIRP(pos)) { if (_is_constant) *_is_constant = SCHEME_CDR(pos); pos = SCHEME_CAR(pos); + } else if (SCHEME_VECTORP(pos)) { + if (SCHEME_VEC_SIZE(pos) == 2) { + if (_is_constant) + get_procedure_shape(SCHEME_VEC_ELS(pos)[1], _is_constant); + } else { + if (_is_constant) { + Scheme_Object *ps; + + ps = scheme_make_struct_proc_shape(SCHEME_INT_VAL(SCHEME_VEC_ELS(pos)[1])); + + *_is_constant = ps; + } + } + pos = SCHEME_VEC_ELS(pos)[0]; } } @@ -4521,6 +4553,11 @@ int scheme_module_export_position(Scheme_Object *modname, Scheme_Env *env, Schem setup_accessible_table(m); pos = scheme_hash_get(m->exp_infos[0]->accessible, varname); + + if (SCHEME_PAIRP(pos)) + pos = SCHEME_CAR(pos); + else if (SCHEME_VECTORP(pos)) + pos = SCHEME_VEC_ELS(pos)[0]; if (pos && (SCHEME_INT_VAL(pos) >= 0)) return SCHEME_INT_VAL(pos); @@ -8011,8 +8048,8 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env sets m->comp_prefix to NULL, which is how optimize & resolve know to avoid re-optimizing and re-resolving. */ - o = scheme_get_param(scheme_current_config(), MZCONFIG_USE_JIT); - use_jit = SCHEME_TRUEP(o); + /* Note: don't use MZCONFIG_USE_JIT for module bodies */ + use_jit = scheme_startup_use_jit; oi = scheme_optimize_info_create(env->prefix, 1); scheme_optimize_info_enforce_const(oi, rec[drec].comp_flags & COMP_ENFORCE_CONSTS); @@ -8644,7 +8681,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ unbounds = scheme_make_pair(eenv->prefix->unbound, unbounds); m = scheme_sfs(m, NULL, max_let_depth); - if (scheme_resolve_info_use_jit(ri)) + if (scheme_startup_use_jit /* Note: not scheme_resolve_info_use_jit(ri) */) m = scheme_jit_expr(m); rp = scheme_prefix_eval_clone(rp); diff --git a/src/racket/src/mzclpf_post.inc b/src/racket/src/mzclpf_post.inc index 6fa6dd2be8..55838e3a3c 100644 --- a/src/racket/src/mzclpf_post.inc +++ b/src/racket/src/mzclpf_post.inc @@ -18,7 +18,6 @@ if (!pf->next_final) { /* We're the first to look at this prefix... */ - gcMARK2(pf->import_map, gc); if (pf->num_stxes) { /* Mark all syntax-object references */ for (i = pf->num_stxes+1; i--;) { diff --git a/src/racket/src/mzmark_type.inc b/src/racket/src/mzmark_type.inc index e2a3f68f4e..a33c5f68a8 100644 --- a/src/racket/src/mzmark_type.inc +++ b/src/racket/src/mzmark_type.inc @@ -42,6 +42,7 @@ static int module_var_MARK(void *p, struct NewGC *gc) { gcMARK2(mv->modidx, gc); gcMARK2(mv->sym, gc); gcMARK2(mv->insp, gc); + gcMARK2(mv->shape, gc); return gcBYTES_TO_WORDS(sizeof(Module_Variable)); @@ -53,6 +54,7 @@ static int module_var_FIXUP(void *p, struct NewGC *gc) { gcFIXUP2(mv->modidx, gc); gcFIXUP2(mv->sym, gc); gcFIXUP2(mv->insp, gc); + gcFIXUP2(mv->shape, gc); return gcBYTES_TO_WORDS(sizeof(Module_Variable)); @@ -2362,7 +2364,6 @@ static int prefix_val_MARK(void *p, struct NewGC *gc) { int i; for (i = pf->num_slots; i--; ) gcMARK2(pf->a[i], gc); - gcMARK2(pf->import_map, gc); return gcBYTES_TO_WORDS((sizeof(Scheme_Prefix) + ((pf->num_slots-mzFLEX_DELTA) * sizeof(Scheme_Object *)) @@ -2375,7 +2376,6 @@ static int prefix_val_FIXUP(void *p, struct NewGC *gc) { int i; for (i = pf->num_slots; i--; ) gcFIXUP2(pf->a[i], gc); - gcFIXUP2(pf->import_map, gc); return gcBYTES_TO_WORDS((sizeof(Scheme_Prefix) + ((pf->num_slots-mzFLEX_DELTA) * sizeof(Scheme_Object *)) diff --git a/src/racket/src/mzmarksrc.c b/src/racket/src/mzmarksrc.c index 3def9be272..c49f50198d 100644 --- a/src/racket/src/mzmarksrc.c +++ b/src/racket/src/mzmarksrc.c @@ -20,6 +20,7 @@ module_var { gcMARK2(mv->modidx, gc); gcMARK2(mv->sym, gc); gcMARK2(mv->insp, gc); + gcMARK2(mv->shape, gc); size: gcBYTES_TO_WORDS(sizeof(Module_Variable)); @@ -949,7 +950,6 @@ prefix_val { int i; for (i = pf->num_slots; i--; ) gcMARK2(pf->a[i], gc); - gcMARK2(pf->import_map, gc); size: gcBYTES_TO_WORDS((sizeof(Scheme_Prefix) + ((pf->num_slots-mzFLEX_DELTA) * sizeof(Scheme_Object *)) diff --git a/src/racket/src/optimize.c b/src/racket/src/optimize.c index 7e0bfab501..aa5f3b1de6 100644 --- a/src/racket/src/optimize.c +++ b/src/racket/src/optimize.c @@ -118,8 +118,6 @@ static Scheme_Object *optimize_shift(Scheme_Object *obj, int delta, int after_de static int compiled_proc_body_size(Scheme_Object *o, int less_args); -READ_ONLY static Scheme_Object *struct_proc_shape_other; - typedef struct Scheme_Once_Used { Scheme_Object so; Scheme_Object *expr; @@ -145,9 +143,6 @@ void scheme_init_optimize() #ifdef MZ_PRECISE_GC register_traversers(); #endif - - REGISTER_SO(struct_proc_shape_other); - struct_proc_shape_other = scheme_make_struct_proc_shape(3, 0, 0); } /*========================================================================*/ @@ -433,7 +428,7 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, Scheme_Object *auto_e; int auto_e_depth; auto_e = scheme_is_simple_make_struct_type(o, vals, resolved, 0, &auto_e_depth, - NULL, NULL, NULL, + NULL, (opt_info ? opt_info->top_level_consts : NULL), NULL, NULL, 0, NULL, NULL, 5); @@ -447,12 +442,13 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, return 0; } -static int is_current_inspector_call(Scheme_Object *a) +static int is_inspector_call(Scheme_Object *a) { if (SAME_TYPE(SCHEME_TYPE(a), scheme_application_type)) { Scheme_App_Rec *app = (Scheme_App_Rec *)a; if (!app->num_args - && SAME_OBJ(app->args[0], scheme_current_inspector_proc)) + && (SAME_OBJ(app->args[0], scheme_current_inspector_proc) + || SAME_OBJ(app->args[0], scheme_make_inspector_proc))) return 1; } return 0; @@ -535,7 +531,8 @@ static int ok_proc_creator_args(Scheme_Object *rator, Scheme_Object *rand1, Sche return 0; } -static int is_values_with_accessors_and_mutators(Scheme_Object *e, int vals, int resolved, int field_count) +static int is_values_with_accessors_and_mutators(Scheme_Object *e, int vals, int resolved, + Simple_Stuct_Type_Info *_stinfo) { if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) { Scheme_App_Rec *app = (Scheme_App_Rec *)e; @@ -546,30 +543,47 @@ static int is_values_with_accessors_and_mutators(Scheme_Object *e, int vals, int && is_local_ref(app->args[1], delta, 1) && is_local_ref(app->args[2], delta+1, 1) && is_local_ref(app->args[3], delta+2, 1)) { - int i; + int i, num_gets = 0, num_sets = 0, normal_ops = 1; for (i = app->num_args; i > 3; i--) { if (is_local_ref(app->args[i], delta, 5)) { - /* ok */ - } else if (SAME_TYPE(SCHEME_TYPE(app->args[i]), scheme_application_type)) { + normal_ops = 0; + } else if (SAME_TYPE(SCHEME_TYPE(app->args[i]), scheme_application_type) + && _stinfo->normal_ops && !_stinfo->indexed_ops) { Scheme_App_Rec *app3 = (Scheme_App_Rec *)app->args[i]; int delta2 = delta + (resolved ? app3->num_args : 0); if (app3->num_args == 3) { if (!ok_proc_creator_args(app3->args[0], app3->args[1], app3->args[2], app3->args[3], - delta2, field_count)) + delta2, _stinfo->field_count)) break; + if (SAME_OBJ(app3->args[0], scheme_make_struct_field_mutator_proc)) { + if (num_gets) normal_ops = 0; + num_sets++; + } else + num_gets++; } else break; - } else if (SAME_TYPE(SCHEME_TYPE(app->args[i]), scheme_application3_type)) { + } else if (SAME_TYPE(SCHEME_TYPE(app->args[i]), scheme_application3_type) + && _stinfo->normal_ops && !_stinfo->indexed_ops) { Scheme_App3_Rec *app3 = (Scheme_App3_Rec *)app->args[i]; int delta2 = delta + (resolved ? 2 : 0); if (!ok_proc_creator_args(app3->rator, app3->rand1, app3->rand2, NULL, - delta2, field_count)) + delta2, _stinfo->field_count)) break; + if (SAME_OBJ(app3->rator, scheme_make_struct_field_mutator_proc)) { + if (num_gets) normal_ops = 0; + num_sets++; + } else + num_gets++; } else break; } - if (i <= 3) + if (i <= 3) { + _stinfo->normal_ops = normal_ops; + _stinfo->indexed_ops = 1; + _stinfo->num_gets = num_gets; + _stinfo->num_sets = num_sets; return 1; + } } } @@ -637,15 +651,21 @@ static int is_constant_super(Scheme_Object *arg, name = symbols[pos]; if (SCHEME_SYMBOLP(name)) { v = scheme_hash_get(symbol_table, name); - if (v && SCHEME_PAIRP(v)) { - v = SCHEME_CDR(v); - if (v && SAME_TYPE(SCHEME_TYPE(v), scheme_struct_proc_shape_type)) { - int mode = (SCHEME_PROC_SHAPE_MODE(v) & STRUCT_PROC_SHAPE_MASK); - int field_count = (SCHEME_PROC_SHAPE_MODE(v) >> STRUCT_PROC_SHAPE_SHIFT); + if (v && SCHEME_VECTORP(v) && (SCHEME_VEC_SIZE(v) == 3)) { + v = SCHEME_VEC_ELS(v)[1]; + if (v && SCHEME_INTP(v)) { + int mode = (SCHEME_INT_VAL(v) & STRUCT_PROC_SHAPE_MASK); + int field_count = (SCHEME_INT_VAL(v) >> STRUCT_PROC_SHAPE_SHIFT); if (mode == STRUCT_PROC_SHAPE_STRUCT) return field_count + 1; } } + } else if (SAME_TYPE(SCHEME_TYPE(name), scheme_module_variable_type)) { + intptr_t k; + if (scheme_decode_struct_shape(((Module_Variable *)name)->shape, &k)) { + if ((k & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_STRUCT) + return (k >> STRUCT_PROC_SHAPE_SHIFT) + 1; + } } } if (top_level_table) { @@ -663,8 +683,7 @@ static int is_constant_super(Scheme_Object *arg, Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int resolved, int check_auto, GC_CAN_IGNORE int *_auto_e_depth, - int *_field_count, int *_init_field_count, - int *_uses_super, + Simple_Stuct_Type_Info *_stinfo, Scheme_Hash_Table *top_level_consts, Scheme_Hash_Table *top_level_table, Scheme_Object **runstack, int rs_delta, @@ -714,7 +733,7 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int || (SCHEME_SYMBOLP(app->args[7]) && !strcmp("prefab", SCHEME_SYM_VAL(app->args[7])) && !SCHEME_SYM_WEIRDP(app->args[7])) - || is_current_inspector_call(app->args[7])) + || is_inspector_call(app->args[7])) && ((app->num_args < 8) /* propcedure property: */ || SCHEME_FALSEP(app->args[8]) @@ -730,19 +749,22 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int /* constructor name: */ || SCHEME_FALSEP(app->args[11]) || SCHEME_SYMBOLP(app->args[11]))) { - int super_count = (super_count_plus_one - ? (super_count_plus_one - 1) - : 0); if (_auto_e_depth) *_auto_e_depth = (resolved ? app->num_args : 0); - if (_field_count) - *_field_count = SCHEME_INT_VAL(app->args[3]) + super_count; - if (_init_field_count) - *_init_field_count = (SCHEME_INT_VAL(app->args[3]) - + SCHEME_INT_VAL(app->args[4]) - + super_count); - if (_uses_super) - *_uses_super = (super_count_plus_one ? 1 : 0); + if (_stinfo) { + int super_count = (super_count_plus_one + ? (super_count_plus_one - 1) + : 0); + _stinfo->field_count = SCHEME_INT_VAL(app->args[3]) + super_count; + _stinfo->init_field_count = (SCHEME_INT_VAL(app->args[3]) + + SCHEME_INT_VAL(app->args[4]) + + super_count); + _stinfo->uses_super = (super_count_plus_one ? 1 : 0); + _stinfo->normal_ops = 1; + _stinfo->indexed_ops = 0; + _stinfo->num_gets = 1; + _stinfo->num_sets = 1; + } return ((app->num_args < 5) ? scheme_true : app->args[5]); } } @@ -758,13 +780,13 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body; if (SAME_TYPE(SCHEME_TYPE(lv->value), scheme_application_type)) { Scheme_Object *auto_e; - int ifc; + Simple_Stuct_Type_Info stinfo; int lh_delta = ((SCHEME_LET_FLAGS(lh) & (SCHEME_LET_RECURSIVE | SCHEME_LET_STAR)) ? lh->count : 0); + if (!_stinfo) _stinfo = &stinfo; auto_e = scheme_is_simple_make_struct_type(lv->value, 5, resolved, check_auto, - _auto_e_depth, _field_count, &ifc, - _uses_super, + _auto_e_depth, _stinfo, top_level_consts, top_level_table, runstack, rs_delta + lh_delta, symbols, symbol_table, @@ -772,10 +794,9 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int if (auto_e) { /* We have (let-values ([... (make-struct-type)]) ....), so make sure body just uses `make-struct-field-{accessor,mutator}'. */ - if (is_values_with_accessors_and_mutators(lv->body, vals, resolved, ifc)) { + if (is_values_with_accessors_and_mutators(lv->body, vals, resolved, _stinfo)) { if (_auto_e_depth && lh_delta) *_auto_e_depth += lh_delta; - if (_init_field_count) *_init_field_count = ifc; return auto_e; } } @@ -795,10 +816,10 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int e2 = skip_clears(lv->value); if (SAME_TYPE(SCHEME_TYPE(e2), scheme_application_type)) { Scheme_Object *auto_e; - int ifc; + Simple_Stuct_Type_Info stinfo; + if (!_stinfo) _stinfo = &stinfo; auto_e = scheme_is_simple_make_struct_type(e2, 5, resolved, check_auto, - _auto_e_depth, _field_count, &ifc, - _uses_super, + _auto_e_depth, _stinfo, top_level_consts, top_level_table, runstack, rs_delta + lvd->count, symbols, symbol_table, @@ -807,9 +828,8 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int /* We have (let-values ([... (make-struct-type)]) ....), so make sure body just uses `make-struct-field-{accessor,mutator}'. */ e2 = skip_clears(lv->body); - if (is_values_with_accessors_and_mutators(e2, vals, resolved, ifc)) { + if (is_values_with_accessors_and_mutators(e2, vals, resolved, _stinfo)) { if (_auto_e_depth) *_auto_e_depth += lvd->count; - if (_init_field_count) *_init_field_count = ifc; return auto_e; } } @@ -822,29 +842,37 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int return NULL; } -Scheme_Object *scheme_make_struct_proc_shape(int k, int field_count, int init_field_count) +intptr_t scheme_get_struct_proc_shape(int k, Simple_Stuct_Type_Info *stinfo) { - Scheme_Object *ps; - switch (k) { case 0: - if (field_count == init_field_count) - k = STRUCT_PROC_SHAPE_STRUCT | (field_count << STRUCT_PROC_SHAPE_SHIFT); + if (stinfo->field_count == stinfo->init_field_count) + return STRUCT_PROC_SHAPE_STRUCT | (stinfo->field_count << STRUCT_PROC_SHAPE_SHIFT); else - k = STRUCT_PROC_SHAPE_OTHER; + return STRUCT_PROC_SHAPE_OTHER; break; case 1: - k = STRUCT_PROC_SHAPE_CONSTR | (init_field_count << STRUCT_PROC_SHAPE_SHIFT); + return STRUCT_PROC_SHAPE_CONSTR | (stinfo->init_field_count << STRUCT_PROC_SHAPE_SHIFT); break; case 2: - k = STRUCT_PROC_SHAPE_PRED; + return STRUCT_PROC_SHAPE_PRED; break; default: - if (struct_proc_shape_other) - return struct_proc_shape_other; - k = STRUCT_PROC_SHAPE_OTHER; + if (stinfo && stinfo->normal_ops && stinfo->indexed_ops) { + if (k - 3 < stinfo->num_gets) + return STRUCT_PROC_SHAPE_GETTER | (stinfo->field_count << STRUCT_PROC_SHAPE_SHIFT); + else + return STRUCT_PROC_SHAPE_SETTER | (stinfo->field_count << STRUCT_PROC_SHAPE_SHIFT); + } } + return STRUCT_PROC_SHAPE_OTHER; +} + +Scheme_Object *scheme_make_struct_proc_shape(intptr_t k) +{ + Scheme_Object *ps; + ps = scheme_malloc_small_atomic_tagged(sizeof(Scheme_Small_Object)); ps->type = scheme_struct_proc_shape_type; SCHEME_PROC_SHAPE_MODE(ps) = k; @@ -5062,7 +5090,8 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) (including raising an exception), then continue the group of simultaneous definitions: */ if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { - int n, cnst = 0, sproc = 0, sstruct = 0, field_count = 0, init_field_count = 0; + int n, cnst = 0, sproc = 0, sstruct = 0; + Simple_Stuct_Type_Info stinfo; vars = SCHEME_VEC_ELS(e)[0]; e = SCHEME_VEC_ELS(e)[1]; @@ -5084,7 +5113,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) sproc = 1; } } else if (scheme_is_simple_make_struct_type(e, n, 0, 1, NULL, - &field_count, &init_field_count, NULL, + &stinfo, info->top_level_consts, NULL, NULL, 0, NULL, NULL, 5)) { @@ -5103,7 +5132,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) Scheme_Object *e2; if (sstruct) { - e2 = scheme_make_struct_proc_shape(i, field_count, init_field_count); + e2 = scheme_make_struct_proc_shape(scheme_get_struct_proc_shape(i, &stinfo)); } else if (sproc) { e2 = scheme_make_noninline_proc(e); } else if (IS_COMPILED_PROC(e)) { diff --git a/src/racket/src/print.c b/src/racket/src/print.c index ef6ceb1459..6a4af29571 100644 --- a/src/racket/src/print.c +++ b/src/racket/src/print.c @@ -2909,10 +2909,11 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, print(mv->modidx, notdisplay, 1, ht, mt, pp); } print(mv->sym, notdisplay, 1, ht, mt, pp); + print(mv->shape ? mv->shape : scheme_false, notdisplay, 1, ht, mt, pp); if (flags & 0x3) { print_compact_number(pp, -3-(flags&0x3)); } - if (((Module_Variable *)obj)->mod_phase) { + if (mv->mod_phase) { print_compact_number(pp, -2); print_compact_number(pp, mv->mod_phase); } diff --git a/src/racket/src/read.c b/src/racket/src/read.c index b33ebd8c31..f5bbd0a839 100644 --- a/src/racket/src/read.c +++ b/src/racket/src/read.c @@ -4692,11 +4692,12 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) case CPT_MODULE_VAR: { Module_Variable *mv; - Scheme_Object *mod, *var; + Scheme_Object *mod, *var, *shape; int pos; mod = read_compact(port, 0); var = read_compact(port, 0); + shape = read_compact(port, 0); pos = read_compact_number(port); mv = MALLOC_ONE_TAGGED(Module_Variable); @@ -4705,6 +4706,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) mod = scheme_intern_resolved_module_path(mod); mv->modidx = mod; mv->sym = var; + mv->shape = shape; if (pos < -3) { pos = -(pos + 3); SCHEME_MODVAR_FLAGS(mv) = pos; diff --git a/src/racket/src/regexp.c b/src/racket/src/regexp.c index adf83ddb26..d12e7c6144 100644 --- a/src/racket/src/regexp.c +++ b/src/racket/src/regexp.c @@ -5088,13 +5088,6 @@ static Scheme_Object *do_make_regexp(const char *who, int is_byte, int pcre, int 1); ((regexp *)re)->source = src; } - - { - Scheme_Object *b; - b = scheme_get_param(scheme_current_config(), MZCONFIG_USE_JIT); - if (SCHEME_TRUEP(b)) - ((regexp *)re)->flags |= REGEXP_JIT; - } return re; } diff --git a/src/racket/src/resolve.c b/src/racket/src/resolve.c index 5ce2407393..5af659bff6 100644 --- a/src/racket/src/resolve.c +++ b/src/racket/src/resolve.c @@ -2505,7 +2505,7 @@ Resolve_Prefix *scheme_resolve_prefix(int phase, Comp_Prefix *cp, int simplify) m = ((Module_Variable *)m)->sym; } } - tls[SCHEME_TOPLEVEL_POS(ht->vals[i])] = m; + tls[SCHEME_TOPLEVEL_POS(ht->vals[i])] = m; } } } diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index 880a8cdd55..5c517c9d22 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -375,6 +375,7 @@ extern Scheme_Object *scheme_make_struct_field_accessor_proc; extern Scheme_Object *scheme_make_struct_field_mutator_proc; extern Scheme_Object *scheme_struct_type_p_proc; extern Scheme_Object *scheme_current_inspector_proc; +extern Scheme_Object *scheme_make_inspector_proc; extern Scheme_Object *scheme_varref_const_p_proc; extern Scheme_Object *scheme_define_values_syntax, *scheme_define_syntaxes_syntax; @@ -2135,7 +2136,6 @@ typedef struct Scheme_Prefix Scheme_Object so; /* scheme_prefix_type */ int num_slots, num_toplevels, num_stxes; struct Scheme_Prefix *next_final; /* for special GC handling */ - char *import_map; /* bitmap indicating which toplevels are imported */ Scheme_Object *a[mzFLEX_ARRAY_DECL]; /* array of objects */ /* followed by an array of `int's for tl_map uses */ } Scheme_Prefix; @@ -2865,25 +2865,40 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, int scheme_might_invoke_call_cc(Scheme_Object *value); int scheme_is_liftable(Scheme_Object *o, int bind_count, int fuel, int as_rator); int scheme_is_functional_primitive(Scheme_Object *rator, int num_args, int expected_vals); + +typedef struct { + int uses_super; + int field_count, init_field_count; + int normal_ops, indexed_ops, num_gets, num_sets; +} Simple_Stuct_Type_Info; + Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *app, int vals, int resolved, int check_auto, int *_auto_e_depth, - int *_field_count, int *_init_field_count, - int *_uses_super, + Simple_Stuct_Type_Info *_stinfo, Scheme_Hash_Table *top_level_consts, Scheme_Hash_Table *top_level_table, Scheme_Object **runstack, int rs_delta, Scheme_Object **symbols, Scheme_Hash_Table *symbol_table, int fuel); -Scheme_Object *scheme_make_struct_proc_shape(int k, int field_count, int init_field_count); +intptr_t scheme_get_struct_proc_shape(int k, Simple_Stuct_Type_Info *sinfo); +Scheme_Object *scheme_make_struct_proc_shape(intptr_t k); #define STRUCT_PROC_SHAPE_STRUCT 0 -#define STRUCT_PROC_SHAPE_PRED 1 -#define STRUCT_PROC_SHAPE_OTHER 2 -#define STRUCT_PROC_SHAPE_CONSTR 3 -#define STRUCT_PROC_SHAPE_MASK 0x7 -#define STRUCT_PROC_SHAPE_SHIFT 3 +#define STRUCT_PROC_SHAPE_CONSTR 1 +#define STRUCT_PROC_SHAPE_PRED 2 +#define STRUCT_PROC_SHAPE_GETTER 3 +#define STRUCT_PROC_SHAPE_SETTER 4 +#define STRUCT_PROC_SHAPE_OTHER 5 +#define STRUCT_PROC_SHAPE_MASK 0xF +#define STRUCT_PROC_SHAPE_SHIFT 4 #define SCHEME_PROC_SHAPE_MODE(obj) (((Scheme_Small_Object *)(obj))->u.int_val) +Scheme_Object *scheme_get_or_check_procedure_shape(Scheme_Object *e, Scheme_Object *expected); +int scheme_check_structure_shape(Scheme_Object *e, Scheme_Object *expected); +int scheme_decode_struct_shape(Scheme_Object *shape, intptr_t *_v); +int scheme_closure_preserves_marks(Scheme_Object *p); +int scheme_native_closure_preserves_marks(Scheme_Object *p); + int scheme_is_env_variable_boxed(Scheme_Comp_Env *env, int which); int scheme_get_eval_type(Scheme_Object *obj); @@ -3193,6 +3208,7 @@ typedef struct Module_Variable { Scheme_Object *modidx; Scheme_Object *sym; Scheme_Object *insp; /* for checking protected/unexported access */ + Scheme_Object *shape; /* NULL or a symbol encoding "type" information */ int pos, mod_phase; } Module_Variable; @@ -3271,7 +3287,8 @@ int scheme_resolved_module_path_value_matches(Scheme_Object *rmp, Scheme_Object Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modidx, Scheme_Object *stxsym, Scheme_Object *insp, - int pos, intptr_t mod_phase, int is_constant); + int pos, intptr_t mod_phase, int is_constant, + Scheme_Object *shape); Scheme_Env *scheme_get_kernel_env(); @@ -3409,7 +3426,7 @@ Scheme_Object *scheme_get_stack_trace(Scheme_Object *mark_set); Scheme_Object *scheme_get_or_check_arity(Scheme_Object *p, intptr_t a); int scheme_native_arity_check(Scheme_Object *closure, int argc); -Scheme_Object *scheme_get_native_arity(Scheme_Object *closure); +Scheme_Object *scheme_get_native_arity(Scheme_Object *closure, int mode); struct Scheme_Logger { Scheme_Object so; diff --git a/src/racket/src/schrx.h b/src/racket/src/schrx.h index 290fd162a3..b97fd4428e 100644 --- a/src/racket/src/schrx.h +++ b/src/racket/src/schrx.h @@ -30,7 +30,6 @@ typedef struct regexp { #define REGEXP_IS_PCRE 0x02 #define REGEXP_ANCH 0x04 #define REGEXP_MUST_CI 0x08 -#define REGEXP_JIT 0x10 #ifdef INDIRECT_TO_PROGRAM # define N_ITO_DELTA(prog, extra, re) extra diff --git a/src/racket/src/schvers.h b/src/racket/src/schvers.h index b3c0fa8679..22d1890104 100644 --- a/src/racket/src/schvers.h +++ b/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "5.3.1.3" +#define MZSCHEME_VERSION "5.3.1.4" #define MZSCHEME_VERSION_X 5 #define MZSCHEME_VERSION_Y 3 #define MZSCHEME_VERSION_Z 1 -#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/struct.c b/src/racket/src/struct.c index 44958b10a4..50813ef4b1 100644 --- a/src/racket/src/struct.c +++ b/src/racket/src/struct.c @@ -40,6 +40,7 @@ READ_ONLY Scheme_Object *scheme_make_struct_field_accessor_proc; READ_ONLY Scheme_Object *scheme_make_struct_field_mutator_proc; READ_ONLY Scheme_Object *scheme_struct_type_p_proc; READ_ONLY Scheme_Object *scheme_current_inspector_proc; +READ_ONLY Scheme_Object *scheme_make_inspector_proc; READ_ONLY Scheme_Object *scheme_recur_symbol; READ_ONLY Scheme_Object *scheme_display_symbol; READ_ONLY Scheme_Object *scheme_write_special_symbol; @@ -715,11 +716,11 @@ scheme_init_struct (Scheme_Env *env) /*** Inspectors ****/ - scheme_add_global_constant("make-inspector", - scheme_make_prim_w_arity(make_inspector, - "make-inspector", - 0, 1), - env); + REGISTER_SO(scheme_make_inspector_proc); + scheme_make_inspector_proc = scheme_make_prim_w_arity(make_inspector, + "make-inspector", + 0, 1); + scheme_add_global_constant("make-inspector", scheme_make_inspector_proc, env); scheme_add_global_constant("make-sibling-inspector", scheme_make_prim_w_arity(make_sibling_inspector, "make-sibling-inspector", @@ -3109,6 +3110,69 @@ chaperone_prop_getter_p(int argc, Scheme_Object *argv[]) ? scheme_true : scheme_false); } +int scheme_decode_struct_shape(Scheme_Object *expected, intptr_t *_v) +{ + intptr_t v; + int i; + + if (!expected || !SCHEME_SYMBOLP(expected)) + return 0; + + if (SCHEME_SYM_VAL(expected)[0] != 's') + return 0; + + for (i = 6, v = 0; SCHEME_SYM_VAL(expected)[i]; i++) { + v = (v * 10) + (SCHEME_SYM_VAL(expected)[i] - '0'); + } + + *_v = v; + + return 1; +} + +int scheme_check_structure_shape(Scheme_Object *e, Scheme_Object *expected) +{ + intptr_t _v, v; + int i; + Scheme_Struct_Type *st; + + if (!scheme_decode_struct_shape(expected, &_v)) + return 0; + v = _v; + + if (SCHEME_STRUCT_TYPEP(e)) { + st = (Scheme_Struct_Type *)e; + if (st->num_slots != st->num_islots) + return (v == STRUCT_PROC_SHAPE_OTHER); + return (v == ((st->num_slots << STRUCT_PROC_SHAPE_SHIFT) + | STRUCT_PROC_SHAPE_STRUCT)); + } else if (!SCHEME_PRIMP(e)) + return 0; + + i = (((Scheme_Primitive_Proc *)e)->pp.flags & SCHEME_PRIM_OTHER_TYPE_MASK); + if ((i == SCHEME_PRIM_STRUCT_TYPE_CONSTR) + || (i == SCHEME_PRIM_STRUCT_TYPE_SIMPLE_CONSTR)) { + st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0]; + return (v == ((st->num_islots << STRUCT_PROC_SHAPE_SHIFT) + | STRUCT_PROC_SHAPE_CONSTR)); + } else if (i == SCHEME_PRIM_STRUCT_TYPE_PRED) { + return (v == STRUCT_PROC_SHAPE_PRED); + } else if (i == SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER) { + st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0]; + return (v == ((st->num_slots << STRUCT_PROC_SHAPE_SHIFT) + | STRUCT_PROC_SHAPE_SETTER)); + } else if (i == SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER) { + st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0]; + return (v == ((st->num_slots << STRUCT_PROC_SHAPE_SHIFT) + | STRUCT_PROC_SHAPE_GETTER)); + } else if ((i == SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER) + || (i == SCHEME_PRIM_STRUCT_TYPE_BROKEN_INDEXED_SETTER) + || (i == SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER)) + return (v == STRUCT_PROC_SHAPE_OTHER); + + return 0; +} + static Scheme_Object *make_struct_field_xxor(const char *who, int getter, int argc, Scheme_Object *argv[]) { diff --git a/src/racket/src/stypes.h b/src/racket/src/stypes.h index e69c816d31..99b6bf06ab 100644 --- a/src/racket/src/stypes.h +++ b/src/racket/src/stypes.h @@ -198,84 +198,85 @@ enum { scheme_serialized_tcp_fd_type, /* 178 */ scheme_serialized_file_fd_type, /* 179 */ scheme_port_closed_evt_type, /* 180 */ - scheme_struct_proc_shape_type, /* 181 */ + scheme_proc_shape_type, /* 181 */ + scheme_struct_proc_shape_type, /* 182 */ #ifdef MZTAG_REQUIRED - _scheme_last_normal_type_, /* 182 */ + _scheme_last_normal_type_, /* 183 */ - scheme_rt_weak_array, /* 183 */ + scheme_rt_weak_array, /* 184 */ - scheme_rt_comp_env, /* 184 */ - scheme_rt_constant_binding, /* 185 */ - scheme_rt_resolve_info, /* 186 */ - scheme_rt_unresolve_info, /* 187 */ - scheme_rt_optimize_info, /* 188 */ - scheme_rt_compile_info, /* 189 */ - scheme_rt_cont_mark, /* 190 */ - scheme_rt_saved_stack, /* 191 */ - scheme_rt_reply_item, /* 192 */ - scheme_rt_closure_info, /* 193 */ - scheme_rt_overflow, /* 194 */ - scheme_rt_overflow_jmp, /* 195 */ - scheme_rt_meta_cont, /* 196 */ - scheme_rt_dyn_wind_cell, /* 197 */ - scheme_rt_dyn_wind_info, /* 198 */ - scheme_rt_dyn_wind, /* 199 */ - scheme_rt_dup_check, /* 200 */ - scheme_rt_thread_memory, /* 201 */ - scheme_rt_input_file, /* 202 */ - scheme_rt_input_fd, /* 203 */ - scheme_rt_oskit_console_input, /* 204 */ - scheme_rt_tested_input_file, /* 205 */ - scheme_rt_tested_output_file, /* 206 */ - scheme_rt_indexed_string, /* 207 */ - scheme_rt_output_file, /* 208 */ - scheme_rt_load_handler_data, /* 209 */ - scheme_rt_pipe, /* 210 */ - scheme_rt_beos_process, /* 211 */ - scheme_rt_system_child, /* 212 */ - scheme_rt_tcp, /* 213 */ - scheme_rt_write_data, /* 214 */ - scheme_rt_tcp_select_info, /* 215 */ - scheme_rt_param_data, /* 216 */ - scheme_rt_will, /* 217 */ - scheme_rt_linker_name, /* 218 */ - scheme_rt_param_map, /* 219 */ - scheme_rt_finalization, /* 220 */ - scheme_rt_finalizations, /* 221 */ - scheme_rt_cpp_object, /* 222 */ - scheme_rt_cpp_array_object, /* 223 */ - scheme_rt_stack_object, /* 224 */ - scheme_rt_preallocated_object, /* 225 */ - scheme_thread_hop_type, /* 226 */ - scheme_rt_srcloc, /* 227 */ - scheme_rt_evt, /* 228 */ - scheme_rt_syncing, /* 229 */ - scheme_rt_comp_prefix, /* 230 */ - scheme_rt_user_input, /* 231 */ - scheme_rt_user_output, /* 232 */ - scheme_rt_compact_port, /* 233 */ - scheme_rt_read_special_dw, /* 234 */ - scheme_rt_regwork, /* 235 */ - scheme_rt_rx_lazy_string, /* 236 */ - scheme_rt_buf_holder, /* 237 */ - scheme_rt_parameterization, /* 238 */ - scheme_rt_print_params, /* 239 */ - scheme_rt_read_params, /* 240 */ - scheme_rt_native_code, /* 241 */ - scheme_rt_native_code_plus_case, /* 242 */ - scheme_rt_jitter_data, /* 243 */ - scheme_rt_module_exports, /* 244 */ - scheme_rt_delay_load_info, /* 245 */ - scheme_rt_marshal_info, /* 246 */ - scheme_rt_unmarshal_info, /* 247 */ - scheme_rt_runstack, /* 248 */ - scheme_rt_sfs_info, /* 249 */ - scheme_rt_validate_clearing, /* 250 */ - scheme_rt_avl_node, /* 251 */ - scheme_rt_lightweight_cont, /* 252 */ - scheme_rt_export_info, /* 253 */ - scheme_rt_cont_jmp, /* 254 */ + scheme_rt_comp_env, /* 185 */ + scheme_rt_constant_binding, /* 186 */ + scheme_rt_resolve_info, /* 187 */ + scheme_rt_unresolve_info, /* 188 */ + scheme_rt_optimize_info, /* 189 */ + scheme_rt_compile_info, /* 190 */ + scheme_rt_cont_mark, /* 191 */ + scheme_rt_saved_stack, /* 192 */ + scheme_rt_reply_item, /* 193 */ + scheme_rt_closure_info, /* 194 */ + scheme_rt_overflow, /* 195 */ + scheme_rt_overflow_jmp, /* 196 */ + scheme_rt_meta_cont, /* 197 */ + scheme_rt_dyn_wind_cell, /* 198 */ + scheme_rt_dyn_wind_info, /* 199 */ + scheme_rt_dyn_wind, /* 200 */ + scheme_rt_dup_check, /* 201 */ + scheme_rt_thread_memory, /* 202 */ + scheme_rt_input_file, /* 203 */ + scheme_rt_input_fd, /* 204 */ + scheme_rt_oskit_console_input, /* 205 */ + scheme_rt_tested_input_file, /* 206 */ + scheme_rt_tested_output_file, /* 207 */ + scheme_rt_indexed_string, /* 208 */ + scheme_rt_output_file, /* 209 */ + scheme_rt_load_handler_data, /* 210 */ + scheme_rt_pipe, /* 211 */ + scheme_rt_beos_process, /* 212 */ + scheme_rt_system_child, /* 213 */ + scheme_rt_tcp, /* 214 */ + scheme_rt_write_data, /* 215 */ + scheme_rt_tcp_select_info, /* 216 */ + scheme_rt_param_data, /* 217 */ + scheme_rt_will, /* 218 */ + scheme_rt_linker_name, /* 219 */ + scheme_rt_param_map, /* 220 */ + scheme_rt_finalization, /* 221 */ + scheme_rt_finalizations, /* 222 */ + scheme_rt_cpp_object, /* 223 */ + scheme_rt_cpp_array_object, /* 224 */ + scheme_rt_stack_object, /* 225 */ + scheme_rt_preallocated_object, /* 226 */ + scheme_thread_hop_type, /* 227 */ + scheme_rt_srcloc, /* 228 */ + scheme_rt_evt, /* 229 */ + scheme_rt_syncing, /* 230 */ + scheme_rt_comp_prefix, /* 231 */ + scheme_rt_user_input, /* 232 */ + scheme_rt_user_output, /* 233 */ + scheme_rt_compact_port, /* 234 */ + scheme_rt_read_special_dw, /* 235 */ + scheme_rt_regwork, /* 236 */ + scheme_rt_rx_lazy_string, /* 237 */ + scheme_rt_buf_holder, /* 238 */ + scheme_rt_parameterization, /* 239 */ + scheme_rt_print_params, /* 240 */ + scheme_rt_read_params, /* 241 */ + scheme_rt_native_code, /* 242 */ + scheme_rt_native_code_plus_case, /* 243 */ + scheme_rt_jitter_data, /* 244 */ + scheme_rt_module_exports, /* 245 */ + scheme_rt_delay_load_info, /* 246 */ + scheme_rt_marshal_info, /* 247 */ + scheme_rt_unmarshal_info, /* 248 */ + scheme_rt_runstack, /* 249 */ + scheme_rt_sfs_info, /* 250 */ + scheme_rt_validate_clearing, /* 251 */ + scheme_rt_avl_node, /* 252 */ + scheme_rt_lightweight_cont, /* 253 */ + scheme_rt_export_info, /* 254 */ + scheme_rt_cont_jmp, /* 255 */ #endif _scheme_last_type_ diff --git a/src/racket/src/type.c b/src/racket/src/type.c index b99e135fe4..f0a141ebf7 100644 --- a/src/racket/src/type.c +++ b/src/racket/src/type.c @@ -710,6 +710,7 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_noninline_proc_type, small_object); GC_REG_TRAV(scheme_prune_context_type, small_object); + GC_REG_TRAV(scheme_proc_shape_type, small_object); GC_REG_TRAV(scheme_struct_proc_shape_type, small_atomic_obj); } diff --git a/src/racket/src/validate.c b/src/racket/src/validate.c index 19643e26d9..964033c723 100644 --- a/src/racket/src/validate.c +++ b/src/racket/src/validate.c @@ -122,6 +122,19 @@ static void noclear_stack_push(struct Validate_Clearing *vc, int pos) vc->ncstackpos += 1; } + +static void add_struct_mapping(Scheme_Hash_Table **_st_ht, int pos, int field_count) +{ + if (!*_st_ht) { + Scheme_Hash_Table *ht; + ht = scheme_make_hash_table_eqv(); + *_st_ht = ht; + } + scheme_hash_set(*_st_ht, + scheme_make_integer(pos), + scheme_make_integer(field_count)); +} + void scheme_validate_code(Mz_CPort *port, Scheme_Object *code, int depth, int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, @@ -155,9 +168,14 @@ void scheme_validate_code(Mz_CPort *port, Scheme_Object *code, for (i = 0; i < num_toplevels; i++) { if (SAME_TYPE(SCHEME_TYPE(toplevels[i]), scheme_module_variable_type)) { int mv_flags = SCHEME_MODVAR_FLAGS(toplevels[i]); - if (mv_flags & SCHEME_MODVAR_CONST) + if (mv_flags & SCHEME_MODVAR_CONST) { + intptr_t k; tl_state[i] = SCHEME_TOPLEVEL_CONST; - else if (mv_flags & SCHEME_MODVAR_FIXED) + if (scheme_decode_struct_shape(((Module_Variable *)toplevels[i])->shape, &k)) { + if ((k & STRUCT_PROC_SHAPE_MASK) == STRUCT_PROC_SHAPE_STRUCT) + add_struct_mapping(&st_ht, i, k >> STRUCT_PROC_SHAPE_SHIFT); + } + } else if (mv_flags & SCHEME_MODVAR_FIXED) tl_state[i] = SCHEME_TOPLEVEL_FIXED; else tl_state[i] = SCHEME_TOPLEVEL_READY; @@ -258,7 +276,8 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port, Scheme_Hash_Tree *procs, Scheme_Hash_Table **_st_ht) { - int i, size, flags, result, is_struct, field_count, field_icount, uses_super; + int i, size, flags, result, is_struct; + Simple_Stuct_Type_Info stinfo; Scheme_Object *val, *only_var; val = SCHEME_VEC_ELS(data)[0]; @@ -361,8 +380,7 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port, } if (scheme_is_simple_make_struct_type(val, size-1, 1, 1, NULL, - &field_count, &field_icount, - &uses_super, + &stinfo, NULL, (_st_ht ? *_st_ht : NULL), NULL, 0, NULL, NULL, 5)) { /* This set of bindings is constant across invocations, but @@ -371,30 +389,22 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port, is_struct = 1; } else { is_struct = 0; - uses_super = 0; - field_count = 0; - field_icount = 0; } result = validate_expr(port, val, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, - tl_state, tl_timestamp + (uses_super ? 1 : 0), + tl_state, tl_timestamp + (stinfo.uses_super ? 1 : 0), NULL, !!only_var, 0, vc, 0, 0, NULL, size-1, NULL); if (is_struct) { - if (_st_ht && (field_count == field_icount)) { + if (_st_ht && (stinfo.field_count == stinfo.init_field_count)) { /* record `struct:' binding as constant across invocations, so that it can be recognized for sub-struct declarations */ - if (!*_st_ht) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table_eqv(); - *_st_ht = ht; - } - scheme_hash_set(*_st_ht, - scheme_make_integer(SCHEME_TOPLEVEL_POS(SCHEME_VEC_ELS(data)[1])), - scheme_make_integer(field_count)); + add_struct_mapping(_st_ht, + SCHEME_TOPLEVEL_POS(SCHEME_VEC_ELS(data)[1]), + stinfo.field_count); } /* In any case, treat the bindings as constant */ result = 2; From 8aee78a4bbefd602a1206f44a288d1adbb4fa3bc Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 30 Oct 2012 17:24:04 -0600 Subject: [PATCH 077/221] fix thread-swap callbacks --- src/racket/src/thread.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/racket/src/thread.c b/src/racket/src/thread.c index df2bf732df..328d87b032 100644 --- a/src/racket/src/thread.c +++ b/src/racket/src/thread.c @@ -3032,7 +3032,7 @@ void scheme_add_swap_callback(Scheme_Closure_Func f, Scheme_Object *data) Scheme_Object *p; p = scheme_make_raw_pair((Scheme_Object *)f, data); - thread_swap_callbacks = scheme_make_pair(p, thread_swap_callbacks); + thread_swap_callbacks = scheme_make_raw_pair(p, thread_swap_callbacks); } void scheme_add_swap_out_callback(Scheme_Closure_Func f, Scheme_Object *data) From 8fab527ce355fa391c06cb5828496ec0249b4a93 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 30 Oct 2012 17:28:37 -0600 Subject: [PATCH 078/221] fix problems with `would-be-future' --- collects/tests/future/future.rkt | 2 +- src/racket/src/future.c | 22 +++++++++++++++++----- src/racket/src/future.h | 1 + src/racket/src/jitcall.c | 5 ++++- 4 files changed, 23 insertions(+), 7 deletions(-) diff --git a/collects/tests/future/future.rkt b/collects/tests/future/future.rkt index 85149cafb6..8e4a847b9c 100644 --- a/collects/tests/future/future.rkt +++ b/collects/tests/future/future.rkt @@ -635,7 +635,7 @@ We should also test deep continuations. (fsemaphore-wait m)))] [f2 (func (λ () (let* ([lst '()] - [retval (let loop ([index 10000] [l lst]) + [retval (let loop ([index 100000] [l lst]) (cond [(zero? index) l] [else diff --git a/src/racket/src/future.c b/src/racket/src/future.c index 388c591751..5e9056b6b1 100644 --- a/src/racket/src/future.c +++ b/src/racket/src/future.c @@ -582,6 +582,12 @@ void scheme_init_futures_per_place() futures_init(); } +static Scheme_Object *set_fts_thread(Scheme_Object *ignored) +{ + scheme_future_thread_state->thread = scheme_current_thread; + return ignored; +} + void futures_init(void) { Scheme_Future_State *fs; @@ -607,7 +613,8 @@ void futures_init(void) rt_fts->is_runtime_thread = 1; rt_fts->gen0_size = 1; scheme_future_thread_state = rt_fts; - rt_fts->thread = scheme_current_thread; + scheme_add_swap_callback(set_fts_thread, scheme_false); + set_fts_thread(scheme_false); REGISTER_SO(fs->future_queue); REGISTER_SO(fs->future_queue_end); @@ -957,6 +964,12 @@ void scheme_future_check_custodians() scheme_future_continue_after_gc(); } +int scheme_future_is_runtime_thread() +{ + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + return fts->is_runtime_thread; +} + /**********************************************************************/ /* Future-event logging */ /**********************************************************************/ @@ -1420,8 +1433,7 @@ static void run_would_be_future(future_t *ft) fts = scheme_future_thread_state; /* Setup the future thread state */ - fts->thread = p; - fts->thread->futures_slow_path_tracing++; + p->futures_slow_path_tracing++; scheme_use_rtcall++; savebuf = p->error_buf; @@ -1435,7 +1447,7 @@ static void run_would_be_future(future_t *ft) } scheme_use_rtcall--; - fts->thread->futures_slow_path_tracing--; + p->futures_slow_path_tracing--; ft->in_tracing_mode = 0; p->error_buf = savebuf; @@ -3590,7 +3602,7 @@ static void do_invoke_rtcall(Scheme_Future_State *fs, future_t *future) retval = _scheme_apply(arg_s0, future->arg_i0, arg_S0); future->retval_s = retval; - send_special_result(future, retval); + send_special_result(future, retval); break; } diff --git a/src/racket/src/future.h b/src/racket/src/future.h index 0f12d283b1..452f34626d 100644 --- a/src/racket/src/future.h +++ b/src/racket/src/future.h @@ -268,6 +268,7 @@ void scheme_future_continue_after_gc(); void scheme_check_future_work(); void scheme_future_gc_pause(); void scheme_future_check_custodians(); +int scheme_future_is_runtime_thread(); #endif /* MZ_USE_FUTURES */ diff --git a/src/racket/src/jitcall.c b/src/racket/src/jitcall.c index 01a436e055..97f80683da 100644 --- a/src/racket/src/jitcall.c +++ b/src/racket/src/jitcall.c @@ -157,7 +157,10 @@ static Scheme_Object *ts__scheme_tail_apply_from_native(Scheme_Object *rator, in /* try thread-local allocation: */ Scheme_Object **a; #ifdef MZ_PRECISE_GC - a = MALLOC_N(Scheme_Object *, argc); + if (scheme_future_is_runtime_thread()) + a = NULL; + else + a = MALLOC_N(Scheme_Object *, argc); #else a = NULL; /* future-local allocation is not supported */ #endif From 195cbe832cacb0ebbc2a6fabb50307ede3f9d311 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 30 Oct 2012 17:34:52 -0600 Subject: [PATCH 079/221] fix problem with compiler's cross-module shape tracking --- collects/tests/racket/module.rktl | 14 ++++++++++++++ src/racket/src/optimize.c | 8 ++++---- 2 files changed, 18 insertions(+), 4 deletions(-) diff --git a/collects/tests/racket/module.rktl b/collects/tests/racket/module.rktl index 5be611c03b..5005ae9e02 100644 --- a/collects/tests/racket/module.rktl +++ b/collects/tests/racket/module.rktl @@ -896,6 +896,20 @@ (parameterize ([current-namespace (module->namespace ''n)]) (eval '(procedure? ptr-set!))))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; check link checking and a constructor with auto fields: + +(module a-with-auto-field racket/base + (provide make-region) + (define-values (struct:region make-region region? region-get region-set!) + (make-struct-type 'region #f 6 6 #f))) + +(module use-a-with-auto-field racket/base + (require 'a-with-auto-field) + (void (make-region 1 2 3 4 5 6))) + +(require 'use-a-with-auto-field) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/src/racket/src/optimize.c b/src/racket/src/optimize.c index aa5f3b1de6..133c99ea1d 100644 --- a/src/racket/src/optimize.c +++ b/src/racket/src/optimize.c @@ -755,10 +755,10 @@ Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int int super_count = (super_count_plus_one ? (super_count_plus_one - 1) : 0); - _stinfo->field_count = SCHEME_INT_VAL(app->args[3]) + super_count; - _stinfo->init_field_count = (SCHEME_INT_VAL(app->args[3]) - + SCHEME_INT_VAL(app->args[4]) - + super_count); + _stinfo->init_field_count = SCHEME_INT_VAL(app->args[3]) + super_count; + _stinfo->field_count = (SCHEME_INT_VAL(app->args[3]) + + SCHEME_INT_VAL(app->args[4]) + + super_count); _stinfo->uses_super = (super_count_plus_one ? 1 : 0); _stinfo->normal_ops = 1; _stinfo->indexed_ops = 0; From f07c8cf4907e283ab590b3528534b9784cd12c7f Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 30 Oct 2012 16:58:24 -0500 Subject: [PATCH 080/221] changed the colorer so that it doesn't use a co-routine; instead, refactor it so it doesn't add anything to the continuation ever, and just check if it has been a while since we started (giving other events a chance to run, if so). Also, interleave the calls to change-style with the parsing of the buffer to get a more accurate count of the time the colorer is taking --- collects/framework/private/color.rkt | 243 +++++++++++++-------------- 1 file changed, 117 insertions(+), 126 deletions(-) diff --git a/collects/framework/private/color.rkt b/collects/framework/private/color.rkt index 7a6102c5a7..fd5767831c 100644 --- a/collects/framework/private/color.rkt +++ b/collects/framework/private/color.rkt @@ -6,17 +6,15 @@ added reset-regions added get-regions |# -(require mzlib/class - mzlib/thread - mred +(require racket/class + racket/gui/base syntax-color/token-tree syntax-color/paren-tree syntax-color/default-lexer string-constants "../preferences.rkt" "sig.rkt" - "aspell.rkt" - framework/private/logging-timer) + "aspell.rkt") (import [prefix icon: framework:icon^] [prefix mode: framework:mode^] @@ -238,11 +236,9 @@ added get-regions (start-colorer token-sym->style get-token pairs))) ;; ---------------------- Multi-threading --------------------------- - ;; A list of (vector style number number) that indicate how to color the buffer - (define colorings null) - ;; The coroutine object for tokenizing the buffer - (define tok-cor #f) - ;; The editor revision when tok-cor was created + ;; If there is some incomplete coloring waiting to happen + (define colorer-pending? #f) + ;; The editor revision when the last coloring was started (define rev #f) @@ -276,18 +272,9 @@ added get-regions (update-lexer-state-observers) (set! restart-callback #f) (set! force-recolor-after-freeze #f) - (set! colorings null) - (when tok-cor - (coroutine-kill tok-cor)) - (set! tok-cor #f) + (set! colorer-pending? #f) (set! rev #f)) - ;; Actually color the buffer. - (define/private (color) - (for ([clr (in-list colorings)]) - (change-style (vector-ref clr 0) (vector-ref clr 1) (vector-ref clr 2) #f)) - (set! colorings '())) - ;; Discard extra tokens at the first of invalid-tokens (define/private (sync-invalid ls) (let ([invalid-tokens (lexer-state-invalid-tokens ls)] @@ -303,60 +290,91 @@ added get-regions (set-lexer-state-invalid-tokens-mode! ls mode)) (sync-invalid ls)))) - (define/private (re-tokenize ls in in-start-pos in-lexer-mode enable-suspend) - (enable-suspend #f) - ;(define-values (_line1 _col1 pos-before) (port-next-location in)) - (define-values (lexeme type data new-token-start new-token-end backup-delta new-lexer-mode) - (get-token in in-start-pos in-lexer-mode)) - ;(define-values (_line2 _col2 pos-after) (port-next-location in)) - (enable-suspend #t) - (unless (eq? 'eof type) - (unless (exact-nonnegative-integer? new-token-start) - (error 'color:text<%> "expected an exact nonnegative integer for the token start, got ~e" new-token-start)) - (unless (exact-nonnegative-integer? new-token-end) - (error 'color:text<%> "expected an exact nonnegative integer for the token end, got ~e" new-token-end)) - (unless (exact-nonnegative-integer? backup-delta) - (error 'color:text<%> "expected an exact nonnegative integer for the backup delta, got ~e" backup-delta)) - (unless (0 . < . (- new-token-end new-token-start)) - (error 'color:text<%> "expected the distance between the start and end position for each token to be positive, but start was ~e and end was ~e" new-token-start new-token-end)) - (enable-suspend #f) - #; (printf "~s at ~a to ~a\n" lexeme (+ in-start-pos (sub1 new-token-start)) - (+ in-start-pos (sub1 new-token-end))) - (let ((len (- new-token-end new-token-start))) - #; - (unless (= len (- pos-after pos-before)) - ;; this check requires the two calls to port-next-location to be also uncommented - ;; when this check fails, bad things can happen non-deterministically later on - (eprintf "pos changed bad ; len ~s pos-before ~s pos-after ~s (token ~s mode ~s)\n" - len pos-before pos-after lexeme new-lexer-mode)) - (set-lexer-state-current-pos! ls (+ len (lexer-state-current-pos ls))) - (set-lexer-state-current-lexer-mode! ls new-lexer-mode) - (sync-invalid ls) - (when (and should-color? (should-color-type? type) (not frozen?)) - (add-colorings type in-start-pos new-token-start new-token-end)) - ;; Using the non-spec version takes 3 times as long as the spec - ;; version. In other words, the new greatly outweighs the tree - ;; operations. - ;;(insert-last! tokens (new token-tree% (length len) (data type))) - (insert-last-spec! (lexer-state-tokens ls) len (make-data type new-lexer-mode backup-delta)) - #; (show-tree (lexer-state-tokens ls)) - (send (lexer-state-parens ls) add-token data len) - (cond - [(and (not (send (lexer-state-invalid-tokens ls) is-empty?)) - (= (lexer-state-invalid-tokens-start ls) - (lexer-state-current-pos ls)) - (equal? new-lexer-mode - (lexer-state-invalid-tokens-mode ls))) - (send (lexer-state-invalid-tokens ls) search-max!) - (send (lexer-state-parens ls) merge-tree - (send (lexer-state-invalid-tokens ls) get-root-end-position)) - (insert-last! (lexer-state-tokens ls) - (lexer-state-invalid-tokens ls)) - (set-lexer-state-invalid-tokens-start! ls +inf.0) - (enable-suspend #t)] - [else - (enable-suspend #t) - (re-tokenize ls in in-start-pos new-lexer-mode enable-suspend)])))) + (define/private (start-re-tokenize start-time) + (set! re-tokenize-lses lexer-states) + (re-tokenize-move-to-next-ls start-time)) + + (define/private (re-tokenize-move-to-next-ls start-time) + (cond + [(null? re-tokenize-lses) + ;; done: return #t + #t] + [else + (set! re-tokenize-ls-argument (car re-tokenize-lses)) + (set! re-tokenize-lses (cdr re-tokenize-lses)) + (set! re-tokenize-in-start-pos (lexer-state-current-pos re-tokenize-ls-argument)) + (set! re-tokenize-lexer-mode-argument (lexer-state-current-lexer-mode re-tokenize-ls-argument)) + (set! re-tokenize-in-argument + (open-input-text-editor this + (lexer-state-current-pos re-tokenize-ls-argument) + (lexer-state-end-pos re-tokenize-ls-argument) + (λ (x) #f))) + (port-count-lines! re-tokenize-in-argument) + (continue-re-tokenize start-time #t)])) + + (define re-tokenize-lses #f) + (define re-tokenize-ls-argument #f) + (define re-tokenize-in-argument #f) + (define re-tokenize-in-start-pos #f) + (define re-tokenize-lexer-mode-argument #f) + (define/private (continue-re-tokenize start-time did-something?) + (cond + [(and did-something? ((+ start-time 20) . <= . (current-inexact-milliseconds))) + #f] + [else + ;(define-values (_line1 _col1 pos-before) (port-next-location in)) + (define-values (lexeme type data new-token-start new-token-end backup-delta new-lexer-mode) + (get-token re-tokenize-in-argument re-tokenize-in-start-pos re-tokenize-lexer-mode-argument)) + ;(define-values (_line2 _col2 pos-after) (port-next-location in)) + (cond + [(eq? 'eof type) + (re-tokenize-move-to-next-ls start-time)] + [else + (unless (exact-nonnegative-integer? new-token-start) + (error 'color:text<%> "expected an exact nonnegative integer for the token start, got ~e" new-token-start)) + (unless (exact-nonnegative-integer? new-token-end) + (error 'color:text<%> "expected an exact nonnegative integer for the token end, got ~e" new-token-end)) + (unless (exact-nonnegative-integer? backup-delta) + (error 'color:text<%> "expected an exact nonnegative integer for the backup delta, got ~e" backup-delta)) + (unless (0 . < . (- new-token-end new-token-start)) + (error 'color:text<%> "expected the distance between the start and end position for each token to be positive, but start was ~e and end was ~e" new-token-start new-token-end)) + #; (printf "~s at ~a to ~a\n" lexeme (+ in-start-pos (sub1 new-token-start)) + (+ in-start-pos (sub1 new-token-end))) + (let ((len (- new-token-end new-token-start))) + #; + (unless (= len (- pos-after pos-before)) + ;; this check requires the two calls to port-next-location to be also uncommented + ;; when this check fails, bad things can happen non-deterministically later on + (eprintf "pos changed bad ; len ~s pos-before ~s pos-after ~s (token ~s mode ~s)\n" + len pos-before pos-after lexeme new-lexer-mode)) + (set-lexer-state-current-pos! re-tokenize-ls-argument (+ len (lexer-state-current-pos re-tokenize-ls-argument))) + (set-lexer-state-current-lexer-mode! re-tokenize-ls-argument new-lexer-mode) + (sync-invalid re-tokenize-ls-argument) + (when (and should-color? (should-color-type? type) (not frozen?)) + (add-colorings type re-tokenize-in-start-pos new-token-start new-token-end)) + ;; Using the non-spec version takes 3 times as long as the spec + ;; version. In other words, the new greatly outweighs the tree + ;; operations. + ;;(insert-last! tokens (new token-tree% (length len) (data type))) + (insert-last-spec! (lexer-state-tokens re-tokenize-ls-argument) len (make-data type new-lexer-mode backup-delta)) + #; (show-tree (lexer-state-tokens ls)) + (send (lexer-state-parens re-tokenize-ls-argument) add-token data len) + (cond + [(and (not (send (lexer-state-invalid-tokens re-tokenize-ls-argument) is-empty?)) + (= (lexer-state-invalid-tokens-start re-tokenize-ls-argument) + (lexer-state-current-pos re-tokenize-ls-argument)) + (equal? new-lexer-mode + (lexer-state-invalid-tokens-mode re-tokenize-ls-argument))) + (send (lexer-state-invalid-tokens re-tokenize-ls-argument) search-max!) + (send (lexer-state-parens re-tokenize-ls-argument) merge-tree + (send (lexer-state-invalid-tokens re-tokenize-ls-argument) get-root-end-position)) + (insert-last! (lexer-state-tokens re-tokenize-ls-argument) + (lexer-state-invalid-tokens re-tokenize-ls-argument)) + (set-lexer-state-invalid-tokens-start! re-tokenize-ls-argument +inf.0) + (re-tokenize-move-to-next-ls start-time)] + [else + (set! re-tokenize-lexer-mode-argument new-lexer-mode) + (continue-re-tokenize start-time #t)]))])])) (define/private (add-colorings type in-start-pos new-token-start new-token-end) (define sp (+ in-start-pos (sub1 new-token-start))) @@ -377,22 +395,23 @@ added get-regions [lp 0]) (cond [(null? spellos) - (set! colorings (cons (vector color (+ sp lp) (+ sp (string-length str))) - colorings))] + (add-coloring color (+ sp lp) (+ sp (string-length str)))] [else (define err (car spellos)) (define err-start (list-ref err 0)) (define err-len (list-ref err 1)) - (set! colorings (list* (vector color (+ pos lp) (+ pos err-start)) - (vector misspelled-color (+ pos err-start) (+ pos err-start err-len)) - colorings)) + (add-coloring misspelled-color (+ pos err-start) (+ pos err-start err-len)) + (add-coloring color (+ pos lp) (+ pos err-start)) (loop (cdr spellos) (+ err-start err-len))])) (loop (cdr strs) (+ pos (string-length str) 1))))] [else - (set! colorings (cons (vector color sp ep) colorings))])] + (add-coloring color sp ep)])] [else - (set! colorings (cons (vector color sp ep) colorings))])) + (add-coloring color sp ep)])) + + (define/private (add-coloring color sp ep) + (change-style color sp ep #f)) (define/private (show-tree t) (printf "Tree:\n") @@ -487,52 +506,24 @@ added get-regions (define/private (colorer-driver) (unless (andmap lexer-state-up-to-date? lexer-states) - #;(printf "revision ~a\n" (get-revision-number)) - (unless (and tok-cor (= rev (get-revision-number))) - (when tok-cor - (coroutine-kill tok-cor)) - #;(printf "new coroutine\n") - (set! tok-cor - (coroutine - (λ (enable-suspend) - (parameterize ((port-count-lines-enabled #t)) - (for-each - (lambda (ls) - (re-tokenize ls - (begin - (enable-suspend #f) - (begin0 - (open-input-text-editor this - (lexer-state-current-pos ls) - (lexer-state-end-pos ls) - (λ (x) #f)) - (enable-suspend #t))) - (lexer-state-current-pos ls) - (lexer-state-current-lexer-mode ls) - enable-suspend)) - lexer-states))))) - (set! rev (get-revision-number))) - (with-handlers ((exn:fail? - (λ (exn) - (parameterize ((print-struct #t)) - ((error-display-handler) - (format "exception in colorer thread: ~s" exn) - exn)) - (set! tok-cor #f)))) - #;(printf "begin lexing\n") - (when (log-timeline "colorer coroutine" (coroutine-run 10 tok-cor)) - (for-each (lambda (ls) - (set-lexer-state-up-to-date?! ls #t)) - lexer-states) - (update-lexer-state-observers))) - #;(printf "end lexing\n") - #;(printf "begin coloring\n") - ;; This edit sequence needs to happen even when colors is null - ;; for the paren highlighter. (begin-edit-sequence #f #f) - (color) - (end-edit-sequence) - #;(printf "end coloring\n"))) + (define finished? + (cond + [(and colorer-pending? (= rev (get-revision-number))) + (continue-re-tokenize (current-inexact-milliseconds) #f)] + [else + (set! rev (get-revision-number)) + (start-re-tokenize (current-inexact-milliseconds))])) + (cond + [finished? + (set! colorer-pending? #f) + (for-each (lambda (ls) + (set-lexer-state-up-to-date?! ls #t)) + lexer-states) + (update-lexer-state-observers)] + [else + (set! colorer-pending? #t)]) + (end-edit-sequence))) (define/private (colorer-callback) (cond From f852b9eb92a96b856960624cdd660f166026cd8c Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 31 Oct 2012 03:30:17 -0400 Subject: [PATCH 081/221] New Racket version 5.3.1.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.manifest | 2 +- src/worksp/racket/racket.rc | 8 ++++---- src/worksp/starters/start.rc | 8 ++++---- 7 files changed, 21 insertions(+), 21 deletions(-) diff --git a/src/worksp/gracket/gracket.manifest b/src/worksp/gracket/gracket.manifest index 554cc91d26..be453af939 100644 --- a/src/worksp/gracket/gracket.manifest +++ b/src/worksp/gracket/gracket.manifest @@ -1,6 +1,6 @@ - diff --git a/src/worksp/gracket/gracket.rc b/src/worksp/gracket/gracket.rc index b181b0e526..2a01d35cc1 100644 --- a/src/worksp/gracket/gracket.rc +++ b/src/worksp/gracket/gracket.rc @@ -11,8 +11,8 @@ APPLICATION ICON DISCARDABLE "gracket.ico" // VS_VERSION_INFO VERSIONINFO - FILEVERSION 5,3,1,3 - PRODUCTVERSION 5,3,1,3 + FILEVERSION 5,3,1,4 + PRODUCTVERSION 5,3,1,4 FILEFLAGSMASK 0x3fL #ifdef _DEBUG FILEFLAGS 0x1L @@ -30,11 +30,11 @@ BEGIN VALUE "CompanyName", "PLT Scheme Inc.\0" VALUE "FileDescription", "Racket GUI application\0" VALUE "InternalName", "GRacket\0" - VALUE "FileVersion", "5, 3, 1, 3\0" + VALUE "FileVersion", "5, 3, 1, 4\0" VALUE "LegalCopyright", "Copyright 1995-2012\0" VALUE "OriginalFilename", "GRacket.exe\0" VALUE "ProductName", "Racket\0" - VALUE "ProductVersion", "5, 3, 1, 3\0" + VALUE "ProductVersion", "5, 3, 1, 4\0" END END BLOCK "VarFileInfo" diff --git a/src/worksp/mzcom/mzcom.rc b/src/worksp/mzcom/mzcom.rc index de1aa178d9..49894811a4 100644 --- a/src/worksp/mzcom/mzcom.rc +++ b/src/worksp/mzcom/mzcom.rc @@ -53,8 +53,8 @@ END // VS_VERSION_INFO VERSIONINFO - FILEVERSION 5,3,1,3 - PRODUCTVERSION 5,3,1,3 + FILEVERSION 5,3,1,4 + PRODUCTVERSION 5,3,1,4 FILEFLAGSMASK 0x3fL #ifdef _DEBUG FILEFLAGS 0x1L @@ -70,12 +70,12 @@ BEGIN BLOCK "040904b0" BEGIN VALUE "FileDescription", "MzCOM Module" - VALUE "FileVersion", "5, 3, 1, 3" + VALUE "FileVersion", "5, 3, 1, 4" VALUE "InternalName", "MzCOM" VALUE "LegalCopyright", "Copyright 2000-2012 PLT (Paul Steckler)" VALUE "OriginalFilename", "MzCOM.EXE" VALUE "ProductName", "MzCOM Module" - VALUE "ProductVersion", "5, 3, 1, 3" + VALUE "ProductVersion", "5, 3, 1, 4" END END BLOCK "VarFileInfo" diff --git a/src/worksp/mzcom/mzobj.rgs b/src/worksp/mzcom/mzobj.rgs index 4e22bbca1d..53dd11f37d 100644 --- a/src/worksp/mzcom/mzobj.rgs +++ b/src/worksp/mzcom/mzobj.rgs @@ -1,19 +1,19 @@ HKCR { - MzCOM.MzObj.5.3.1.3 = s 'MzObj Class' + MzCOM.MzObj.5.3.1.4 = s 'MzObj Class' { CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}' } MzCOM.MzObj = s 'MzObj Class' { CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}' - CurVer = s 'MzCOM.MzObj.5.3.1.3' + CurVer = s 'MzCOM.MzObj.5.3.1.4' } NoRemove CLSID { ForceRemove {A3B0AF9E-2AB0-11D4-B6D2-0060089002FE} = s 'MzObj Class' { - ProgID = s 'MzCOM.MzObj.5.3.1.3' + ProgID = s 'MzCOM.MzObj.5.3.1.4' VersionIndependentProgID = s 'MzCOM.MzObj' ForceRemove 'Programmable' LocalServer32 = s '%MODULE%' diff --git a/src/worksp/racket/racket.manifest b/src/worksp/racket/racket.manifest index 679d7ea6b0..47847c2b36 100644 --- a/src/worksp/racket/racket.manifest +++ b/src/worksp/racket/racket.manifest @@ -1,6 +1,6 @@ - diff --git a/src/worksp/racket/racket.rc b/src/worksp/racket/racket.rc index fdd1c324b9..8662cd5d4d 100644 --- a/src/worksp/racket/racket.rc +++ b/src/worksp/racket/racket.rc @@ -11,8 +11,8 @@ APPLICATION ICON DISCARDABLE "racket.ico" // VS_VERSION_INFO VERSIONINFO - FILEVERSION 5,3,1,3 - PRODUCTVERSION 5,3,1,3 + FILEVERSION 5,3,1,4 + PRODUCTVERSION 5,3,1,4 FILEFLAGSMASK 0x3fL #ifdef _DEBUG FILEFLAGS 0x1L @@ -30,11 +30,11 @@ BEGIN VALUE "CompanyName", "PLT Scheme Inc.\0" VALUE "FileDescription", "Racket application\0" VALUE "InternalName", "Racket\0" - VALUE "FileVersion", "5, 3, 1, 3\0" + VALUE "FileVersion", "5, 3, 1, 4\0" VALUE "LegalCopyright", "Copyright 1995-2012\0" VALUE "OriginalFilename", "racket.exe\0" VALUE "ProductName", "Racket\0" - VALUE "ProductVersion", "5, 3, 1, 3\0" + VALUE "ProductVersion", "5, 3, 1, 4\0" END END BLOCK "VarFileInfo" diff --git a/src/worksp/starters/start.rc b/src/worksp/starters/start.rc index c9066fa134..6473fddb25 100644 --- a/src/worksp/starters/start.rc +++ b/src/worksp/starters/start.rc @@ -22,8 +22,8 @@ APPLICATION ICON DISCARDABLE "mzstart.ico" // VS_VERSION_INFO VERSIONINFO - FILEVERSION 5,3,1,3 - PRODUCTVERSION 5,3,1,3 + FILEVERSION 5,3,1,4 + PRODUCTVERSION 5,3,1,4 FILEFLAGSMASK 0x3fL #ifdef _DEBUG FILEFLAGS 0x1L @@ -45,7 +45,7 @@ BEGIN #ifdef MZSTART VALUE "FileDescription", "Racket Launcher\0" #endif - VALUE "FileVersion", "5, 3, 1, 3\0" + VALUE "FileVersion", "5, 3, 1, 4\0" #ifdef MRSTART VALUE "InternalName", "mrstart\0" #endif @@ -60,7 +60,7 @@ BEGIN VALUE "OriginalFilename", "MzStart.exe\0" #endif VALUE "ProductName", "Racket\0" - VALUE "ProductVersion", "5, 3, 1, 3\0" + VALUE "ProductVersion", "5, 3, 1, 4\0" END END BLOCK "VarFileInfo" From 08c659c5d532da69eeb0db5b09a57f50b0023a86 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 31 Oct 2012 08:03:47 -0600 Subject: [PATCH 082/221] =?UTF-8?q?fix=20a=20bug=20in=20`free-identifier?= =?UTF-8?q?=3D=3F'?= The bug is related to macro-introduced `require' and rename on export. --- collects/tests/racket/syntax.rktl | 22 ++++++++++++++++++++++ src/racket/src/syntax.c | 7 ++++++- 2 files changed, 28 insertions(+), 1 deletion(-) diff --git a/collects/tests/racket/syntax.rktl b/collects/tests/racket/syntax.rktl index a73c98fefc..26ee859ff5 100644 --- a/collects/tests/racket/syntax.rktl +++ b/collects/tests/racket/syntax.rktl @@ -1637,6 +1637,28 @@ f-id (eval '(extract f f2 f2 #t)))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Check interaction of marks, `rename-out', and `free-identifier=?' + +(module check-free-eq-with-rename racket/base + (require (for-syntax racket/base)) + (provide (rename-out [prefix:quote quote]) + check) + (define-syntax (check stx) + (syntax-case stx () + [(_ id) #`#,(free-identifier=? #'id #'prefix:quote)])) + (define-syntax-rule (prefix:quote x) (quote x))) + +(module use-rename-checker racket/base + (define-syntax-rule (body) + (begin + (provide v) + (require 'check-free-eq-with-rename) + (define v (check quote)))) + (body)) + +(test #t dynamic-require ''use-rename-checker 'v) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/src/racket/src/syntax.c b/src/racket/src/syntax.c index f3b197934f..6559ba94a9 100644 --- a/src/racket/src/syntax.c +++ b/src/racket/src/syntax.c @@ -4549,7 +4549,12 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ if (SCHEME_FALSEP(bdg)) bdg = get_old_module_env(a); } - result = search_shared_pes(mrn->shared_pes, glob_id, a, bdg, NULL, 1, 0, NULL); + rename = search_shared_pes(mrn->shared_pes, glob_id, a, bdg, NULL, 1, 0, NULL); + if (rename) { + if (mrn->kind == mzMOD_RENAME_MARKED) + skip_other_mods = 1; + result = rename; + } } else { /* match; set result: */ if (mrn->kind == mzMOD_RENAME_MARKED) From 226a7140b5784531103e10338785249a37aac677 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 31 Oct 2012 09:42:49 -0500 Subject: [PATCH 083/221] fix a bug in the colorer refactoring As it turns out, changing the color (via change-style) can somtimes split snips, which can change the revision number, which means that the open port into the editor is no longer valid. Since this doesn't seem to happen very much when editing in DrRacket, we just detect this situation and give up on this colorer's port, and hopefully it actually doesn't happen much (the place it happened that let me notice this was when inserting an image via a menu in the drracket test suites) --- collects/framework/private/color.rkt | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/collects/framework/private/color.rkt b/collects/framework/private/color.rkt index fd5767831c..58d84c510a 100644 --- a/collects/framework/private/color.rkt +++ b/collects/framework/private/color.rkt @@ -310,6 +310,7 @@ added get-regions (lexer-state-end-pos re-tokenize-ls-argument) (λ (x) #f))) (port-count-lines! re-tokenize-in-argument) + (set! rev (get-revision-number)) (continue-re-tokenize start-time #t)])) (define re-tokenize-lses #f) @@ -319,7 +320,8 @@ added get-regions (define re-tokenize-lexer-mode-argument #f) (define/private (continue-re-tokenize start-time did-something?) (cond - [(and did-something? ((+ start-time 20) . <= . (current-inexact-milliseconds))) + [(or (not (= rev (get-revision-number))) + (and did-something? ((+ start-time 20) . <= . (current-inexact-milliseconds)))) #f] [else ;(define-values (_line1 _col1 pos-before) (port-next-location in)) @@ -512,7 +514,6 @@ added get-regions [(and colorer-pending? (= rev (get-revision-number))) (continue-re-tokenize (current-inexact-milliseconds) #f)] [else - (set! rev (get-revision-number)) (start-re-tokenize (current-inexact-milliseconds))])) (cond [finished? From fdfa5bf134ce215e9b4aac01defe62680acba78a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 31 Oct 2012 10:14:39 -0500 Subject: [PATCH 084/221] add docs for get-spell-check-strings and set-spell-check-strings --- collects/scribblings/framework/color.scrbl | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/collects/scribblings/framework/color.scrbl b/collects/scribblings/framework/color.scrbl index 646e96c994..4407978c3c 100644 --- a/collects/scribblings/framework/color.scrbl +++ b/collects/scribblings/framework/color.scrbl @@ -154,6 +154,17 @@ Sets the currently active regions to be @racket[regions]. } + + @defmethod[(get-spell-check-strings) boolean?]{ + Returns @racket[#t] if the colorer will attempt to + spell-check string constants. + } + + @defmethod[(set-spell-check-strings [b? boolean?]) void?]{ + If called with @racket[#t], tell the colorer to spell-check + string constants. Otherwise, disable spell-checking of constants. + } + @defmethod*[(((get-regions) (listof (list/c number? (or/c (quote end) number?)))))]{ This returns the list of regions that are currently being colored in the editor. From 9582fe830ae4d0db3b71a02b78d3546521b63bc2 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 31 Oct 2012 10:15:28 -0500 Subject: [PATCH 085/221] add logging to the colorer --- collects/framework/private/color.rkt | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) diff --git a/collects/framework/private/color.rkt b/collects/framework/private/color.rkt index 58d84c510a..e340683e51 100644 --- a/collects/framework/private/color.rkt +++ b/collects/framework/private/color.rkt @@ -320,8 +320,10 @@ added get-regions (define re-tokenize-lexer-mode-argument #f) (define/private (continue-re-tokenize start-time did-something?) (cond - [(or (not (= rev (get-revision-number))) - (and did-something? ((+ start-time 20) . <= . (current-inexact-milliseconds)))) + [(not (= rev (get-revision-number))) + (c-log "revision number changed unexpectedly") + #f] + [(and did-something? ((+ start-time 20) . <= . (current-inexact-milliseconds))) #f] [else ;(define-values (_line1 _col1 pos-before) (port-next-location in)) @@ -509,19 +511,22 @@ added get-regions (define/private (colorer-driver) (unless (andmap lexer-state-up-to-date? lexer-states) (begin-edit-sequence #f #f) + (c-log "starting to color") (define finished? (cond [(and colorer-pending? (= rev (get-revision-number))) (continue-re-tokenize (current-inexact-milliseconds) #f)] [else (start-re-tokenize (current-inexact-milliseconds))])) + (c-log (format "coloring stopped ~a" (if finished? "because it finished" "with more to do"))) (cond [finished? (set! colorer-pending? #f) (for-each (lambda (ls) (set-lexer-state-up-to-date?! ls #t)) lexer-states) - (update-lexer-state-observers)] + (update-lexer-state-observers) + (c-log "updated observers")] [else (set! colorer-pending? #t)]) (end-edit-sequence))) @@ -1141,3 +1146,9 @@ added get-regions (define text-mode% (text-mode-mixin mode:surrogate-text%)) (define misspelled-text-color-style-name "Misspelled Text") + +(define logger (make-logger 'framework/colorer (current-logger))) +(define-syntax-rule + (c-log exp) + (when (log-level? logger 'debug) + (log-message logger 'debug exp (current-inexact-milliseconds)))) From 8f73ebbc36dcb66afa1051889c4e0636f50be5f4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 31 Oct 2012 12:17:24 -0600 Subject: [PATCH 086/221] fix error-message code Closes PR 13222 --- collects/tests/racket/udp.rktl | 14 ++++++++++++++ src/racket/src/network.c | 6 ++++-- 2 files changed, 18 insertions(+), 2 deletions(-) diff --git a/collects/tests/racket/udp.rktl b/collects/tests/racket/udp.rktl index 12c565e3ce..ce4d45331b 100644 --- a/collects/tests/racket/udp.rktl +++ b/collects/tests/racket/udp.rktl @@ -178,3 +178,17 @@ (test w sync w)) (test #t evt? (udp-receive!-evt udp1 us1)) (test #t evt? (udp-send-to-evt udp1 "127.0.0.1" port #"here's more")) + + +;; check that error-repoting doesn't crash: +(let () + (define (q) + (define s (udp-open-socket #f #f)) + (udp-bind! s #f 5999) + s) + + (define s (q)) + (err/rt-test (q) exn:fail:network?) + (udp-close s)) + + diff --git a/src/racket/src/network.c b/src/racket/src/network.c index 446b52a3ca..af10f4736a 100644 --- a/src/racket/src/network.c +++ b/src/racket/src/network.c @@ -3225,7 +3225,8 @@ static Scheme_Object *udp_bind_or_connect(const char *name, int argc, Scheme_Obj " port number: %d\n" " system error: %E", name, - port, address ? address : "#f", + address ? address : "#f", + port, SOCK_ERRNO()); return NULL; } @@ -3257,7 +3258,8 @@ static Scheme_Object *udp_bind_or_connect(const char *name, int argc, Scheme_Obj " port number: %d\n" " system error: %E", name, - port, address ? address : "#f", + address ? address : "#f", + port, SOCK_ERRNO()); return NULL; } From 45a5cfca12be47d617993004d88c9c3efa78bd17 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Wed, 31 Oct 2012 14:53:28 -0400 Subject: [PATCH 087/221] basic history, please merge --- doc/release-notes/teachpack/HISTORY.txt | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/doc/release-notes/teachpack/HISTORY.txt b/doc/release-notes/teachpack/HISTORY.txt index 6f480b0057..a2479a554a 100644 --- a/doc/release-notes/teachpack/HISTORY.txt +++ b/doc/release-notes/teachpack/HISTORY.txt @@ -1,3 +1,7 @@ +Version 5.3.1 [Wed Oct 31 14:52:48 EDT 2012] + +* bug fixes + ------------------------------------------------------------------------ Version 5.2.1 [Thu Jan 19 11:36:19 EST 2012] From b9a0eaf5da30f877a0562c8f681111c3ce80876c Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Wed, 31 Oct 2012 15:31:50 -0600 Subject: [PATCH 088/221] Adding an example for equal<%> --- collects/scribblings/reference/class.scrbl | 37 ++++++++++++++++++++++ 1 file changed, 37 insertions(+) diff --git a/collects/scribblings/reference/class.scrbl b/collects/scribblings/reference/class.scrbl index 25261ec274..26047c1895 100644 --- a/collects/scribblings/reference/class.scrbl +++ b/collects/scribblings/reference/class.scrbl @@ -2052,6 +2052,43 @@ See @racket[prop:equal+hash] for more information on equality comparisons and hash codes. The @racket[equal<%>] interface is implemented with @racket[interface*] and @racket[prop:equal+hash].} +Example: +@codeblock|{ +#lang racket + +;; Case insensitive words: +(define ci-word% + (class* object% (equal<%>) + + ;; Initialization + (init-field word) + (super-new) + + ;; We define equality to ignore case: + (define/public (equal-to? other recur) + (string-ci=? word (get-field word other))) + + ;; The hash codes need to be insensitive to casing as well. + ;; We'll just downcase the word and get its hash code. + (define/public (equal-hash-code-of hash-code) + (hash-code (string-downcase word))) + + (define/public (equal-secondary-hash-code-of hash-code) + (hash-code (string-downcase word))))) + +;; We can create a hash with a single word: +(define h (make-hash)) +(hash-set! h (new ci-word% [word "inconceivable!"]) 'value) + +;; Lookup into the hash should be case-insensitive, so that +;; both of these should return 'value. +(hash-ref h (new ci-word% [word "inconceivable!"])) +(hash-ref h (new ci-word% [word "INCONCEIVABLE!"])) + +;; Comparison fails if we use a non-ci-word%: +(hash-ref h "inconceivable!" 'i-dont-think-it-means-what-you-think-it-means) +}| + @; ------------------------------------------------------------------------ @section[#:tag "objectserialize"]{Object Serialization} From e2d74f2cf3b12c62916aeecf2a2acabcc6b1f77e Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 31 Oct 2012 16:52:01 -0500 Subject: [PATCH 089/221] streamline the objects that are sent across the channel from the expansion place to the main drracket place during online check syntax --- collects/drracket/private/syncheck/gui.rkt | 22 +++++------ .../drracket/private/syncheck/online-comp.rkt | 38 ++++++++++++------- 2 files changed, 35 insertions(+), 25 deletions(-) diff --git a/collects/drracket/private/syncheck/gui.rkt b/collects/drracket/private/syncheck/gui.rkt index 245e34747a..c18fb6f83b 100644 --- a/collects/drracket/private/syncheck/gui.rkt +++ b/collects/drracket/private/syncheck/gui.rkt @@ -1606,26 +1606,26 @@ If the namespace does not, they are colored the unbound color. ;; using 'defs-text' all the time is wrong in the case of embedded editors, ;; but they already don't work and we've arranged for them to not appear here .... (match x - [`(syncheck:add-arrow ,start-text ,start-pos-left ,start-pos-right - ,end-text ,end-pos-left ,end-pos-right - ,actual? ,level) + [`#(syncheck:add-arrow ,start-pos-left ,start-pos-right + ,end-pos-left ,end-pos-right + ,actual? ,level) (send defs-text syncheck:add-arrow defs-text start-pos-left start-pos-right defs-text end-pos-left end-pos-right actual? level)] - [`(syncheck:add-tail-arrow ,from-text ,from-pos ,to-text ,to-pos) + [`#(syncheck:add-tail-arrow ,from-pos ,to-pos) (send defs-text syncheck:add-tail-arrow defs-text from-pos defs-text to-pos)] - [`(syncheck:add-mouse-over-status ,text ,pos-left ,pos-right ,str) + [`#(syncheck:add-mouse-over-status ,pos-left ,pos-right ,str) (send defs-text syncheck:add-mouse-over-status defs-text pos-left pos-right str)] - [`(syncheck:add-background-color ,text ,color ,start ,fin) + [`#(syncheck:add-background-color ,color ,start ,fin) (send defs-text syncheck:add-background-color defs-text color start fin)] - [`(syncheck:add-jump-to-definition ,text ,start ,end ,id ,filename) + [`#(syncheck:add-jump-to-definition ,start ,end ,id ,filename) (send defs-text syncheck:add-jump-to-definition defs-text start end id filename)] - [`(syncheck:add-require-open-menu ,text ,start-pos ,end-pos ,file) + [`#(syncheck:add-require-open-menu ,start-pos ,end-pos ,file) (send defs-text syncheck:add-require-open-menu defs-text start-pos end-pos file)] - [`(syncheck:add-docs-menu ,text ,start-pos ,end-pos ,key ,the-label ,path ,definition-tag ,tag) + [`#(syncheck:add-docs-menu,start-pos ,end-pos ,key ,the-label ,path ,definition-tag ,tag) (send defs-text syncheck:add-docs-menu defs-text start-pos end-pos key the-label path definition-tag tag)] - [`(syncheck:add-rename-menu ,id-as-sym ,to-be-renamed/poss ,name-dup-pc ,name-dup-id) + [`#(syncheck:add-rename-menu ,id-as-sym ,to-be-renamed/poss ,name-dup-pc ,name-dup-id) (define other-side-dead? #f) (define (name-dup? name) (cond @@ -1643,7 +1643,7 @@ If the namespace does not, they are colored the unbound color. #f])])) (define to-be-renamed/poss/fixed (for/list ([lst (in-list to-be-renamed/poss)]) - (list defs-text (list-ref lst 1) (list-ref lst 2)))) + (list defs-text (list-ref lst 0) (list-ref lst 1)))) (send defs-text syncheck:add-rename-menu id-as-sym to-be-renamed/poss/fixed name-dup?)])) diff --git a/collects/drracket/private/syncheck/online-comp.rkt b/collects/drracket/private/syncheck/online-comp.rkt index 0cd315ba1a..4101e6e1fd 100644 --- a/collects/drracket/private/syncheck/online-comp.rkt +++ b/collects/drracket/private/syncheck/online-comp.rkt @@ -1,6 +1,7 @@ #lang racket/base (require racket/class racket/place + (for-syntax racket/base) "../../private/eval-helpers.rkt" "traversals.rkt" "local-member-names.rkt" @@ -34,26 +35,35 @@ (define/override (syncheck:find-source-object stx) (and (equal? src (syntax-source stx)) src)) - (define-syntax-rule - (log name) - (define/override (name . args) - (set! trace (cons (cons 'name args) trace)))) + + ;; send over the non _ variables in the message to the main drracket place + (define-syntax (log stx) + (syntax-case stx () + [(_ name args ...) + (with-syntax ([(wanted-args ...) + (filter (λ (x) (not (regexp-match #rx"^_" (symbol->string (syntax-e x))))) + (syntax->list #'(args ...)))]) + #'(define/override (name args ...) + (add-to-trace (vector 'name wanted-args ...))))])) - ; (log syncheck:color-range) ;; we don't want log these as they are too distracting to keep popping up - (log syncheck:add-mouse-over-status) - (log syncheck:add-arrow) - (log syncheck:add-tail-arrow) - (log syncheck:add-background-color) - (log syncheck:add-require-open-menu) - (log syncheck:add-docs-menu) - (log syncheck:add-jump-to-definition) + (log syncheck:add-arrow + _start-text start-pos-left start-pos-right + _end-text end-pos-left end-pos-right + actual? level) + (log syncheck:add-tail-arrow _from-text from-pos _to-text to-pos) + (log syncheck:add-mouse-over-status _text pos-left pos-right str) + (log syncheck:add-background-color _text color start fin) + (log syncheck:add-jump-to-definition _text start end id filename) + (log syncheck:add-require-open-menu _text start-pos end-pos file) + (log syncheck:add-docs-menu _text start-pos end-pos key the-label path definition-tag tag) (define/override (syncheck:add-rename-menu id-as-sym to-be-renamed/poss dup-name?) (define id (hash-count table)) (hash-set! table id dup-name?) - (set! trace (cons (list 'syncheck:add-rename-menu id-as-sym to-be-renamed/poss remote id) - trace))) + (add-to-trace (vector 'syncheck:add-rename-menu id-as-sym (map cdr to-be-renamed/poss) remote id))) (define/public (get-trace) (reverse trace)) + (define/private (add-to-trace thing) + (set! trace (cons thing trace))) (super-new))) (define (go expanded path the-source orig-cust) From b2b350eff50bb91c701afb9254864a47699b1be7 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 31 Oct 2012 19:51:22 -0500 Subject: [PATCH 090/221] fix typesetting of builtin non-terminals --- 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 9f946da119..a7bfccef06 100644 --- a/collects/redex/private/core-layout.rkt +++ b/collects/redex/private/core-layout.rkt @@ -3,6 +3,7 @@ (require "loc-wrapper.rkt" "matcher.rkt" "reduction-semantics.rkt" + "underscore-allowed.rkt" texpict/utils texpict/mrpict @@ -702,7 +703,7 @@ (list (non-terminal->token col span nt) (make-pict-token (+ col span) 0 sub+sup)))])] [(or (memq atom all-nts) - (memq atom '(number variable variable-except variable-not-otherwise-mentioned))) + (memq atom underscore-allowed)) (list (non-terminal->token col span (symbol->string atom)))] [(symbol? atom) (list (or (rewrite-atomic col span atom literal-style) From 0e71f2d5dc58bd497a686f23c0ed0781590a3dc6 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 31 Oct 2012 21:13:01 -0400 Subject: [PATCH 091/221] Fix accidental use of the wrong letrec-bound variable. --- collects/tests/typed-racket/succeed/exn-any.rkt | 15 +++++++++++++++ collects/typed-racket/utils/any-wrap.rkt | 4 ++-- 2 files changed, 17 insertions(+), 2 deletions(-) create mode 100644 collects/tests/typed-racket/succeed/exn-any.rkt diff --git a/collects/tests/typed-racket/succeed/exn-any.rkt b/collects/tests/typed-racket/succeed/exn-any.rkt new file mode 100644 index 0000000000..131aec6e28 --- /dev/null +++ b/collects/tests/typed-racket/succeed/exn-any.rkt @@ -0,0 +1,15 @@ +#lang racket/load + +(module m typed/racket + (struct: s ()) + + (struct: s2 s ()) + (define: v : Any (s2)) + (provide v)) + +(module n racket + (require 'm) + v) + +(require 'n) + diff --git a/collects/typed-racket/utils/any-wrap.rkt b/collects/typed-racket/utils/any-wrap.rkt index 4cecd411b5..3ebcd0bea3 100644 --- a/collects/typed-racket/utils/any-wrap.rkt +++ b/collects/typed-racket/utils/any-wrap.rkt @@ -14,7 +14,7 @@ (define (wrap-struct s) (define (extract-functions struct-type) (define-values (sym init auto ref set! imms par skip?) - (struct-type-info type)) + (struct-type-info struct-type)) (when skip? (fail s)) ;; "Opaque struct type!") (define-values (fun/chap-list _) (for/fold ([res null] @@ -36,7 +36,7 @@ res) imms)))) (cond - [par (cons fun/chap-list (extract-functions par))] + [par (append fun/chap-list (extract-functions par))] [else fun/chap-list])) (define-values (type skipped?) (struct-info s)) (when skipped? (fail s)); "Opaque struct type!" From f2fd47905f4fe981dea4bda03fd08bd930dc63a1 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 31 Oct 2012 21:39:16 -0400 Subject: [PATCH 092/221] Fix binding of `udp?`. --- collects/typed-racket/types/abbrev.rkt | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/collects/typed-racket/types/abbrev.rkt b/collects/typed-racket/types/abbrev.rkt index cadae87bee..517b645184 100644 --- a/collects/typed-racket/types/abbrev.rkt +++ b/collects/typed-racket/types/abbrev.rkt @@ -14,12 +14,11 @@ ;; avoid the other dependencies of `racket/place` '#%place unstable/function - racket/udp unstable/lazy-require (except-in racket/contract/base ->* -> one-of/c) (prefix-in c: racket/contract/base) (for-syntax racket/base syntax/parse racket/list) - (for-template racket/base racket/contract/base racket/promise racket/tcp racket/flonum) + (for-template racket/base racket/contract/base racket/promise racket/tcp racket/flonum racket/udp) racket/pretty racket/udp ;; for base type predicates racket/promise racket/tcp racket/flonum) From a57e158c43b25fac9803cb1af399e53b97144df0 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 30 Oct 2012 13:42:20 -0400 Subject: [PATCH 093/221] Correct TR types for udp-bind! and udp-connect!. --- collects/typed-racket/base-env/base-env.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/typed-racket/base-env/base-env.rkt b/collects/typed-racket/base-env/base-env.rkt index 6f9b4754eb..fcb090e39d 100644 --- a/collects/typed-racket/base-env/base-env.rkt +++ b/collects/typed-racket/base-env/base-env.rkt @@ -1484,8 +1484,8 @@ ;;racket/udp [udp-open-socket (->opt [(-opt -String) (-opt -String)] -UDP-Socket)] -[udp-bind! (-> -UDP-Socket (-opt -String) -PosInt)] -[udp-connect! (-> -UDP-Socket (-opt -String) -PosInt)] +[udp-bind! (-> -UDP-Socket (-opt -String) -Nat -Void)] +[udp-connect! (-> -UDP-Socket (-opt -String) (-opt -Nat) -Void)] [udp-send-to (->opt -UDP-Socket -String -Nat -Bytes [-Nat -Nat] -Void)] [udp-send (->opt -UDP-Socket -Bytes [-Nat -Nat] -Void)] From e7dc4a70ee289f2803a10588bcfd92c87d904688 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 31 Oct 2012 21:48:21 -0500 Subject: [PATCH 094/221] fix redex bitmap tests under linux --- ...eduction-relation-with-computed-labels.png | Bin 7458 -> 7771 bytes 1 file changed, 0 insertions(+), 0 deletions(-) diff --git a/collects/redex/tests/bmps-unix/reduction-relation-with-computed-labels.png b/collects/redex/tests/bmps-unix/reduction-relation-with-computed-labels.png index 372980cb931ecff972db8b73241ec0033e2bf952..afdee97e3f8a6b7efd320e4e76f4312e26132b66 100644 GIT binary patch literal 7771 zcmaJ`bzD?IyIw@PLpofMlI{kjl?DYxSfrb!7nf8)N5Ij|u*M>mQD8YLlY)tS4B1p%OkfR%_^`nvG`Ly zE-d@@IxnHRc|j)O5S(^4%0V8q_b=TaD=5el6Kho`Utgk6yuC~QxkamSuS36J^n82D zb8p3Ge1dX1Y^E`|JT2NE-WmZu5$YD=@Y(b+=EsoIUWOk0fFG~aA94plJ0C{ zRPGDaB=MNnl@8Rk{Dl2VLQz@6%`fqUEH|VR(TfH_{XQa zGYJigEE$7V12*NVDbh3Jnd?q2E=x-hG8U~tBnDNEP2(%rgKSuYbdR%!`H)9eoSdAS z^@)LjSm{a;EDs<0Z*OnsDk^A2fB8b%*4g6 z2>g!bt5;9W%pR7MlpwcMRaBUuP_&gkg0?7D4U3JT%wzS@)y36SMGp_rTEw2k)!Dv5 zjceyPGtRyyO#%i@_9pJ}CQ1d~+!@6Rh9xevXbNR}7;${&kN*%-O%e`|?X- zqH2G#)T=V9$l0+n92}gh1tQ-!qxrAyVqiqZ#dW;Lz>DWI#e}rAwfXz|^LqSw<1p7y zz+LIIqzLmqexa(W3i)$z@IXi?CX|wA^i^nMqYMiROYcoeK>-)oKyxs*sHmvpQhOK{ zg9w!2MOg10as{pF>FH=cKfgLqf>-A=U zy1F_cqxTWX^~Leh`C3Yr@9ho5&Hd0#oL=XLs`2i0wWx#y`il>(;o;$B_EWk^JW^6g zX=xA2v$X549cF5BQfl3Io@J>g1%-y{OsOY|HqAGEK=q@JDJUqUMV};SIXm<7G+yyH z-d^wF5D;X#to5~XKMe{T8sN;fz;mFOfEA<%mFJ zrKP2f-cwLgN=Mmz6?ICRjE#;4g%~*N6&xHqJ~_F#xR_RvnUOKSww5K5QdwCEs{%j& zH1DQ3c5$n>u&_9tX<9Awz4g(}fB79oh_hd1t4i@)0KNF<&*3dJGYbpn%@OwI=4MA{ z=R5PDCZl6xN2}A~fe_0|6mxjaP(wEx; z5Pp7sO>zaE&$(OWm6eTqgu-#l%VxSou->K*Shh!Z0z3?aSnzVKQ#a+oE@{)!()RT9 zh`O#5YYP1qcUe_+<1H5k>qLI_fo& znfdrgbaZrB)V^i-^x_ZHBH*fOYOiWs*YSTDqtK8wy(Q}LbN(ljnp2F?7}eF)UDYmYM-5!sEt&cGs$Yfezm+2PVCZp1A_cm64_R0q0n|P}KM$#` ztu3|eXQ+ScDxSpeysXR&g*H(!D2l6~l21a{vgi=?vBn{4*pt zZM{*hG9x47Nk6$@=KTDd(ITUW+FFUu&Q4B)s^a!aWk_abW_&^d?RQzIyf+G)(zLs? zvuR```ebM7FIu+Bc`O5_*f;wer+@>+m;DE8AQzmM+6gKgW}azjMV4%m$Vx&-948um zWneIvYO-YY?4CV|Y*39=>Lzt+z2|9e{{c3%wPgr`Pbd00j8??N-rjy2=})YIP2dOW zv1E%_R?>KR>H*aMiET6T0xgpBEd4^8XyjKa{xn{zHTReyLz2DE9Q>jZcOji6iiF;#d|J z7Mc)q-j>_^{vKxQ0V)<2EQ5oC5Kg0pt4Obv_v%@uYkf)W-02@9q%VR}Q}2VyaM;%N zw~GGt>oFj^{nOK|)YQlJMH&=#?8+VstFR)Zq;(DWo81G#gLv(qAnt z9|qHv$Vf?L-Q9&9Sq+}4s8EYI&;g!k>g((CTM-EZ^H5Kg>;y3U$uJ}tD)+J2Zi4?W z>W4GRIQ(POWGT6yU80Gfe{{5bJZ99< z+e@INq(n+e`m(`GYn&L96U=SrBJ{Cd9vMEyVvmgltdsEP&X+ZT~81R)1TvGp=SiLf-&u8@2DRe z8$-EXSLE|K{r(KK5^VJPF6edU7|Z!e*2hPBXRzbxN$(vp?!{we3!O0g=Py`dpyD ztE#I})h@jozuuu+3DQWP&7%XoEg$u-YxwrCS0p$zbO~THl8jY7@i!p+jp=FuLPEmv zsi~jND_!DxC!??7#@5zPZ*Q)@3R;r}5-}=f4VQrK2aE4F$rA;L@bCACTYv4n*?K-9 zA#+ghX6EL60CMW>73Af4-M7aveHr0wTcZU_Q5w>G?$okW@^U{Rkd^QpovcSso;-PG z?{jl*$;`x*K5BjXh=W5%TSq4bv=Fk_SH{7?;aQ$;fsLI62ZxH2v$Hnv35-ZuHFF?o z+qs_v1ukxECcmnLlxGD0JSP7Q@g4`T@vCav=kt9ioA1WCwyu zNOObe2g)V}I0o<&vy6<969Sv;lqbi>GIIzmkkXKA$fUui<_Id z2G!1)PrCcQ38@$gb91W$nV+-oQpn8AETs4`LB-LLcWbPuV`e4^=p71fgO^LMA7;~h z7Zwo_kqwXyx+5$F8@DWfEww}e%kao9Qd!B}MB|g*KQxmU zSC@I|gd5e88K5D4nsyKZe`60e$|FO$O7bBY85xU4a?dv*+i&KclPZ+w9@mqXeLtD6 zUeCfv{BOSmWF*Ndr#*dgu&otm1tG%hcq5`R1@dgbkMU@8xWuk437K03 zc4Ef145Y=GgBR+(;}6>z&zABU#w+&**7fl-we_A(p8uTY=CU6-xDCJI!Ljr)3ksyn z>N6+4m{b0EguL>>WUVar+qQjsM#LDPp2c)*hY2TOG~WhQR+7Y3bj;Y=l{96Ov!zF*BfxB@|7v9ifpc@pfEyY*A!!NipF}LQMp)ZnU$U}W4r`GI zNH_X~{|eSAt|fCkS5T;HbQfE>cMsBYYa=CGkcZSwu*4cVNaii*j*NP-=kD(DgNZMv zbKO;(E_owcM8kNWKzDmw@wxUL^Lr~tzOzZUBG!*8?DJ7?)swpCpWO(-Tu)njM#^AQ z4nbJ-5!o4x9yJ97dyT@e%SS2IFSMJlDrX%I#J_dz^78t# zzi-^^k7JWS{n*NiZFO}OP}mk1F#|&%5N)DB$_Wb#pIuz=gW|xV0J!|*`Sa*WDH;I_ zeBhhuB-}rNT*Cyou&^)!fXOR4S;@`){X`rb9Do3VLqeK|hQ0uun6m|Z*44O$hgSh~{v03wGD2>&EI&V=O4RZGQb$C`=x8jw@jAA`eyib=buLO;Ic z5^i_mb6uK5luA5$k1#r?AJr`oy;)+16jH1nt~9{MrDcLR#tQd0>mtsPKEy^lL`$J? z_rtaxNO)%EP`N4VER`^6m|{x}++AR~X2`jeBXV1>Y2H8HIY=%W8 zNkO=JHgDT9=RPkSt&h@Qp3r*?&P0X%TwPk&&Q)(T)bC1_QA^LP#yGrU9qt*b$yoC;9VXe?`I;@6lao>s=Z94|b%#@95XYUN zn8HTifEJm=Hy&_CH|d>BJS(}IFw+io2y(_XVbuPQ?}qs!jy!JL_IlAz072-2BGBhG zOpjX{lqz>!uV%2-EtAv1Tbn9!iaE#|<)T@S>YJLTj^;Iy{=7@u;TnQQXUCC*8#j5; zuX?4O_}3J+dAgewyQrB$fn@GRhv!8rHczBGd{vjI6Wot(P;g#8KD1nyqyXl~vgtjBsF+xZ!;CltZ~_p8 zSidGGzX3y0;5~}?~}^V=$fKruAV3#?{-K zcLO(mhe}e3kENiPe#C{A%dHT*cgAR<{iWLHCsk6KjxAihV@TWMyHY|fNQ zt-EOnzU|(lxH~^S7>*~VS6p7Pia^J7$;Vmy~MRjUK%u5Gbpbp(AUy5cwRKw z1Hr|^JNCJ|la=E0Kt?8o&$NBSll6ZK;x>(TkB(eJLP9`9`LV_T*p-w zk~j&F{JZPHWUN$@9>wAsZUq4W0mp^?1LO*S6J~iOB{FL239~p^RBi{8L#*JH&$olF zTt33XEdBNJgi4PPuqO2t7yf$3MjJNbhN!29pz--oRxhvm7&pfIV!xE~Bh`+xs^`#* z^kLyEN%sZsP6>~KQtTBF-T{Sc=Ie!z6~Wk2^Ma!RR{S!lf1o2>tiRf(trBi(Zv3j~ zq6Y#Jo}-2ZHujtgm66XzhM&U274uO1PK)y8TE?mlcwL>Zp^kuIX$Cf0@fG7k34`YpBI zK@sY$wGR)$b3=>i89a}Z2}_Vn5YP~Z1qU~^wPAqdubk`Aqi1l=wOM)~K3PEoRz#5N zegya$VrFKR$`&%)lv9YBoo$#srXB)H^LJ;baa+heOq^I7o*K_w^n8Nj3qNT7+@;1r zXzoo({$x2lfZX5G-U%5Mv8xm>U%hk|WXADZoT`kk9-0D8oRO7<{-QnraL`!w0}w=lDjb0+czH>JP*6zwXqR5* z-)x%u$p2^4Y*`8HfvL$is2-Z1`YLKdei_lGtq&WWH`h~5cxO**yWP>C8aM_sIo>6% z=*LTwd!2yAV?d-)Zq>ATdfRhVG-|qb$xpasWNbzM!3RX|UVH+6MJIc0CLS`Xu=d<2sN#?b{HB)9+ZBnxmGt;Mhs( zO6@D0U5~n)Hns;+i)s@>pb;G?BMGXT#M;BXJ$GyNaG#=sqBf3=v8800O@vgHm5GV0 zy!>4dO-N1Jh`$_~L zx@To#`T!1W7MGVZDvTPuzM`RH65qQQ@Imgn@S1@YJPz z$`m6J*mK;MJ<9h&l-lp}w4}Hon$6c1_RggF-T{>`rmqBpF@O^p*R4@C0!lZ(`=X-p z`T3k6!9R-qSzg}O+q?6w>CQl!0v_^ceK0#oRYQZ7J!ez?5gXgD)>eOz>8xXfrm@u> z_DO*3N;^b|YDlWhbT7Xj%;M}4T6MMkY*w&+0mX(pap!@Wm{f<1X4yut{zBJf$ z>yv7|G+@YKOzZzI>F|vP@3PpbazH5YVkeX*l=Pn_Z-nOtoF1uYYmdTUtRsSn+dR-BPb}=Nh-Ib^u9X zy73?!{&D(n420sqV|>rg2leL;9IoM*vn;lgQTePqV)-|TVgy4kh(f`wGWa%uZC%~0 zlN%cwi%U$TGchswR?7lyC3}os?6x&ZLk1#Gy)B(;S!^vv8gK*#ISzAyR65Kog1O?; z2xj+T1Q0L!sDk)n)?3ew#wATT5pDUp!w9u1S0mX6UWjE0eJ z{4Sp7{+;K0pXdJLIXh?joNb@8Yw!2_des%KuBveRCiP7S1ae#PxvVAxfRm&A=x6(d&4+BdYk$azQQ$*nP5O?vBHWfZc!Kdk_e|N9!V$g#C<)(EDc?vX4e}dI!MwQeY+TZ(lC>-? z1WbMMcR!J~zGZ1id@e8lG5Z+wNm;TD3 zOzr+1j4dl`YZcam^vWHYtl}wAD=QYtp|4mN8Q&G^mR7i8blkafM@Clm z`q|l;dr6JUs*-7aDhCILoao8mQClG~F)>*M1w(OiX1npCS7!&S zetRwW@x*drc*-wc$mNdQAtw)xjC_%TLjM^GN>69}^5sjd)8aKJ))pJMfqWFL;?t+s zR8>{i!l#3mmX?0~`enA<85vL9@#Ju=f2!J^W@>6m<-6!-8W9IQaTX@(EW;Xy;Ex}N zi}WkSC-%|khk}BmW=Yg$BRMbh3=Nl;mos@Ln|wvU^1Xa~mR48g+}s2ccubqu@isNB zTRz-iVP%a?Onjau?Z3Cb|EdErc}ra9fJQ^}z`QJv2b_7A1Gl;ebe7 zD7{ZuwsOK-#@C(M29A+jHQk+uP^hU!;aJa)XQ4ZFCid=s|Ni|t*W^o6L`hDbrSeTs z@zUpXZ?UI6oD5wmVn3Z#^>#}0F(>CJPlL-U>>8VCAjUmq`HhmP-+l02{(S{meXLlAOu^52c#u0idt8^aHmmY1gxfzXhU5H`=$ z@V?&Owzjs+X^WQ=;{NAHe0l4en*|Ky*TP`12P`bX!NJ$x+S@Cts8}5R8Je7)-kivX z)ugAVA9GFz_w@95ZNn$n9zSN{;<_y%A)y?~BAY41!T_;>2vXmsprAMpfn_Z0?nWmk z(|{>y8ydO;H;4=k#a~@r9TV106Q_>sT!1TOKg}K4FvY)qePLnYiKgb=AbgTXTwIZ- zr(QwgFZZ#{T*~Z^A1`Jnn7nQeyCW+vZy-*~q>{mOmJY-F+1=f}pu#93l8~toU18aK zuikCr+Rr2b>)*C;A>q*&aUqR-ZE(w%#Kd3V-MxbYero0d*u>OS-Q0F^Z>{rkSX9*7 z*?L-y8{5-F74!3I>YrU*p|PxLo0QW?Waf~~WVty$q@$ywy|XhzGvD@Y9+UfyWos~@ zg|&6%+o=lMK|B{1m$LHmA7FHD+s=kJOAo78e({kTua@JK&gE zTX(gF+zJm5Z|UwP)Ya9+Bcd`BRCTTSI9iwBu|0i!sF_D<0Zz0HiFcvpdNUZ;wh^4#ohAUY?%63L`C(S zJw0`2W@qCfD0#-~=04pQI6@z9BXikc8F}O#PO5Xm!^1vOfo8<1si`xK-m&)uta#rH zvt+sy>qNle@EZ@vo{olUe7N(JK6iBqfznR>nIsGXpt2MmmbQ{fQAf{xS4VCcq^m zBrGyTq@qz1fESpkS%icrQdAYx)k%egh0j;ryYZ!bju_e4!m_ehxQ%KdGm5+h#qpn+ z6~4s8yo-&Ez27F10@lFK&p%n~oSFS>$oF(H^z5LQM^RbXe7fq**SI)+zy+Jd|HB17 zV~78N3(VE?*lzA3E~T5BnX;ACp)vUva$;s8{r8FltV*9cu=_pvzBY1 z8UT>8)Y7C+PfyEUcii;%wzXyFjy9LYOebpLFP1E=5SGsPg ziAt(u(uWV%=DgSGuHoW}IW0ic&jjEM0jEs3_{1!LF97AfHaB;6cYg?q1*nAI@6^d8 z;LOqoy?Nt_zW#mJwZ6sTnmPW-_?jA#q@<+pQoi>nDHCj$lSG{#$jQmU=?PqICQ9gj z{P+RL(RFk5aYQ>~aK0c5gAF8#PNH+6B`ESHC}MxTJ4(H9jEGh=rZ<5{AQ1c4SNQaz zG8&7y7^${5BxaEQ1ke>iC*fhSJq?Et(TRWEZN7-&GOQ*A>>d$utL@`$W+S;Nf>s#rLeay{W!e`?8n1{z2jOip2dDz2IDtLAr!VAAD*%KKV zoc?4H5q4TZ8&X@eqsX_9ME6@i+_+U6fDyN!uF9`&0f2Ldfng9V2@qD+CbyS~Nvd?q z(Z)zudQ@RyVSqXTBRe|`kmTLFcgx`LhkSgWhcXq+?d<{|k;_`&{l><|0y@AqKpWMW0KR#TiysydVSaJEU1g6PA6^8wgzm?8 zTIc=}9ZkZjmMX}uqO81(Dn;P2^Z4K6GLZH164lYs856d0bc~kIeAN|22O+1VB%`5; zP|7Yi8BhTbwYBv&p36|)!omWMT3J~!GdF(*_6=&bIsY-Nbsl>xGG1)R3fL%SGx$!!FXsbPevjMexrz!A5PY@u_55Z( z-`RF~+K!YMOMD0l0<8!R33=HtFpwev5F{VSVAn~w9VICDN&nPW(j1+6KZvJPgdk9~ zMn*L-fm2$^b`vGefSSbJH)RWTimA&u;(+{d^7IrrO;w2l!fvF- z(G;*@NMWH}5TGpy&z*MAGKbmvD}tvPSO-ol9Gi5vyRzW z<0~fPHfhu=trxKB`#mvRFzS{*aBc*5T37%36OiC|r+8M=Gt=ZiTW1pJr;} zZcUcAEufCopcp|2;_pF(Wyam7lBA>Wh9;0|-$mamWw#=c$OkfnO!P!!0YeTmwa$5C zw$j*BbLDoHV6P`s{i9XR%kohSP;MyWqhK4spxu_Yv-NSSy$Oft2~!ap7_c(6$0)Tme1_eU-)Ar(sah+uDy3^ee4CfB&u$5Fia~$kuE_0?@@^^f~D= zNtZ~JTv6j(@{!bX`ua&jEMo%J16AsJPs8xv|97>#CpG@PTK`4+|3^lZCsPeSH>|KA z)XGu$0bqP>>gNf5-$==+Ici>3YkGVYqx+201<(ANhlfXzal`oVD+1^F&)3bb0a5mL zvg|!DD}vp}E(Zhr_8q=L@qrZ>QLp%(O3*jxsjxGv^3Obr*U zMq39r2H%l|8{e!YmqCCjpd^I3z+_X+SHEsG!e@-{`M=n^D@!Kni)t>jnAp_tE2=kB z6%QlsalIbR(}+~%cXoCLv_=YyTR=bn9MxDY`QF20%rwfso;gnU^2B(?n0|H8SjuL0 zxLRXB@tKAq;ozr>H2H^!s}FC&B5=YkPH_iJnk@?UzRj%7URqsXn;=`Fdt}KT{&tID z1?y++v5lW=zsIg07I2x?xnyITlH=lT%*2@ukBkuBy4BX-U;HM+9s)Obp{hy@con#~ zU+FSIS7M%kfM5YgyxR_}|I`BVtD$Otd!lfmch3HX*`jvET*8>7{FB6dI0Ns~e{yX& zz8%$J#O_96ks{W?Ra`BDzN}l9Af|SO8I|zG4J2YI0#)++cJ9mYrPd-C`&{r zn>+H^dy|ESgs{p@Z_MTGNIWHWChcK2s(@>EC=*{sMuz3#L+8cT8w&%Br8@UHjo`jl;XX8ZJ3fckpaEv$VR*p-Xp$jl1(?qoj|H zK@tB#7;l>;*S{_QaGh$hE!i8T@RvGpJ@Kvl+> zk73X+w(Gkw5EXw%KFifrNS{g5HD6?p zKvA@5bf&iuAzXakT6=(EdvoCzNmA(0hFh(;D0PvRx{>VPkM3LIZtsw*mVfIC@h`1s zET*d~1oU?QY{VKh21Me}o7fZ;ZB}9G>nF=#H*^UH*Yb~O7C+#%+Br$@cy8< z%$v=NfXHL!5tV`-;^QPzZ`IdOsEE>1o>#A4om*1Bdyy>s%HBRQIyzb=WE)vi3GxJB zcY~Umq*_{9fCCz@-Jfmnyz=E99>VN#Fko59C@B>HA42rX%y5kB-G1cdg$db>t7~Yq zfH6uEcV|~W+i3E?@BkcT^?Rq_Wnrz`#$BL?aLoRm?sFQ|?xhmS7mif~V0_rw*=?n4 za_-%`*I6?k&^w&1e04j>3k39$^MBVBI&b^W+0^Z74gN0o$LBUisD`L2JP(9Iz#qk5 z2r5oaYF_f6i%#myjEd%UoVER^61}!ifY!?oY|tDKO==r&YB+m4p_(IkdDnx>pyF~; zgPYQ59o%>3c5K9L($Kl5KcWZqUzs4V|?iinXA7@3x3P4E4nD2xVQ@0AF%sM$tq=J?ded9}}k8VKq zI=+D)UD~nq7uzRN@TJE0e=E1#b*LEpp5a(Sk7wV1dBiMzaiV%qgF&t&#GZ)X+mz^< z>7PpKKaBr9(}{;%<9e>YM=vT}2^0@g<=^5f#;U6wmiR#Bb~tS3u1TtqOp8t!qSkp)r7S_+M+r&>V+Cfw_$ z)|cg+v|GsEhuyjA`PvX89?q;6g*tHhTaZ%L0OVztME#yu*XI17P=4{?`;BwDCx!R8 zoB){hX|bYG&Hg3c(YJa*%|O27x;`M3cq$<(dYT&9(cVtgxHFG{+9Ru1_ZHjE2|FY_ zw(=0!5^jIgn=f`Gs^3mM1zwDso12J6_)~kkEG8-^D@$Ed^Qo6tZS!nFZ|#4{b`{ik zv3|3kcQO9YQQ(!sK7Go17E1gVbPMEE0~Yr4wfdhj*v?h8bZdHhL<58qOw^={P1lB7 zaMnGx#auRnH9qWnZ4vsr)ET**d#8&Q8GW@CX+hB}l*j&m7)F*VZ5Jr#u9xN!pyT6NsZgK)x}yPNp!clc~? zf#4!6I@iOUmR_it9Ol!y@WDeC#9f}d;XjNC{U0~T?IUUhBC|H znC&At`}l_sAACBj9T3=a4xsle$BXnOFB|tQRm@*TYRqspy)5;yq=>V29w&iXl+B#~ z2(2^Lv8oENr>oqIt%m`haOrzm^hPg#tS|YLk``H&eROOu$*S=Ct81@aZ;y=!>-}%a zNF9$A77Q66h_AZZdt++QJv5e~+-~X%+I0=*g)8Ug@cK_dOo`Hdv0+u&8=b2^3gRxa zqKvAl1G0Q+#162$K=Rer)$uvbNz&5MfjrR5%Zth==WoDot!&NvjWW2`t~oh5F+P4A z-V%f#8y_$4=hrBcQlLk}|IU`1RrR|W5P(3|#IvS)wQ?eDUX2jtdTgKVW=Eh)CURbK zsHQ-3O>?*!`s)f4oHrKCDo#N!CtX)aFLX`yh^)1QF$q3;CTRD8^MOOJVFE)qRMTEw9sOCh6vo} zmuOKCy9Xd>I7`F-EfXZ8rtaxW5)gA|G}-EN=n%=e9B2v4x~2BmJcd-H|i& zXfQ!9F`L^Udx+O#)@?3Z&F0QH!_}<&voR?RDmi<5&q($MMiG3z=$qd^q_w$^9-h7w zAkEXv*Q1t588gi`6IjvL#`W364|vhipU-SM;G5hYh#|X3e=pid{&V3?=^q}7n(f3mxfqhb`Vmxg_4XQ0t0~!dR}Q2H=zUa36MyK1KYn0 z@>vi7V9wE37FJ037?=V9yKzpCcdEU4^BAx?69_{7xR2-U?d^BIk?TIK=o$foEdle93y?C>p%-NA zASu9NPY{>YdnKX$;pF4s$=X!}7s(GHi01a6mQD?YW_T5A937VU$Gn_|9acT;Fn zY|sq|W3Ay0x9^gHQ9v|F4h_LgYFb}(6m?}FJd6E_ZTt`ohuDVfvEj#VqNW3et(Aj+ zciJ!|p>!|VDgN6`h9Y%LiN4LDNX#DpH;bv8g1_|75RZbH;^hc-pr zJ>z9zy=C3z>Dk%h&dvagf`ceN4H}r*?0->VH^FUWjPjs6Ran~Ijs%Aj8X6k4wY6rJ zmX=3?D9=!mg8^&Bzji|n_h6bclsj&=S0ngie%AZ)A<&(O5t1_7&MjN>Iv+GU$f4bK zW~M}2K(cm+jI7OdP^#+|Pvh@AMw(?XlUs95$>C(IUy_o#W7VYdd9=twe*S#2HkcL- z65o#3g1MlUQS`;M=4aT8U1uk!mHf(HD-@b$)&Gsp_xSBO8r4;7i1y7> zC1BdgdEdjcd39Pvbf5ovp5ONdAXELYXX_wn?##fs$%L&Hga8g487#Z;J45akIC`+O z@*)K;`jSM*EXD}vO1(xez7z@1M=UJuuiq0gVNZ!tu?E04Dk>_@H2WvtrV$3wysnlM zQ*ho(`1}e6l!x%<%_U&BtwBmKHb(X|%wX&^?}?KWZvwaRQYb@!&1PaSDG7nl&u>C@ zpKgMzvkmzAWN~_?c3j!py#D8Im_Bz12&6%-JA??lq~^HEBx|n?%U}cN6jr-)O`oXv zK7bsd5}f3LArH%#%p20`UVuIEbLJ a48oH{Irg1ovf$7Yq9~^-Tk_QG!~X+8Q{w#q From 0e4305fc45c457824936607f61d06bbe8b4ea02c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 1 Nov 2012 07:19:19 -0600 Subject: [PATCH 095/221] fix problem with places and `struct-type-info' Merge to v5.3.1 --- collects/tests/racket/place-struct-info.rkt | 20 +++++++++++++++ src/racket/src/error.c | 1 + src/racket/src/schpriv.h | 2 ++ src/racket/src/struct.c | 27 ++++++++++++--------- 4 files changed, 39 insertions(+), 11 deletions(-) create mode 100644 collects/tests/racket/place-struct-info.rkt diff --git a/collects/tests/racket/place-struct-info.rkt b/collects/tests/racket/place-struct-info.rkt new file mode 100644 index 0000000000..fcb2fa9301 --- /dev/null +++ b/collects/tests/racket/place-struct-info.rkt @@ -0,0 +1,20 @@ +#lang racket/base +(require racket/place) + +;; Some results from `struct-type-info' may be created on demand. +;; Check that any sharing of `struct:exn' across places handles +;; that on-demand creation correctly. + +(define (go) + (place + pch + (define-values (sym init auto ref set! imms par skip?) + (struct-type-info struct:exn)) + (unless (procedure? ref) + (error "bad reference procedure")) + (collect-garbage))) + +(module+ main + (void (place-wait (go))) + (collect-garbage) + (void (place-wait (go)))) diff --git a/src/racket/src/error.c b/src/racket/src/error.c index c4b02768ec..5bbbd2aba4 100644 --- a/src/racket/src/error.c +++ b/src/racket/src/error.c @@ -4313,6 +4313,7 @@ void scheme_init_exn(Scheme_Env *env) if (exn_table[i].count) { Scheme_Object **values; + scheme_force_struct_type_info((Scheme_Struct_Type *)exn_table[i].type); values = scheme_make_struct_values(exn_table[i].type, exn_table[i].names, exn_table[i].count, diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index 5c517c9d22..e8a9f8e73d 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -850,6 +850,8 @@ Scheme_Object *scheme_make_serialized_struct_instance(Scheme_Object *s, int num_ Scheme_Object *scheme_struct_getter(int argc, Scheme_Object **args, Scheme_Object *prim); Scheme_Object *scheme_struct_setter(int argc, Scheme_Object **args, Scheme_Object *prim); +void scheme_force_struct_type_info(Scheme_Struct_Type *stype); + Scheme_Object *scheme_extract_checked_procedure(int argc, Scheme_Object **argv); Scheme_Object *scheme_rename_struct_proc(Scheme_Object *p, Scheme_Object *sym); diff --git a/src/racket/src/struct.c b/src/racket/src/struct.c index 50813ef4b1..c57ec32185 100644 --- a/src/racket/src/struct.c +++ b/src/racket/src/struct.c @@ -2643,18 +2643,8 @@ static Scheme_Object *check_type_and_inspector(const char *who, int always, int return insp; } -static void get_struct_type_info(int argc, Scheme_Object *argv[], Scheme_Object **a, int always) +void scheme_force_struct_type_info(Scheme_Struct_Type *stype) { - Scheme_Struct_Type *stype, *parent; - Scheme_Object *insp, *ims; - int p, cnt; - - insp = check_type_and_inspector("struct-type-info", always, argc, argv); - if (SCHEME_NP_CHAPERONEP(argv[0])) - stype = (Scheme_Struct_Type *)SCHEME_CHAPERONE_VAL(argv[0]); - else - stype = (Scheme_Struct_Type *)argv[0]; - /* Make sure generic accessor and mutator are created: */ if (!stype->accessor) { Scheme_Object *p; @@ -2667,6 +2657,21 @@ static void get_struct_type_info(int argc, Scheme_Object *argv[], Scheme_Object p = make_struct_proc(stype, fn, SCHEME_GEN_SETTER, 0); stype->mutator = p; } +} + +static void get_struct_type_info(int argc, Scheme_Object *argv[], Scheme_Object **a, int always) +{ + Scheme_Struct_Type *stype, *parent; + Scheme_Object *insp, *ims; + int p, cnt; + + insp = check_type_and_inspector("struct-type-info", always, argc, argv); + if (SCHEME_NP_CHAPERONEP(argv[0])) + stype = (Scheme_Struct_Type *)SCHEME_CHAPERONE_VAL(argv[0]); + else + stype = (Scheme_Struct_Type *)argv[0]; + + scheme_force_struct_type_info(stype); if (stype->name_pos) parent = stype->parent_types[stype->name_pos - 1]; From f832c961a828db42f3c6560760f3722688774367 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 1 Nov 2012 09:09:36 -0600 Subject: [PATCH 096/221] change `Scheme_Symbol' declaration to avoid compiler warnings --- src/racket/include/scheme.h | 6 +++++- src/racket/src/mzmark_type.inc | 6 +++--- src/racket/src/mzmarksrc.c | 2 +- src/racket/src/symbol.c | 2 +- 4 files changed, 10 insertions(+), 6 deletions(-) diff --git a/src/racket/include/scheme.h b/src/racket/include/scheme.h index 9b93c22d73..a309968fbe 100644 --- a/src/racket/include/scheme.h +++ b/src/racket/include/scheme.h @@ -127,10 +127,14 @@ typedef long FILE; old way. */ #ifdef MZ_USE_OLD_ARRAY_STYLE # define mzFLEX_ARRAY_DECL 1 +# define mzFLEX_ARRAY4_DECL 4 # define mzFLEX_DELTA 1 +# define mzFLEX4_DELTA 4 #else # define mzFLEX_ARRAY_DECL /* empty */ +# define mzFLEX_ARRAY4_DECL /* empty */ # define mzFLEX_DELTA 0 +# define mzFLEX4_DELTA 0 #endif #ifdef MZ_XFORM @@ -331,7 +335,7 @@ typedef struct { typedef struct Scheme_Symbol { Scheme_Inclhash_Object iso; /* 1 in low bit of keyex indicates uninterned */ intptr_t len; - char s[4]; /* Really, a number of chars to match `len' */ + char s[mzFLEX_ARRAY4_DECL]; } Scheme_Symbol; typedef struct Scheme_Vector { diff --git a/src/racket/src/mzmark_type.inc b/src/racket/src/mzmark_type.inc index a33c5f68a8..273ffe0e60 100644 --- a/src/racket/src/mzmark_type.inc +++ b/src/racket/src/mzmark_type.inc @@ -1417,21 +1417,21 @@ static int symbol_obj_SIZE(void *p, struct NewGC *gc) { Scheme_Symbol *s = (Scheme_Symbol *)p; return - gcBYTES_TO_WORDS(sizeof(Scheme_Symbol) + s->len - 3); + gcBYTES_TO_WORDS(sizeof(Scheme_Symbol) + s->len + 1 - mzFLEX4_DELTA); } static int symbol_obj_MARK(void *p, struct NewGC *gc) { Scheme_Symbol *s = (Scheme_Symbol *)p; return - gcBYTES_TO_WORDS(sizeof(Scheme_Symbol) + s->len - 3); + gcBYTES_TO_WORDS(sizeof(Scheme_Symbol) + s->len + 1 - mzFLEX4_DELTA); } static int symbol_obj_FIXUP(void *p, struct NewGC *gc) { Scheme_Symbol *s = (Scheme_Symbol *)p; return - gcBYTES_TO_WORDS(sizeof(Scheme_Symbol) + s->len - 3); + gcBYTES_TO_WORDS(sizeof(Scheme_Symbol) + s->len + 1 - mzFLEX4_DELTA); } #define symbol_obj_IS_ATOMIC 1 diff --git a/src/racket/src/mzmarksrc.c b/src/racket/src/mzmarksrc.c index c49f50198d..933eb7a714 100644 --- a/src/racket/src/mzmarksrc.c +++ b/src/racket/src/mzmarksrc.c @@ -551,7 +551,7 @@ symbol_obj { mark: size: - gcBYTES_TO_WORDS(sizeof(Scheme_Symbol) + s->len - 3); + gcBYTES_TO_WORDS(sizeof(Scheme_Symbol) + s->len + 1 - mzFLEX4_DELTA); } cons_cell { diff --git a/src/racket/src/symbol.c b/src/racket/src/symbol.c index 781195190d..75d72226c2 100644 --- a/src/racket/src/symbol.c +++ b/src/racket/src/symbol.c @@ -356,7 +356,7 @@ make_a_symbol(const char *name, uintptr_t len, int kind) { Scheme_Symbol *sym; - sym = (Scheme_Symbol *)scheme_malloc_atomic_tagged(sizeof(Scheme_Symbol) + len - 3); + sym = (Scheme_Symbol *)scheme_malloc_atomic_tagged(sizeof(Scheme_Symbol) + len + 1 - mzFLEX4_DELTA); sym->iso.so.type = scheme_symbol_type; MZ_OPT_HASH_KEY(&sym->iso) = kind; From 739aa114044d17019936cd202045eabcd2e5e13c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 1 Nov 2012 09:29:26 -0600 Subject: [PATCH 097/221] Scribble Latex/PDF: use tocstyle only if it's available --- collects/scribble/scribble.tex | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/collects/scribble/scribble.tex b/collects/scribble/scribble.tex index 179f099db5..29a3bd43ea 100644 --- a/collects/scribble/scribble.tex +++ b/collects/scribble/scribble.tex @@ -11,8 +11,7 @@ \usepackage[htt]{hyphenat} \usepackage[usenames,dvipsnames]{color} \hypersetup{bookmarks=true,bookmarksopen=true,bookmarksnumbered=true} -\usepackage{tocstyle} -\usetocstyle{standard} +\IfFileExists{tocstyle.sty}{\usepackage{tocstyle}\usetocstyle{standard}} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Configuration that is especially meant to be overridden: From ee97c08e0a0428555e4ecf3547978f7bb95b0a6b Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 1 Nov 2012 12:15:26 -0400 Subject: [PATCH 098/221] Replace #lang scheme deprecation notice with a pointer to #lang racket. --- collects/scribblings/scheme/scheme.scrbl | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/scribblings/scheme/scheme.scrbl b/collects/scribblings/scheme/scheme.scrbl index 845171971f..553ac7cd7c 100644 --- a/collects/scribblings/scheme/scheme.scrbl +++ b/collects/scribblings/scheme/scheme.scrbl @@ -60,7 +60,8 @@ Racket was once called ``PLT Scheme,'' and a number of libraries with names starting @racketidfont{scheme} provide compatibility with the old name. A few @seclink["compat-exe"]{old executables} are also provided. -@deprecated[@racketmodname[racket]]{} +Do not use @racketmodfont{#lang} @racketmodname[scheme] to start new projects; +@racketmodfont{#lang} @racketmodname[racket] is the preferred language. @table-of-contents[] From e6ab32593e089418b730fc2a998b45ec265cc632 Mon Sep 17 00:00:00 2001 From: Burke Fetscher Date: Thu, 1 Nov 2012 11:28:46 -0500 Subject: [PATCH 099/221] add redex-generator form and some tests update examples/generate-types --- .../define-judgment-form/generate-types.rkt | 8 +- collects/redex/private/generate-term.rkt | 89 ++++++++++++------- collects/redex/tests/gen-test.rkt | 44 ++++++--- collects/redex/tests/rg-test.rkt | 4 +- 4 files changed, 97 insertions(+), 48 deletions(-) diff --git a/collects/redex/examples/define-judgment-form/generate-types.rkt b/collects/redex/examples/define-judgment-form/generate-types.rkt index 050cdab50f..0f7c898581 100644 --- a/collects/redex/examples/define-judgment-form/generate-types.rkt +++ b/collects/redex/examples/define-judgment-form/generate-types.rkt @@ -3,10 +3,12 @@ (require redex/pict redex/reduction-semantics) +(provide (all-defined-out)) + ;; This file makes some small changes to the system in ;; typing-rules.rkt (in the same directory) to allow generation ;; of terms that satisfy the "typeof" judgment-form. Specifically, -;; since gerenation of this type doesn't yet support ellipses, +;; since this kind of random generation doesn't yet support ellipses, ;; they have to be eliminated form the judgment-form and the ;; metafunctions it depends on. @@ -75,7 +77,7 @@ (typeof () e τ) 5)) -(define (test-some-terms n) +(define (random-terms n) (for/list ([_ n]) (match (random-typed-term) [`(typeof () ,e ,t) @@ -84,5 +86,3 @@ (error 'typeof "non-unique types: ~s in ~s\n" types e)) (test-equal (car types) t) e]))) - -(test-some-terms 15) diff --git a/collects/redex/private/generate-term.rkt b/collects/redex/private/generate-term.rkt index 1ef069df5e..c4638ca384 100644 --- a/collects/redex/private/generate-term.rkt +++ b/collects/redex/private/generate-term.rkt @@ -353,9 +353,9 @@ (syntax-case #'rest () [() #`(λ (size) - (generate-jf-pat (jf/mf-id . args) size))] + (generate-jf-pat language (jf/mf-id . args) size))] [(size) - #'(generate-jf-pat (jf/mf-id . args) size)] + #'(generate-jf-pat language (jf/mf-id . args) size)] [(x . y) (raise-syntax-error 'generate-term "#:satisfying does not yet support additional keyword arguments" stx #'x)])] @@ -405,24 +405,67 @@ (syntax-case stx () [(g-m-p lang-id (mf-name . lhs-pats) rhs-pat size) #`(parameterize ([unsupported-pat-err-name 'generate-term]) - ((get-mf-generator lang-id (mf-name . lhs-pats) rhs-pat size)))])) + ((make-redex-generator lang-id (mf-name . lhs-pats) = rhs-pat size)))])) (define-syntax (generate-jf-pat stx) (syntax-case stx () - [(g-p (jf-name . pat-raw) size) + [(g-j-p lang-id (jf-name . pat-raw) size) #`(parameterize ([unsupported-pat-err-name 'generate-term]) - ((get-jf-generator (jf-name . pat-raw) size)))])) + ((make-redex-generator lang-id (jf-name . pat-raw) size)))])) -(define-syntax (get-jf-generator stx) +(define-syntax (redex-generator stx) (syntax-case stx () - [(g-j-g (jf-name . pat-raw) size) - (let* ([j-f (lookup-judgment-form-id #'jf-name)] - [lang (judgment-form-lang j-f)] - [clauses (judgment-form-gen-clauses j-f)] - [nts (definition-nts lang stx 'generate-term)]) - (with-syntax ([(pat (names ...) (names/ellipses ...)) - (rewrite-side-conditions/check-errs nts 'generate-term #t #'pat-raw)]) - #`(make-jf-gen/proc 'jf-name #,clauses #,lang 'pat size)))])) + [(form-name args ...) + #`(#%expression (make-redex-generator args ...))])) + +(define-syntax (make-redex-generator stx) + (syntax-case stx () + [(_ lang-id (jf/mf-id . args) . rest) + (cond + [(judgment-form-id? #'jf/mf-id) + (syntax-case #'rest () + [(size) + (let* ([j-f (lookup-judgment-form-id #'jf/mf-id)] + [clauses (judgment-form-gen-clauses j-f)] + [nts (definition-nts #'lang-id stx 'redex-generator)]) + (with-syntax ([(pat (names ...) (names/ellipses ...)) + (rewrite-side-conditions/check-errs nts 'redex-generator #t #'args)]) + #`(make-jf-gen/proc 'jf/mf-id #,clauses lang-id 'pat size)))] + [_ + (raise-syntax-error 'redex-generator + "expected an integer depth bound" + stx + #'rest)])] + [(metafunc #'jf/mf-id) + (syntax-case #'rest () + [(= res size) + (and (identifier? #'=) + (equal? '= (syntax->datum #'=))) + (let () + (define mf (syntax-local-value #'jf/mf-id (λ () #f))) + (define nts (definition-nts #'lang-id stx 'redex-generator)) + (with-syntax ([(lhs-pat (lhs-names ...) (lhs-names/ellipses ...)) + (rewrite-side-conditions/check-errs nts (syntax-e #'g-m-p) #t #'args)] + [(rhs-pat (rhs-names ...) (rhs-names/ellipses ...)) + (rewrite-side-conditions/check-errs nts (syntax-e #'g-m-p) #t #'res)] + [mf-id (term-fn-get-id mf)]) + #`(make-mf-gen/proc 'mf-id mf-id lang-id 'lhs-pat 'rhs-pat size)))] + [_ + (raise-syntax-error 'redex-generator + "expected \"=\" followed by a result pattern and an integer depth bound" + stx + #'rest)])] + [else + (raise-syntax-error 'redex-generator + "expected either a metafunction or a judgment-form identifier" + stx + #'jf/mf-id)])] + [(_ not-lang-id . rest) + (not (identifier? #'not-lang-id)) + (raise-syntax-error 'redex-generator + "expected an identifier in the language position" + stx + #'not-lang-id)])) (define (make-jf-gen/proc jf-id mk-clauses lang pat size) (define gen (search/next (mk-clauses) pat size lang)) @@ -437,21 +480,6 @@ (parameterize ([current-logger generation-logger]) (termify (gen))))) -(define-syntax (get-mf-generator stx) - (syntax-case stx () - [(g-m-g lang-id (mf-name . lhs-pats) rhs-pat size) - (let () - (define mf (syntax-local-value #'mf-name (λ () #f))) - (unless (term-fn? mf) - (raise-syntax-error 'generate-mf-pat "expected an identifier bound to a metafunction" stx #'mf-name)) - (define nts (language-id-nts #'lang-id (syntax-e #'g-m-p))) - (with-syntax ([(lhs-pat (lhs-names ...) (lhs-names/ellipses ...)) - (rewrite-side-conditions/check-errs nts (syntax-e #'g-m-p) #t #'lhs-pats)] - [(rhs-pat (rhs-names ...) (rhs-names/ellipses ...)) - (rewrite-side-conditions/check-errs nts (syntax-e #'g-m-p) #t #'rhs-pat)] - [mf-id (term-fn-get-id mf)]) - #`(make-mf-gen/proc 'mf-id mf-id lang-id 'lhs-pat 'rhs-pat size)))])) - (define (make-mf-gen/proc fn metafunc-proc lang lhs-pat rhs-pat size) (define gen (search/next ((metafunc-proc-gen-clauses metafunc-proc)) `(list ,lhs-pat ,rhs-pat) @@ -480,7 +508,6 @@ get-most-recent-trace update-gen-trace! exn:fail:redex:generation-failure? - get-jf-generator - get-mf-generator + redex-generator (struct-out counterexample) (struct-out exn:fail:redex:test)) diff --git a/collects/redex/tests/gen-test.rkt b/collects/redex/tests/gen-test.rkt index 9d3b62a095..56986c6c9b 100644 --- a/collects/redex/tests/gen-test.rkt +++ b/collects/redex/tests/gen-test.rkt @@ -241,7 +241,7 @@ (test-equal (judgment-holds (typeof ([x_2 int] ([x_1 (int → int)] •)) (x_1 5) int)) #t) - (for ([_ 500]) + (for ([_ 100]) (define term (generate-term STLC #:satisfying (typeof Γ e τ) 6)) (match term [`(typeof ,g ,e ,t) @@ -258,6 +258,17 @@ (test-equal tp `(,t))] [#f (void)])) + + (define g (redex-generator STLC (typeof • e τ) 5)) + (define terms (filter values (for/list ([_ 400]) (g)))) + (test-equal (length terms) + (length (remove-duplicates terms))) + (map (match-lambda + [`(typeof ,g ,e ,t) + (define tp (judgment-holds (typeof ,g ,e τ) τ)) + (test-equal tp `(,t))]) + terms) + (void) ) (let () @@ -267,17 +278,17 @@ (n number)) (define-metafunction l - filter : n e -> e - [(filter n •) + fltr : n e -> e + [(fltr n •) •] - [(filter n (n e)) - (filter n e)] - [(filter n (n_0 e)) - (n_0 (filter n e))]) + [(fltr n (n e)) + (fltr n e)] + [(fltr n (n_0 e)) + (n_0 (fltr n e))]) (define-judgment-form l #:mode (filtered I I O) - [(filtered e n (filter n e))]) + [(filtered e n (fltr n e))]) (test-equal (generate-term l #:satisfying (filtered (1 (2 (3 (4 •)))) 3 (1 (2 (4 •)))) +inf.0) '(filtered (1 (2 (3 (4 •)))) 3 (1 (2 (4 •))))) @@ -294,12 +305,23 @@ (void)])) (for ([_ 50]) - (define t (generate-term l #:satisfying (filter n e) e_1 5)) + (define t (generate-term l #:satisfying (fltr n e) e_1 5)) (match t - [`((filter ,n ,e) = ,e1) - (test-equal (term (filter ,n ,e)) e1)] + [`((fltr ,n ,e) = ,e1) + (test-equal (term (fltr ,n ,e)) e1)] [#f (void)])) + + (define g (redex-generator l (fltr n e_1) = e_2 5)) + (define terms (filter values (for/list ([_ 50]) (g)))) + (test-equal (length terms) + (length (remove-duplicates terms))) + (map (match-lambda + [`((fltr ,n ,e) = ,e1) + (test-equal (term (fltr ,n ,e)) e1)]) + terms) + (void) + ) (let () diff --git a/collects/redex/tests/rg-test.rkt b/collects/redex/tests/rg-test.rkt index ac723e8bb1..5615e98f5a 100644 --- a/collects/redex/tests/rg-test.rkt +++ b/collects/redex/tests/rg-test.rkt @@ -1301,13 +1301,13 @@ ------------------------- (sum (s n_1) n_2 n_3)]) - (test (generate-term L + (test (generate-term nats #:satisfying (sum z z n) 5) '(sum z z z)) - (test (generate-term L + (test (generate-term nats #:satisfying (sum (s z) (s z) n) 5) From 6be405975e08d9266de07b75c72b27d86d531eaf Mon Sep 17 00:00:00 2001 From: Burke Fetscher Date: Thu, 1 Nov 2012 11:51:09 -0500 Subject: [PATCH 100/221] don't use disunify* to check disequations, since at this point they are fully instantiated --- collects/redex/private/jdg-gen.rkt | 4 ++-- collects/redex/tests/gen-test.rkt | 20 ++++++++++++++++---- 2 files changed, 18 insertions(+), 6 deletions(-) diff --git a/collects/redex/private/jdg-gen.rkt b/collects/redex/private/jdg-gen.rkt index 6629202f42..56f33ecafb 100644 --- a/collects/redex/private/jdg-gen.rkt +++ b/collects/redex/private/jdg-gen.rkt @@ -84,7 +84,7 @@ (set! sym-index 0) (define rhs-term (pat->term/term-e rhs term-e eqs lang)) (define lhs-term (pat->term/term-e lhs term-e eqs lang)) - (disunify* lhs-term rhs-term (make-hash) lang)) + (not (equal? rhs-term lhs-term))) (define (pat->term/term-e t term-e actual-e lang) (call/ec @@ -100,7 +100,7 @@ [`(cstr (,nts ...) ,pat) (recur pat)] [`(list ,ps ...) - `(list ,@(for/list ([p ps]) (recur p)))] + (for/list ([p ps]) (recur p))] [`(nt ,_) (fail (not-ground))] [`(,stuff ...) ;; here it's a fully instanatiated list diff --git a/collects/redex/tests/gen-test.rkt b/collects/redex/tests/gen-test.rkt index 56986c6c9b..3983f848a6 100644 --- a/collects/redex/tests/gen-test.rkt +++ b/collects/redex/tests/gen-test.rkt @@ -11,17 +11,21 @@ (let () (define-language L0) + (test-equal (check-dq `a `a (make-hash) L0 (hash)) + #f) + (test-equal (check-dq `a `b (make-hash) L0 (hash)) + #t) (test-equal (check-dq `(list a) `(list a) (make-hash) L0 (hash)) #f) (test-equal (check-dq `(list a) `(list b) (make-hash) L0 (hash)) #t) - (test-equal (check-dq `(list a) `(list any) (make-hash) L0 (hash)) + (test-equal (check-dq `(list number) `(list variable) (make-hash) L0 (hash)) #t) (test-equal (check-dq `(list a) `(list number) (make-hash) L0 (hash)) #t) - (test-equal (check-dq `(list a) `(list variable-not-otherwise-mentioned) (make-hash) L0 (hash)) + (test-equal (check-dq `(list 2) `(list variable-not-otherwise-mentioned) (make-hash) L0 (hash)) #t) - (test-equal (check-dq `(list a b) `(list a any) (make-hash) L0 (hash)) + (test-equal (check-dq `(list a b) `(list a number) (make-hash) L0 (hash)) #t) (test-equal (check-dq `(list a b) `(list a b) (make-hash) L0 (hash)) #f) @@ -30,7 +34,15 @@ (make-hash) L0 (hash (lvar 'a) 'number)) - #f)) + #f) + (test-equal (check-dq `(name a ,(bound)) + `(name b ,(bound)) + (make-hash (list (cons (lvar 'a) '(1 2 3)) + (cons (lvar 'b) '(1 2 3)))) + L0 + (hash (lvar 'a) 'any (lvar 'b) 'any)) + #f) + ) (let () From 2274e23394e63d71896cbbf01506085802e82f17 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 29 Oct 2012 22:49:12 -0600 Subject: [PATCH 101/221] Fix error with min-width and fractions --- collects/racket/format.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/racket/format.rkt b/collects/racket/format.rkt index ba334c76eb..481e452499 100644 --- a/collects/racket/format.rkt +++ b/collects/racket/format.rkt @@ -378,7 +378,7 @@ (define (number->fraction-string N base upper? precision) (let ([s (number->string* N base upper?)]) - (string-append (make-string (- precision (string-length s)) #\0) s))) + (string-append (make-string (max 0 (- precision (string-length s))) #\0) s))) ;; Allow base up to 36! (define (get-digit d upper?) From 6d101c9472dbde58001d29d9b5c063e18c285959 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 30 Oct 2012 11:07:46 -0600 Subject: [PATCH 102/221] add a test for the patch --- collects/tests/racket/format.rkt | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/collects/tests/racket/format.rkt b/collects/tests/racket/format.rkt index a48a1fc550..978e3e52ff 100644 --- a/collects/tests/racket/format.rkt +++ b/collects/tests/racket/format.rkt @@ -268,3 +268,8 @@ (tc (~r 3735928559 #:base '(up 16) #:precision 6 #:notation 'exponential) ;; note rounding! "D.EADBEF×16^+07") + +(tc (~r 33.99508664763296 #:precision 1 #:min-width 5) + " 33.1") +(tc (~r 33.99508664763296 #:precision 2 #:min-width 7) + " 33.1") From 0c892b5b0d36c828b56d2d6c2ae89ba4abf4dc91 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 1 Nov 2012 11:12:47 -0600 Subject: [PATCH 103/221] pushing update timeout --- collects/meta/props | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/meta/props b/collects/meta/props index b688fac53f..718c307940 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1388,7 +1388,7 @@ path/s is either such a string or a list of them. "collects/tests/racket/stress/contract-lifting.rkt" responsible (robby sstrickl) "collects/tests/racket/stress/dict.rkt" drdr:timeout 180 "collects/tests/racket/stress/fuzz.rkt" responsible (samth mflatt) drdr:command-line (racket * "-c") drdr:timeout 300 drdr:random #t -"collects/tests/racket/stress/module-stack.rkt" drdr:timeout 180 +"collects/tests/racket/stress/module-stack.rkt" drdr:timeout 360 "collects/tests/racket/sync.rktl" drdr:command-line #f "collects/tests/racket/syntax.rktl" drdr:command-line #f "collects/tests/racket/thread.rktl" drdr:command-line #f From 9c9f269765dfd14170c7f211876ee0460e057536 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Tue, 30 Oct 2012 15:01:59 -0600 Subject: [PATCH 104/221] [honu] add syntax-rules analog --- collects/honu/syntax.rkt | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 collects/honu/syntax.rkt diff --git a/collects/honu/syntax.rkt b/collects/honu/syntax.rkt new file mode 100644 index 0000000000..d73638cda8 --- /dev/null +++ b/collects/honu/syntax.rkt @@ -0,0 +1,10 @@ +#lang honu + +/* Standard syntax-rules but as a macro-defining form */ + +provide macro_rules; +macro macro_rules(){ + name:identifier (literal ...){ pattern ... }{ template ... } +} { + syntax(macro name (literal ...){ pattern ... }{ syntax(template ...) }) +} From ae15ef55b38d9ff099cbcbf6bb471877c23b5013 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Wed, 31 Oct 2012 22:00:57 -0600 Subject: [PATCH 105/221] [honu] clean up syntax parse attributes in patterns. dont remove repeats too early from syntax --- collects/honu/core/private/macro2.rkt | 250 +++++++++++++++----------- collects/honu/core/private/parse2.rkt | 5 +- 2 files changed, 147 insertions(+), 108 deletions(-) diff --git a/collects/honu/core/private/macro2.rkt b/collects/honu/core/private/macro2.rkt index 3ac8799a69..9be34a090a 100644 --- a/collects/honu/core/private/macro2.rkt +++ b/collects/honu/core/private/macro2.rkt @@ -11,7 +11,6 @@ "debug.rkt" (prefix-in phase1: "compile.rkt") "util.rkt" - (prefix-in syntax: syntax/parse/private/residual-ct) racket/base) (for-meta 2 syntax/parse racket/base @@ -28,6 +27,9 @@ "literals.rkt" "syntax.rkt" "debug.rkt" + + (for-meta 0 "template.rkt" syntax/stx) + (for-meta -1 "literals.rkt" "compile.rkt" "parse2.rkt" "parse-helper.rkt") #; (for-syntax "honu-typed-scheme.rkt") @@ -37,14 +39,30 @@ (require syntax/parse "literals.rkt" "debug.rkt" + "util.rkt" + (prefix-in syntax: syntax/parse/private/residual-ct) racket/syntax racket/set + racket/match + (for-syntax syntax/parse + racket/base + racket/syntax) (for-template racket/base syntax/parse)) (provide (all-defined-out)) (struct pattern-variable [name original depth class] #:transparent) + ;; given the name of an object and some fields this macro defines + ;; name.field for each of the fields + (define-syntax (define-struct-fields stx) + (syntax-parse stx + [(_ name type (field ...)) + (with-syntax ([(field* ...) + (for/list ([field (syntax->list #'(field ...))]) + (format-id field "~a.~a" (syntax-e #'name) (syntax-e field)))]) + #'(match-define (struct type (field* ...)) name))])) + ;; makes a syntax object with the right number of nested ellipses patterns (define (pattern-variable->syntax variable) (debug 2 "Convert pattern variable to syntax ~a location ~a\n" variable (pattern-variable-original variable)) @@ -126,6 +144,83 @@ (define variables (find (reverse-syntax original-pattern))) (debug 2 "Found variables ~a\n" variables) (for/list ([x variables]) x)) + + ;; variable is the original pattern variable, like 'foo' + ;; and new-name is the new generated name, 'temp1' + ;; we want to bind all the attributes from temp1 to foo, so if temp1 has + ;; temp1_a + ;; temp1_b ... + ;; + ;; we want to bind + ;; foo_a temp_a + ;; (foo_b ...) (temp_b ...) + (define (bind-attributes variable new-name) + (debug "Syntax class of ~a is ~a at ~a\n" + (pattern-variable-class variable) + (syntax-local-value (pattern-variable-class variable) (lambda () #f)) + (syntax-local-phase-level)) + (define attributes + (let ([syntax-class (syntax-local-value (pattern-variable-class variable))]) + (for/list ([attribute (syntax:stxclass-attrs syntax-class)]) + (pattern-variable (syntax:attr-name attribute) + (pattern-variable-original variable) + (+ (pattern-variable-depth variable) + (syntax:attr-depth attribute)) + #f)))) + + (define (mirror-attribute attribute) + (debug "Mirror attribute ~a\n" attribute) + (define-struct-fields attribute pattern-variable + (name original depth class)) + ;; create a new pattern variable with a syntax object that uses + ;; the given lexical context and whose name is prefix_suffix + (define (create lexical prefix suffix) + (pattern-variable->syntax + (pattern-variable (format-id lexical "~a_~a" prefix suffix) + attribute.original attribute.depth attribute.class))) + (define-struct-fields variable pattern-variable + (name original depth class)) + (debug "Bind attributes ~a ~a\n" variable.name attribute.name) + (with-syntax ([bind-attribute + #; + (create name (syntax-e name) name) + (pattern-variable->syntax + (pattern-variable (format-id variable.name "~a_~a" + (syntax-e variable.name) + attribute.name) + attribute.original + attribute.depth + attribute.class))] + [new-attribute + #; + (create new-name new-name name) + (pattern-variable->syntax + (pattern-variable + (format-id new-name "~a_~a" + new-name + attribute.name) + attribute.original attribute.depth #f))]) + (debug "Bind ~a to ~a\n" #'bind-attribute #'new-attribute) + #'(#:with bind-attribute #'new-attribute))) + + (for/set ([attribute attributes]) + (mirror-attribute attribute))) + + ;; returns a set of #:with clauses for syntax-parse that + ;; bind all the old variables and their attributes to some new names + ;; taking care of ellipses depth + (define (pattern-variables+attributes variables use) + (for/union ([old variables] + [new use]) + (define-struct-fields old pattern-variable (name original depth class)) + (with-syntax ([old-syntax (pattern-variable->syntax old)] + [new.result (pattern-variable->syntax + (pattern-variable (format-id new "~a_result" new) + old.original + old.depth + old.class))]) + (set-union (set #'(#:with old-syntax #'new.result)) + (bind-attributes old new))))) ) (require (for-meta 2 (submod "." analysis))) @@ -261,6 +356,15 @@ context context)]) ;; (debug "Stuff is ~a\n" (syntax->datum #'stuff*)) ;; (debug "Stuff syntaxed is ~a\n" (syntax->datum #'#'stuff*)) + + ;; stuff* will be expanded when this syntax is returned because + ;; the whole thing will be + ;; (remove-repeats #'((repeat$ 1) (repeat$ 2))) + ;; so remove-repeats will be executed later + (phase1:racket-syntax + (remove-repeats #'stuff*)) + + #; (with-syntax ([(out ...) #'stuff*]) (phase1:racket-syntax #'stuff*))) #; #'(%racket-expression (parse-stuff stuff ...)) @@ -301,128 +405,60 @@ (begin-for-syntax (define-syntax (generate-pattern stx) - - ;; given the name of an object and some fields this macro defines - ;; name.field for each of the fields - (define-syntax (define-struct-fields stx) - (syntax-parse stx - [(_ name type (field ...)) - (with-syntax ([(field* ...) - (for/list ([field (syntax->list #'(field ...))]) - (format-id field "~a.~a" (syntax-e #'name) (syntax-e field)))]) - #'(match-define (struct type (field* ...)) name))])) - (syntax-parse stx [(_ name literals original-pattern maybe-out) - (define variables (find-pattern-variables #'original-pattern)) - (define use (generate-temporaries variables)) - (define mapping (make-hash)) - (for ([old variables] - [new use]) - (debug "Update mapping ~a to ~a\n" (syntax-e (pattern-variable-name old)) new) - (hash-set! mapping - (syntax-e (pattern-variable-name old)) - (pattern-variable new - (pattern-variable-original old) - (pattern-variable-depth old) - (pattern-variable-class old)))) - ;; variable is the original pattern variable, like 'foo' - ;; and new-name is the new generated name, 'temp1' - ;; we want to bind all the attributes from temp1 to foo, so if temp1 has - ;; temp1_a - ;; temp1_b ... - ;; - ;; we want to bind - ;; foo_a temp_a - ;; (foo_b ...) (temp_b ...) - (define (bind-attributes variable new-name) - (debug "Syntax class of ~a is ~a at ~a\n" - (pattern-variable-class variable) - (syntax-local-value (pattern-variable-class variable) (lambda () #f)) - (syntax-local-phase-level)) - (define attributes - (let ([syntax-class (syntax-local-value (pattern-variable-class variable))]) - (for/list ([attribute (syntax:stxclass-attrs syntax-class)]) - (pattern-variable (syntax:attr-name attribute) - (pattern-variable-original variable) - (+ (pattern-variable-depth variable) - (syntax:attr-depth attribute)) - #f)))) + (define (make-syntax-class-pattern honu-pattern maybe-out) + (define variables (find-pattern-variables honu-pattern)) + (define use (generate-temporaries variables)) + (define mapping (make-hash)) + (for ([old variables] + [new use]) + (debug "Update mapping ~a to ~a\n" (syntax-e (pattern-variable-name old)) new) + (hash-set! mapping + (syntax-e (pattern-variable-name old)) + (pattern-variable new + (pattern-variable-original old) + (pattern-variable-depth old) + (pattern-variable-class old)))) - (define (mirror-attribute attribute) - (debug "Mirror attribute ~a\n" attribute) - ;; create a new pattern variable with a syntax object that uses - ;; the given lexical context and whose name is prefix_suffix - (define-struct-fields attribute pattern-variable - (name original depth class)) - (define (create lexical prefix suffix) - (pattern-variable->syntax - (pattern-variable (format-id lexical "~a_~a" prefix suffix) - attribute.original attribute.depth attribute.class))) - (define-struct-fields variable pattern-variable - (name original depth class)) - (debug "Bind attributes ~a ~a\n" variable.name attribute.name) - (with-syntax ([bind-attribute - #; - (create name (syntax-e name) name) - (pattern-variable->syntax - (pattern-variable (format-id variable.name "~a_~a" - (syntax-e variable.name) - attribute.name) - attribute.original - attribute.depth - attribute.class))] - [new-attribute - #; - (create new-name new-name name) - (pattern-variable->syntax - (pattern-variable - (format-id new-name "~a_~a" - new-name - attribute.name) - attribute.original attribute.depth #f))]) - (debug "Bind ~a to ~a\n" #'bind-attribute #'new-attribute) - #'(#:with bind-attribute #'new-attribute))) + (define withs (pattern-variables+attributes variables use)) - (for/set ([attribute attributes]) - (mirror-attribute attribute))) + (with-syntax ([(new-pattern ...) (convert-pattern honu-pattern mapping)] + [((withs ...) ...) (set->list withs)] + [(result-with ...) (if (syntax-e maybe-out) + (with-syntax ([(out ...) maybe-out]) + #'(#:with result (out ...))) + #'(#:with result #'()))]) + #'[pattern (~seq new-pattern ...) + withs ... ... + result-with ... + ])) - (define withs - (for/union ([old variables] - [new use]) - (define-struct-fields old pattern-variable (name original depth class)) - (with-syntax ([old-syntax (pattern-variable->syntax old)] - [new.result (pattern-variable->syntax - (pattern-variable (format-id new "~a_result" new) - old.original - old.depth - old.class))]) - (set-union (set #'(#:with old-syntax #'new.result)) - (bind-attributes old new))))) + (define pattern-stuff (make-syntax-class-pattern #'original-pattern #'maybe-out)) + #; (debug "With bindings ~a\n" withs) (with-syntax ([(literal ...) #'literals] - [(new-pattern ...) (convert-pattern #'original-pattern mapping)] - [((withs ...) ...) (set->list withs)] - [(result-with ...) (if (syntax-e #'maybe-out) - (with-syntax ([(out ...) #'maybe-out]) - #'(#:with result (out ...))) - #'(#:with result #'()))]) + [(new-pattern ...) (list pattern-stuff)]) + #; (debug "Result with ~a\n" (syntax->datum #'(quote-syntax (result-with ...)))) (define output #'(quote-syntax (begin - ;; define at phase1 so we can use it + ;; define at phase1 so we can use it in a macro (begin-for-syntax (define-literal-set local-literals (literal ...)) (define-splicing-syntax-class name - #:literal-sets ([cruft #:at name] - [local-literals #:at name]) - [pattern (~seq new-pattern ...) - withs ... ... - result-with ... - ]))))) + #:literal-sets ([cruft #:at name] + [local-literals #:at name]) + new-pattern ... + + #; + [pattern (~seq new-pattern ...) + withs ... ... + result-with ... + ]))))) (debug "Output is ~a\n" (pretty-syntax output)) output)]))) diff --git a/collects/honu/core/private/parse2.rkt b/collects/honu/core/private/parse2.rkt index 68480fb544..57762927c5 100644 --- a/collects/honu/core/private/parse2.rkt +++ b/collects/honu/core/private/parse2.rkt @@ -316,7 +316,10 @@ (do-parse #'(parsed ... rest ...) precedence left current) ;; (debug "Remove repeats from ~a\n" #'parsed) - (define re-parse (remove-repeats #'parsed) + (define re-parse + #'parsed + #; + (remove-repeats #'parsed) #; (with-syntax ([(x ...) #'parsed]) (debug "Properties on parsed ~a\n" (syntax-property-symbol-keys #'parsed)) From dc1b34479ca11edef335245b4d03bffb2c19bc96 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Thu, 1 Nov 2012 01:05:43 -0600 Subject: [PATCH 106/221] [honu] move honu-syntax to syntax.rkt. allow each pattern to specify a syntax result --- collects/honu/core/main.rkt | 1 + collects/honu/core/private/macro2.rkt | 80 +++++++++------------------ collects/honu/core/private/syntax.rkt | 44 +++++++++++++++ collects/tests/honu/match.honu | 2 +- 4 files changed, 71 insertions(+), 56 deletions(-) diff --git a/collects/honu/core/main.rkt b/collects/honu/core/main.rkt index ddc1b05567..67c43b90e6 100644 --- a/collects/honu/core/main.rkt +++ b/collects/honu/core/main.rkt @@ -9,6 +9,7 @@ "private/macro2.rkt" "private/class.rkt" "private/operator.rkt" + "private/syntax.rkt" (prefix-in literal: "private/literals.rkt") (prefix-in syntax-parse: syntax/parse) (prefix-in racket: racket/base) diff --git a/collects/honu/core/private/macro2.rkt b/collects/honu/core/private/macro2.rkt index 9be34a090a..22f8606def 100644 --- a/collects/honu/core/private/macro2.rkt +++ b/collects/honu/core/private/macro2.rkt @@ -7,6 +7,7 @@ racket/syntax "template.rkt" "literals.rkt" + "syntax.rkt" (prefix-in phase1: "parse2.rkt") "debug.rkt" (prefix-in phase1: "compile.rkt") @@ -333,43 +334,6 @@ (syntax #'stuff*))]))) |# -(provide honu-syntax) -;; Do any honu-specific expansion here -(define-honu-syntax honu-syntax - (lambda (code) - (syntax-parse code #:literal-sets (cruft) - #; - [(_ (#%parens single) . rest) - (define context #'single) - (define compressed (compress-dollars #'single)) - (values - (with-syntax ([stuff* (datum->syntax context compressed context context)]) - (phase1:racket-syntax #'stuff*)) - #'rest - #f)] - [(_ (#%parens stuff ...) . rest) - (define context (stx-car #'(stuff ...))) - (define compressed (compress-dollars #'(stuff ...))) - (values - (with-syntax ([stuff* (datum->syntax context - (syntax->list compressed) - context context)]) - ;; (debug "Stuff is ~a\n" (syntax->datum #'stuff*)) - ;; (debug "Stuff syntaxed is ~a\n" (syntax->datum #'#'stuff*)) - - ;; stuff* will be expanded when this syntax is returned because - ;; the whole thing will be - ;; (remove-repeats #'((repeat$ 1) (repeat$ 2))) - ;; so remove-repeats will be executed later - (phase1:racket-syntax - (remove-repeats #'stuff*)) - - #; - (with-syntax ([(out ...) #'stuff*]) - (phase1:racket-syntax #'stuff*))) - #; #'(%racket-expression (parse-stuff stuff ...)) - #'rest - #f)]))) ;; combine syntax objects ;; #'(a b) + #'(c d) = #'(a b c d) @@ -406,7 +370,7 @@ (begin-for-syntax (define-syntax (generate-pattern stx) (syntax-parse stx - [(_ name literals original-pattern maybe-out) + [(_ name literals (pattern-stx out-stx) ...) (define (make-syntax-class-pattern honu-pattern maybe-out) (define variables (find-pattern-variables honu-pattern)) @@ -428,19 +392,23 @@ [((withs ...) ...) (set->list withs)] [(result-with ...) (if (syntax-e maybe-out) (with-syntax ([(out ...) maybe-out]) - #'(#:with result (out ...))) + #'(#:with result (parse-stuff honu-syntax (#%parens out ...)))) #'(#:with result #'()))]) #'[pattern (~seq new-pattern ...) withs ... ... result-with ... ])) - (define pattern-stuff (make-syntax-class-pattern #'original-pattern #'maybe-out)) + (define pattern-stuff + (for/list ([pattern (syntax->list #'(pattern-stx ...))] + [out (syntax->list #'(out-stx ...))]) + (printf "Pattern ~a\n" pattern) + (make-syntax-class-pattern pattern out))) #; (debug "With bindings ~a\n" withs) (with-syntax ([(literal ...) #'literals] - [(new-pattern ...) (list pattern-stuff)]) + [(new-pattern ...) pattern-stuff]) #; (debug "Result with ~a\n" (syntax->datum #'(quote-syntax (result-with ...)))) (define output @@ -468,21 +436,23 @@ (lambda (code) (syntax-parse code #:literal-sets (cruft) [(_ name (#%parens literal ...) - (#%braces pattern ...) - (~optional (#%braces out ...)) + (~seq (#%braces original-pattern ...) + (~optional (~seq honu-comma maybe-out) + #:defaults ([maybe-out #'#f]))) + ... . rest) - (values (with-syntax ([out* (attribute out)]) - (phase1:racket-syntax - (splicing-let-syntax - ([make (lambda (stx) - (syntax-parse stx - [(_ new-name) - (syntax-local-introduce - (generate-pattern name - (literal ...) - (pattern ...) - out*))]))]) - (make name)))) + (values + (phase1:racket-syntax + (splicing-let-syntax + ([make (lambda (stx) + (syntax-parse stx + [(_ new-name) + (syntax-local-introduce + (generate-pattern name + (literal ...) + ((original-pattern ...) maybe-out) + ...))]))]) + (make name))) #'rest #f)]))) diff --git a/collects/honu/core/private/syntax.rkt b/collects/honu/core/private/syntax.rkt index aa617c2923..ee17c9c9e8 100644 --- a/collects/honu/core/private/syntax.rkt +++ b/collects/honu/core/private/syntax.rkt @@ -22,3 +22,47 @@ [rhs rhs]) (syntax/loc stx (define-syntax id (make-honu-transformer rhs)))))) + +;; Do any honu-specific expansion here +(require (for-syntax + "template.rkt" ;; for compress-dollars at phase 1 + "compile.rkt" + "literals.rkt" + syntax/stx + syntax/parse) + "template.rkt") ;; for remove-repeats at phase 0 +(define-honu-syntax honu-syntax + (lambda (code) + (syntax-parse code #:literal-sets (cruft) + #; + [(_ (#%parens single) . rest) + (define context #'single) + (define compressed (compress-dollars #'single)) + (values + (with-syntax ([stuff* (datum->syntax context compressed context context)]) + (phase1:racket-syntax #'stuff*)) + #'rest + #f)] + [(_ (#%parens stuff ...) . rest) + (define context (stx-car #'(stuff ...))) + (define compressed (compress-dollars #'(stuff ...))) + (values + (with-syntax ([stuff* (datum->syntax context + (syntax->list compressed) + context context)]) + ;; (debug "Stuff is ~a\n" (syntax->datum #'stuff*)) + ;; (debug "Stuff syntaxed is ~a\n" (syntax->datum #'#'stuff*)) + + ;; stuff* will be expanded when this syntax is returned because + ;; the whole thing will be + ;; (remove-repeats #'((repeat$ 1) (repeat$ 2))) + ;; so remove-repeats will be executed later + (racket-syntax + (remove-repeats #'stuff*)) + + #; + (with-syntax ([(out ...) #'stuff*]) + (phase1:racket-syntax #'stuff*))) + #; #'(%racket-expression (parse-stuff stuff ...)) + #'rest + #f)]))) diff --git a/collects/tests/honu/match.honu b/collects/tests/honu/match.honu index 8e1f7689d5..1965f9526b 100644 --- a/collects/tests/honu/match.honu +++ b/collects/tests/honu/match.honu @@ -2,7 +2,7 @@ var => = 0 -pattern match_pattern (){ [element:expression_list]} { [ $ element_each_result , $ ...]} +pattern match_pattern (){ [element:expression_list]}, { [ $ element_each_result , $ ...]} pattern match_clause (| =>){ | pattern:match_pattern => out:expression , } From 2984bfe8e2ec6772b2279d09a85f93af02eb135b Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Thu, 1 Nov 2012 01:06:30 -0600 Subject: [PATCH 107/221] [honu] remove printf --- collects/honu/core/private/macro2.rkt | 1 - 1 file changed, 1 deletion(-) diff --git a/collects/honu/core/private/macro2.rkt b/collects/honu/core/private/macro2.rkt index 22f8606def..c2c7ef0d26 100644 --- a/collects/honu/core/private/macro2.rkt +++ b/collects/honu/core/private/macro2.rkt @@ -402,7 +402,6 @@ (define pattern-stuff (for/list ([pattern (syntax->list #'(pattern-stx ...))] [out (syntax->list #'(out-stx ...))]) - (printf "Pattern ~a\n" pattern) (make-syntax-class-pattern pattern out))) #; From fb42f390c935e9f34dc61ff9d845dbc61c343f47 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Thu, 1 Nov 2012 01:17:40 -0600 Subject: [PATCH 108/221] [honu] provide honu-syntax through the user api --- collects/honu/core/api.rkt | 2 ++ collects/honu/core/private/macro2.rkt | 9 +++++---- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/collects/honu/core/api.rkt b/collects/honu/core/api.rkt index c1fb359dba..891e9f46b1 100644 --- a/collects/honu/core/api.rkt +++ b/collects/honu/core/api.rkt @@ -5,10 +5,12 @@ (require "private/syntax.rkt" "private/literals.rkt" (for-syntax "private/compile.rkt" + "private/syntax.rkt" "private/parse2.rkt")) (provide define-honu-syntax define-literal (for-syntax racket-syntax honu-expression + honu-syntax honu-body parse-all)) diff --git a/collects/honu/core/private/macro2.rkt b/collects/honu/core/private/macro2.rkt index c2c7ef0d26..0e535468e0 100644 --- a/collects/honu/core/private/macro2.rkt +++ b/collects/honu/core/private/macro2.rkt @@ -394,10 +394,11 @@ (with-syntax ([(out ...) maybe-out]) #'(#:with result (parse-stuff honu-syntax (#%parens out ...)))) #'(#:with result #'()))]) - #'[pattern (~seq new-pattern ...) - withs ... ... - result-with ... - ])) + (syntax/loc honu-pattern + [pattern (~seq new-pattern ...) + withs ... ... + result-with ... + ]))) (define pattern-stuff (for/list ([pattern (syntax->list #'(pattern-stx ...))] From 3de9b1da748ef9261908678486b7637183575ad0 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Thu, 1 Nov 2012 01:32:42 -0600 Subject: [PATCH 109/221] [honu] add syntax form that is not parsed by enforest so it can contain normal racket code --- collects/honu/core/main.rkt | 1 + collects/honu/core/private/macro2.rkt | 27 +++++++++++++++++++++++++++ 2 files changed, 28 insertions(+) diff --git a/collects/honu/core/main.rkt b/collects/honu/core/main.rkt index 67c43b90e6..f7aa0405e3 100644 --- a/collects/honu/core/main.rkt +++ b/collects/honu/core/main.rkt @@ -36,6 +36,7 @@ [honu-while while] [honu-macro macro] [honu-phase phase] + [honu-racket racket] [honu-primitive-macro primitive_macro] [honu-pattern pattern] [racket:read-line readLine] diff --git a/collects/honu/core/private/macro2.rkt b/collects/honu/core/private/macro2.rkt index 0e535468e0..20d476ef80 100644 --- a/collects/honu/core/private/macro2.rkt +++ b/collects/honu/core/private/macro2.rkt @@ -465,3 +465,30 @@ (define out (phase1:racket-syntax (begin-for-syntax (parse-stuff body ...)))) (values out #'rest #t)]))) + +;; not sure this is useful but it lets you write racket syntax expressions +;; from inside honu. the main issue is all the bindings available +;; are honu bindings so things like (+ 1 x) wont work. +(provide honu-racket) +(define-honu-syntax honu-racket + (lambda (code) + (define (remove-cruft stx) + (syntax-parse stx #:literal-sets (cruft) + [(#%parens inside ...) + (remove-cruft #'(inside ...))] + [(#%braces inside ...) + (remove-cruft #'(inside ...))] + [(#%brackets inside ...) + (remove-cruft #'(inside ...))] + [(head rest ...) + (with-syntax ([head* (remove-cruft #'head)] + [(rest* ...) (remove-cruft #'(rest ...))]) + #'(head* rest* ...))] + [x #'x])) + + (syntax-parse code #:literal-sets (cruft) + [(_ (#%parens stx ...) . rest) + (define out + (with-syntax ([(stx* ...) (remove-cruft #'(stx ...))]) + (phase1:racket-syntax (phase0:racket-syntax (stx* ...))))) + (values out #'rest #t)]))) From 1f02a0a8b8ef63e3db673a6a6339e7ef3c2fbfc3 Mon Sep 17 00:00:00 2001 From: John Clements Date: Thu, 1 Nov 2012 12:37:34 -0700 Subject: [PATCH 110/221] exposed mapping for unreserved characters --- collects/net/scribblings/uri-codec.scrbl | 6 ++++++ collects/net/uri-codec.rkt | 19 ++++++++++++++++--- collects/tests/net/uri-codec.rkt | 12 +++++++++++- 3 files changed, 33 insertions(+), 4 deletions(-) diff --git a/collects/net/scribblings/uri-codec.scrbl b/collects/net/scribblings/uri-codec.scrbl index 6429b238f4..04a41496e2 100644 --- a/collects/net/scribblings/uri-codec.scrbl +++ b/collects/net/scribblings/uri-codec.scrbl @@ -86,6 +86,12 @@ Encodes a string according to the rules in @cite["RFC3986"] for the userinfo fie @defproc[(uri-userinfo-decode [str string?]) string?]{ Decodes a string according to the rules in @cite["RFC3986"] for the userinfo field. } +@defproc[(uri-unreserved-encode [str string?]) string?]{ +Encodes a string according to the rules in @cite["RFC3986"](section 2.3) for the unreserved characters. +} +@defproc[(uri-unreserved-decode [str string?]) string?]{ +Decodes a string according to the rules in @cite["RFC3986"](section 2.3) for the unreserved characters. +} @defproc[(form-urlencoded-encode [str string?]) string?]{ diff --git a/collects/net/uri-codec.rkt b/collects/net/uri-codec.rkt index 7c0c53ae64..e3571338ce 100644 --- a/collects/net/uri-codec.rkt +++ b/collects/net/uri-codec.rkt @@ -91,6 +91,8 @@ See more in PR8831. uri-path-segment-decode uri-userinfo-encode uri-userinfo-decode + uri-unreserved-encode + uri-unreserved-decode form-urlencoded-encode form-urlencoded-decode alist->form-urlencoded @@ -141,9 +143,6 @@ See more in PR8831. (define (hex n) (string-ref "0123456789ABCDEF" n)) (string #\% (hex (quotient number 16)) (hex (modulo number 16)))) -(define (hex-string->number hex-string) - (string->number (substring hex-string 1 3) 16)) - (define ascii-size 128) ;; (listof (cons char char)) -> (values (vectorof string) (vectorof string)) @@ -159,6 +158,7 @@ See more in PR8831. (char->integer enc) (char->integer orig))]) alist) + (values encoding-table decoding-table))) (define-values (uri-encoding-vector uri-decoding-vector) @@ -172,6 +172,9 @@ See more in PR8831. uri-userinfo-decoding-vector) (make-codec-tables uri-userinfo-mapping)) +(define-values (uri-unreserved-encoding-vector + uri-unreserved-decoding-vector) + (make-codec-tables unreserved-mapping)) (define-values (form-urlencoded-encoding-vector form-urlencoded-decoding-vector) @@ -198,6 +201,9 @@ See more in PR8831. (cons (vector-ref table (char->integer char)) (internal-decode rest))] [(cons char rest) + ;; JBC : this appears to handle strings containing + ;; non-ascii characters; shouldn't this just be an + ;; error? (append (bytes->list (string->bytes/utf-8 (string char))) (internal-decode rest))])) @@ -235,6 +241,13 @@ See more in PR8831. (define (uri-userinfo-decode str) (decode uri-userinfo-decoding-vector str)) +;; string -> string +(define (uri-unreserved-encode str) + (encode uri-unreserved-encoding-vector str)) + +;; string -> string +(define (uri-unreserved-decode str) + (decode uri-unreserved-decoding-vector str)) ;; string -> string (define (form-urlencoded-encode str) diff --git a/collects/tests/net/uri-codec.rkt b/collects/tests/net/uri-codec.rkt index 2517f6f43f..d6836e90d8 100644 --- a/collects/tests/net/uri-codec.rkt +++ b/collects/tests/net/uri-codec.rkt @@ -69,7 +69,17 @@ (uri-userinfo-decode "hello") => "hello" (uri-userinfo-decode "hello%20there") => "hello there" (uri-userinfo-decode "hello:there") => "hello:there" - + + ;; tried to choose characters from each subset: + (uri-encode "M~(@; ") => "M~(%40%3B%20" + (uri-path-segment-encode "M~(@; ") => "M~(@%3B%20" + (uri-userinfo-encode "M~(@; ") => "M~(%40;%20" + (uri-unreserved-encode "M~(@; ") => "M~%28%40%3B%20" + ;; matching decodes: + (uri-decode "M~(%40%3B%20") => "M~(@; " + (uri-path-segment-decode "M~(@%3B%20") => "M~(@; " + (uri-userinfo-decode "M~(%40;%20") => "M~(@; " + (uri-unreserved-decode "M~%28%40%3B%20") => "M~(@; " )) ;; tests adapted from Noel Welsh's original test suite From 354a71b080a3ee92de5011207e53079ad268e6e8 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Thu, 1 Nov 2012 14:32:01 -0600 Subject: [PATCH 111/221] documentation: adding examples for string input. --- .../scribblings/reference/string-input.scrbl | 89 ++++++++++++++++++- 1 file changed, 88 insertions(+), 1 deletion(-) diff --git a/collects/scribblings/reference/string-input.scrbl b/collects/scribblings/reference/string-input.scrbl index 71b7cf2a21..3110634024 100644 --- a/collects/scribblings/reference/string-input.scrbl +++ b/collects/scribblings/reference/string-input.scrbl @@ -1,6 +1,9 @@ #lang scribble/doc @(require "mz.rkt") +@(define si-eval (make-base-eval)) + + @title{Byte and String Input} @defproc[(read-char [in input-port? (current-input-port)]) @@ -12,6 +15,19 @@ several bytes to UTF-8-decode them into a character (see perform the decoding. If no bytes are available before an end-of-file, then @racket[eof] is returned.} +@examples[#:eval si-eval +(let ([ip (open-input-string "S2")]) + (print (read-char ip)) + (newline) + (print (read-char ip)) + (newline) + (print (read-char ip))) + +(let ([ip (open-input-bytes #"\316\273")]) + @code:comment{The byte string contains UTF-8-encoded content:} + (print (read-char ip))) +] + @defproc[(read-byte [in input-port? (current-input-port)]) (or/c byte? eof-object?)]{ @@ -20,6 +36,17 @@ Reads a single byte from @racket[in]. If no bytes are available before an end-of-file, then @racket[eof] is returned.} +@examples[#:eval si-eval +(let ([ip (open-input-string "a")]) + @code:comment{The two values in the following list should be the same.} + (list (read-byte ip) (char->integer #\a))) + +(let ([ip (open-input-string (string #\u03bb))]) + @code:comment{This string has a two byte-encoding.} + (list (read-byte ip) (read-byte ip) (read-byte ip))) +] + + @defproc[(read-line [in input-port? (current-input-port)] [mode (or/c 'linefeed 'return 'return-linefeed 'any 'any-one) 'linefeed]) (or/c string? eof-object?)]{ @@ -65,6 +92,27 @@ changes return-linefeed combinations to a linefeed. Thus, when a file is opened in text mode, @racket['linefeed] is usually the appropriate @racket[read-line] mode.} +@examples[#:eval si-eval +(let ([ip (open-input-string "x\ny\n")]) + (read-line ip)) + +(let ([ip (open-input-string "x\ny\n")]) + (read-line ip 'return)) + +(let ([ip (open-input-string "x\ry\r")]) + (read-line ip 'return)) + +(let ([ip (open-input-string "x\r\ny\r\n")]) + (read-line ip 'return-linefeed)) + +(let ([ip (open-input-string "x\r\ny\nz")]) + (list (read-line ip 'any) (read-line ip 'any))) + +(let ([ip (open-input-string "x\r\ny\nz")]) + (list (read-line ip 'any-one) (read-line ip 'any-one))) +] + + @defproc[(read-bytes-line [in input-port? (current-input-port)] [mode (or/c 'linefeed 'return 'return-linefeed 'any 'any-one) 'linefeed]) (or/c bytes? eof-object?)]{ @@ -93,12 +141,27 @@ If an error occurs during reading, some characters may be lost; that is, if @racket[read-string] successfully reads some characters before encountering an error, the characters are dropped.} +@examples[#:eval si-eval +(let ([ip (open-input-string "supercalifragilisticexpialidocious")]) + (read-string 5 ip)) +] + @defproc[(read-bytes [amt exact-nonnegative-integer?] [in input-port? (current-input-port)]) (or/c bytes? eof-object?)]{ @margin-note{To read an entire port as bytes use @racket[port->bytes].} Like @racket[read-string], but reads bytes and produces a byte string.} +@examples[#:eval si-eval +(let ([ip (open-input-bytes + (bytes 14 + 115 101 99 114 101 + 116 58 32 235 185 + 132 235 176 128))]) + (define length (read-byte ip)) + (bytes->string/utf-8 (read-bytes length ip))) +] + @defproc[(read-string! [str (and/c string? (not/c immutable?))] [in input-port? (current-input-port)] [start-pos exact-nonnegative-integer? 0] @@ -121,13 +184,34 @@ characters read. If @math{m} characters are read and not modified at indices @math{@racket[start-pos]+m} through @racket[end-pos].} +@examples[#:eval si-eval +(let ([buffer (make-string 10 #\_)] + [ip (open-input-string "cketRa")]) + (printf "~s\n" buffer) + (read-string! buffer ip 2 6) + (printf "~s\n" buffer) + (read-string! buffer ip 0 2) + (printf "~s\n" buffer)) +] + @defproc[(read-bytes! [bstr bytes?] [in input-port? (current-input-port)] [start-pos exact-nonnegative-integer? 0] [end-pos exact-nonnegative-integer? (bytes-length bstr)]) (or/c exact-positive-integer? eof-object?)]{ Like @racket[read-string!], but reads bytes, puts them into a byte -string, and returns the number of bytes read.} +string, and returns the number of bytes read. + +@examples[ +(let ([buffer (make-bytes 10 (char->integer #\_))] + [ip (open-input-string "cketRa")]) + (printf "~s\n" buffer) + (read-bytes! buffer ip 2 6) + (printf "~s\n" buffer) + (read-bytes! buffer ip 0 2) + (printf "~s\n" buffer)) +] +} @defproc[(read-bytes-avail! [bstr bytes?] [in input-port? (current-input-port)] @@ -408,3 +492,6 @@ for some input port, @racket[#f] otherwise. With two arguments, returns @racket[#t] if @racket[evt] is a progress event for @racket[in], @racket[#f] otherwise.} + + +@close-eval[si-eval] From dcf4d8b040f1acdc535d1542e0d7b1bb1112d987 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Thu, 1 Nov 2012 15:14:23 -0600 Subject: [PATCH 112/221] adding close-eval at the end of scribble files that have a toplevel evaluator --- collects/data/scribblings/gvector.scrbl | 3 +++ collects/data/scribblings/heap.scrbl | 1 + collects/data/scribblings/integer-set.scrbl | 3 +++ collects/data/scribblings/interval-map.scrbl | 2 ++ collects/data/scribblings/order.scrbl | 3 +++ collects/data/scribblings/queue.scrbl | 4 ++++ collects/data/scribblings/skip-list.scrbl | 3 +++ collects/data/scribblings/splay-tree.scrbl | 3 +++ collects/file/scribblings/md5.scrbl | 4 ++++ collects/file/scribblings/sha1.scrbl | 3 +++ collects/images/scribblings/icons.scrbl | 3 +++ collects/images/scribblings/logos.scrbl | 4 ++++ collects/macro-debugger/macro-debugger.scrbl | 4 ++++ collects/mzlib/scribblings/compat.scrbl | 3 +++ collects/mzlib/scribblings/etc.scrbl | 4 ++++ collects/mzlib/scribblings/kw.scrbl | 4 ++++ collects/mzlib/scribblings/struct.scrbl | 4 ++++ collects/net/scribblings/cookie.scrbl | 4 ++++ collects/net/scribblings/head.scrbl | 4 ++++ collects/net/scribblings/uri-codec.scrbl | 3 +++ collects/racklog/racklog.scrbl | 4 ++++ collects/redex/scribblings/ref.scrbl | 5 +++++ collects/redex/scribblings/tut.scrbl | 4 ++++ collects/scribblings/draw/guide.scrbl | 3 +++ collects/scribblings/foreign/objc.scrbl | 5 +++++ collects/scribblings/guide/futures.scrbl | 4 ++++ collects/scribblings/more/more.scrbl | 5 +++++ collects/scribblings/reference/async-channels.scrbl | 3 +++ collects/scribblings/reference/booleans.scrbl | 4 ++++ collects/scribblings/reference/contracts.scrbl | 3 +++ collects/scribblings/reference/fixnums.scrbl | 5 +++++ collects/scribblings/reference/trace.scrbl | 5 +++++ collects/syntax/scribblings/keyword.scrbl | 4 ++++ collects/syntax/scribblings/modcollapse.scrbl | 5 +++++ collects/typed-racket/scribblings/guide/begin.scrbl | 4 ++++ collects/unstable/automata/scribblings/automata.scrbl | 4 ++++ collects/unstable/automata/scribblings/re.scrbl | 4 ++++ collects/unstable/scribblings/custom-write.scrbl | 4 ++++ collects/unstable/scribblings/gui/notify.scrbl | 4 ++++ collects/unstable/scribblings/logging.scrbl | 4 ++++ collects/unstable/scribblings/open-place.scrbl | 4 ++++ collects/unstable/scribblings/parameter-group.scrbl | 4 ++++ 42 files changed, 157 insertions(+) diff --git a/collects/data/scribblings/gvector.scrbl b/collects/data/scribblings/gvector.scrbl index 4446345b99..81cb92be60 100644 --- a/collects/data/scribblings/gvector.scrbl +++ b/collects/data/scribblings/gvector.scrbl @@ -123,3 +123,6 @@ Unlike @racket[for/list], the @racket[body] may return zero or multiple values; all returned values are added to the gvector, in order, on each iteration. } + + +@close-eval[the-eval] \ No newline at end of file diff --git a/collects/data/scribblings/heap.scrbl b/collects/data/scribblings/heap.scrbl index d48858cc08..0862ebe591 100644 --- a/collects/data/scribblings/heap.scrbl +++ b/collects/data/scribblings/heap.scrbl @@ -109,3 +109,4 @@ Equivalent to @racket[in-heap/consume!] except the heap is copied first. (heap-count h)] } +@close-eval[the-eval] \ No newline at end of file diff --git a/collects/data/scribblings/integer-set.scrbl b/collects/data/scribblings/integer-set.scrbl index b994220b9a..26ac7aaa6f 100644 --- a/collects/data/scribblings/integer-set.scrbl +++ b/collects/data/scribblings/integer-set.scrbl @@ -151,3 +151,6 @@ Returns the number of integers in the given integer set.} Returns true if every integer in @racket[x] is also in @racket[y], otherwise @racket[#f].} + + +@close-eval[the-eval] \ No newline at end of file diff --git a/collects/data/scribblings/interval-map.scrbl b/collects/data/scribblings/interval-map.scrbl index aeca9a7496..e7a52de7a9 100644 --- a/collects/data/scribblings/interval-map.scrbl +++ b/collects/data/scribblings/interval-map.scrbl @@ -167,3 +167,5 @@ Implementations of @racket[dict-iterate-first], Returns @racket[#t] if @racket[v] represents a position in an interval-map, @racket[#f] otherwise. } + +@close-eval[the-eval] \ No newline at end of file diff --git a/collects/data/scribblings/order.scrbl b/collects/data/scribblings/order.scrbl index 38c4810109..a77d1dce9c 100644 --- a/collects/data/scribblings/order.scrbl +++ b/collects/data/scribblings/order.scrbl @@ -251,3 +251,6 @@ a single execution of a program: (datum-order (make-fish 'alewife) (make-fowl 'dodo)) ] } + + +@close-eval[the-eval] diff --git a/collects/data/scribblings/queue.scrbl b/collects/data/scribblings/queue.scrbl index ed11262a66..fa3dd4ec63 100644 --- a/collects/data/scribblings/queue.scrbl +++ b/collects/data/scribblings/queue.scrbl @@ -94,3 +94,7 @@ Returns a sequence whose elements are the elements of These contracts recognize queues; the latter requires the queue to contain at least one value. } + + + +@close-eval[qeval] \ No newline at end of file diff --git a/collects/data/scribblings/skip-list.scrbl b/collects/data/scribblings/skip-list.scrbl index f55c919e9a..2f0cf075a5 100644 --- a/collects/data/scribblings/skip-list.scrbl +++ b/collects/data/scribblings/skip-list.scrbl @@ -171,3 +171,6 @@ skip-list, @racket[#f] otherwise. Returns an association list with the keys and values of @racket[skip-list], in order. } + + +@close-eval[the-eval] \ No newline at end of file diff --git a/collects/data/scribblings/splay-tree.scrbl b/collects/data/scribblings/splay-tree.scrbl index f653d543ea..b237f7481b 100644 --- a/collects/data/scribblings/splay-tree.scrbl +++ b/collects/data/scribblings/splay-tree.scrbl @@ -174,3 +174,6 @@ splay-tree, @racket[#f] otherwise. Returns an association list with the keys and values of @racket[s], in order. } + + +@close-eval[the-eval] \ No newline at end of file diff --git a/collects/file/scribblings/md5.scrbl b/collects/file/scribblings/md5.scrbl index 4645c10fa9..f9b0a241dc 100644 --- a/collects/file/scribblings/md5.scrbl +++ b/collects/file/scribblings/md5.scrbl @@ -20,3 +20,7 @@ that is the MD5 hash of the given input stream or byte string. (md5 #"abc") (md5 #"abc" #f) ]} + + + +@close-eval[md5-eval] \ No newline at end of file diff --git a/collects/file/scribblings/sha1.scrbl b/collects/file/scribblings/sha1.scrbl index fcd264556b..215abd6c33 100644 --- a/collects/file/scribblings/sha1.scrbl +++ b/collects/file/scribblings/sha1.scrbl @@ -40,3 +40,6 @@ until an end-of-file. Converts the given byte string to a string representation, where each byte in @racket[bstr] is converted to its two-digit hexadecimal representation in the resulting string.} + + +@close-eval[sha1-eval] \ No newline at end of file diff --git a/collects/images/scribblings/icons.scrbl b/collects/images/scribblings/icons.scrbl index b5f3f02808..c1ef2cb47d 100644 --- a/collects/images/scribblings/icons.scrbl +++ b/collects/images/scribblings/icons.scrbl @@ -475,3 +475,6 @@ Icons for the Debugger. The @racket[small-debugger-icon] is used when the toolba @doc-apply[small-macro-stepper-hash-color]{ Constants used within @racketmodname[images/icons/tool]. } + + +@close-eval[icons-eval] \ No newline at end of file diff --git a/collects/images/scribblings/logos.scrbl b/collects/images/scribblings/logos.scrbl index 1b3633b063..1231bcc2b0 100644 --- a/collects/images/scribblings/logos.scrbl +++ b/collects/images/scribblings/logos.scrbl @@ -38,3 +38,7 @@ Returns the algebraic stepper logo. Returns the macro stepper logo. @examples[#:eval logos-eval (macro-stepper-logo)] } + + + +@close-eval[logos-eval] \ No newline at end of file diff --git a/collects/macro-debugger/macro-debugger.scrbl b/collects/macro-debugger/macro-debugger.scrbl index e0a24f4377..91adf78df6 100644 --- a/collects/macro-debugger/macro-debugger.scrbl +++ b/collects/macro-debugger/macro-debugger.scrbl @@ -567,3 +567,7 @@ module path and the module paths of its immediate dependents. (get-dependencies 'openssl #:exclude (list 'racket)) ] } + + + +@close-eval[the-eval] \ No newline at end of file diff --git a/collects/mzlib/scribblings/compat.scrbl b/collects/mzlib/scribblings/compat.scrbl index 6567208e4b..85b6f2a3b8 100644 --- a/collects/mzlib/scribblings/compat.scrbl +++ b/collects/mzlib/scribblings/compat.scrbl @@ -94,3 +94,6 @@ Emulates Chez Scheme's @racket[new-cafe] by installing running @racket[read-eval-print]. In addition, @racket[current-exit] is set to escape from the call to @racket[new-cafe].} + + +@close-eval[compat-eval] \ No newline at end of file diff --git a/collects/mzlib/scribblings/etc.scrbl b/collects/mzlib/scribblings/etc.scrbl index 3acd10710a..1138875a09 100644 --- a/collects/mzlib/scribblings/etc.scrbl +++ b/collects/mzlib/scribblings/etc.scrbl @@ -269,3 +269,7 @@ no filename is available, the result is @racket[#f].} Creates a new hash-table providing the quoted flags (if any) to @racket[make-hash-table], and then mapping each key to the corresponding values.} + + + +@close-eval[etc-eval] \ No newline at end of file diff --git a/collects/mzlib/scribblings/kw.scrbl b/collects/mzlib/scribblings/kw.scrbl index 06dd69e0ee..4bc7907308 100644 --- a/collects/mzlib/scribblings/kw.scrbl +++ b/collects/mzlib/scribblings/kw.scrbl @@ -449,3 +449,7 @@ if the @racket[args] list is imbalanced, and the search stops at a non-keyword value.)} + + + +@close-eval[kw-eval] \ No newline at end of file diff --git a/collects/mzlib/scribblings/struct.scrbl b/collects/mzlib/scribblings/struct.scrbl index 1fada9665f..51516f0830 100644 --- a/collects/mzlib/scribblings/struct.scrbl +++ b/collects/mzlib/scribblings/struct.scrbl @@ -66,3 +66,7 @@ Builds a function that accepts a structure type instance (matching @racket[struct-id]) and provides a vector of the fields of the structure type instance.} + + + +@close-eval[struct-eval] \ No newline at end of file diff --git a/collects/net/scribblings/cookie.scrbl b/collects/net/scribblings/cookie.scrbl index ecd0b22d6f..dfbe81fcd6 100644 --- a/collects/net/scribblings/cookie.scrbl +++ b/collects/net/scribblings/cookie.scrbl @@ -187,3 +187,7 @@ Imports nothing, exports @racket[cookie^].} @defsignature[cookie^ ()]{} Includes everything exported by the @racketmodname[net/cookie] module. + + + +@close-eval[cookie-eval] \ No newline at end of file diff --git a/collects/net/scribblings/head.scrbl b/collects/net/scribblings/head.scrbl index 440612e680..f46e79eff5 100644 --- a/collects/net/scribblings/head.scrbl +++ b/collects/net/scribblings/head.scrbl @@ -241,3 +241,7 @@ Imports nothing, exports @racket[head^].} @defsignature[head^ ()]{} Includes everything exported by the @racketmodname[net/head] module. + + + +@close-eval[head-eval] \ No newline at end of file diff --git a/collects/net/scribblings/uri-codec.scrbl b/collects/net/scribblings/uri-codec.scrbl index 04a41496e2..f25e274e7b 100644 --- a/collects/net/scribblings/uri-codec.scrbl +++ b/collects/net/scribblings/uri-codec.scrbl @@ -185,3 +185,6 @@ Imports nothing, exports @racket[uri-codec^].} @defsignature[uri-codec^ ()]{} Includes everything exported by the @racketmodname[net/uri-codec] module. + + +@close-eval[uri-codec-eval] diff --git a/collects/racklog/racklog.scrbl b/collects/racklog/racklog.scrbl index 47132398f3..fb1135bd28 100644 --- a/collects/racklog/racklog.scrbl +++ b/collects/racklog/racklog.scrbl @@ -1457,3 +1457,7 @@ frozen structure in @racket[F].} #:location "Indiana U Comp Sci Dept Tech Report #182" #:date "1985"] ] + + + +@close-eval[racklog-eval] \ No newline at end of file diff --git a/collects/redex/scribblings/ref.scrbl b/collects/redex/scribblings/ref.scrbl index 12d515fc1d..deb7b1213e 100644 --- a/collects/redex/scribblings/ref.scrbl +++ b/collects/redex/scribblings/ref.scrbl @@ -3077,3 +3077,8 @@ just before or just after that argument. The line-span and column-span of the new lw is always zero. } + + + + +@close-eval[redex-eval] \ No newline at end of file diff --git a/collects/redex/scribblings/tut.scrbl b/collects/redex/scribblings/tut.scrbl index 183aecdad8..6108526bd1 100644 --- a/collects/redex/scribblings/tut.scrbl +++ b/collects/redex/scribblings/tut.scrbl @@ -1122,3 +1122,7 @@ Typeset @racket[types]. Use a compound rewriter so a use of @racket[(type Γ e t is rendered as @racketblock[Γ ⊢ e : t] @generate-bibliography[] + + + +@close-eval[amb-eval] \ No newline at end of file diff --git a/collects/scribblings/draw/guide.scrbl b/collects/scribblings/draw/guide.scrbl index ffc1527a90..52fa7c3a16 100644 --- a/collects/scribblings/draw/guide.scrbl +++ b/collects/scribblings/draw/guide.scrbl @@ -764,3 +764,6 @@ Different kinds of bitmaps can produce different results: reason.} ] + + +@close-eval[draw-eval] \ No newline at end of file diff --git a/collects/scribblings/foreign/objc.scrbl b/collects/scribblings/foreign/objc.scrbl index c4747489f4..15aafd345f 100644 --- a/collects/scribblings/foreign/objc.scrbl +++ b/collects/scribblings/foreign/objc.scrbl @@ -342,3 +342,8 @@ imported using @racket[objc-unsafe!].} Analogous to @racket[(unsafe!)], makes unsafe bindings of @racketmodname[ffi/unsafe/objc] available in the importing module.} + + + + +@close-eval[objc-eval] \ No newline at end of file diff --git a/collects/scribblings/guide/futures.scrbl b/collects/scribblings/guide/futures.scrbl index 235f33fbe4..431bca8e23 100644 --- a/collects/scribblings/guide/futures.scrbl +++ b/collects/scribblings/guide/futures.scrbl @@ -477,3 +477,7 @@ disabled) are considered unsafe. The @exec{raco decompile} tool annotates operations that can be inlined by the compiler (see @secref[#:doc '(lib "scribblings/raco/raco.scrbl") "decompile"]), so the decompiler can be used to help predict parallel performance. + + + +@close-eval[future-eval] \ No newline at end of file diff --git a/collects/scribblings/more/more.scrbl b/collects/scribblings/more/more.scrbl index f556bd5f3c..ab930314c7 100644 --- a/collects/scribblings/more/more.scrbl +++ b/collects/scribblings/more/more.scrbl @@ -873,3 +873,8 @@ memory accounting @cite["Wick04"], kill-safe abstractions #:url "http://www.cs.utah.edu/plt/publications/ismm04-wf.pdf") ) + + + + +@close-eval[more-eval] diff --git a/collects/scribblings/reference/async-channels.scrbl b/collects/scribblings/reference/async-channels.scrbl index 39649bc6e1..79ffb85b2b 100644 --- a/collects/scribblings/reference/async-channels.scrbl +++ b/collects/scribblings/reference/async-channels.scrbl @@ -96,3 +96,6 @@ the event itself. See also @racket[sync].} (async-channel-get from-server)) (async-channel-put to-server 'quit) ] + + + diff --git a/collects/scribblings/reference/booleans.scrbl b/collects/scribblings/reference/booleans.scrbl index 71043dd6fd..b4feaa5e15 100644 --- a/collects/scribblings/reference/booleans.scrbl +++ b/collects/scribblings/reference/booleans.scrbl @@ -307,3 +307,7 @@ Returns @racket[(not v)].} (xor #f #f)] } + + + +@close-eval[bool-eval] \ No newline at end of file diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index fa453dc8df..35288fa52a 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -2337,3 +2337,6 @@ do not have corresponding generators (for example, not all predicates have generators) or because there is not enough fuel. In either case, the thunk @racket[fail] is invoked. } + + + diff --git a/collects/scribblings/reference/fixnums.scrbl b/collects/scribblings/reference/fixnums.scrbl index 2b5f75c27a..a25da77133 100644 --- a/collects/scribblings/reference/fixnums.scrbl +++ b/collects/scribblings/reference/fixnums.scrbl @@ -200,3 +200,8 @@ For communication among @tech{places}, the new @tech{fxvector} is allocated in the @tech{shared memory space}. @mz-examples[#:eval flfx-eval (make-shared-fxvector 4 3)]} + + + + +@close-eval[flfx-eval] \ No newline at end of file diff --git a/collects/scribblings/reference/trace.scrbl b/collects/scribblings/reference/trace.scrbl index 2394295c72..36bfc46d6b 100644 --- a/collects/scribblings/reference/trace.scrbl +++ b/collects/scribblings/reference/trace.scrbl @@ -122,3 +122,8 @@ results, and a number indicating the depth of the call. It defaults to @racket["<"]. } + + + + +@close-eval[ev] \ No newline at end of file diff --git a/collects/syntax/scribblings/keyword.scrbl b/collects/syntax/scribblings/keyword.scrbl index 89d8aaad53..895d3145b9 100644 --- a/collects/syntax/scribblings/keyword.scrbl +++ b/collects/syntax/scribblings/keyword.scrbl @@ -273,3 +273,7 @@ A @techlink{check-procedure} that accepts syntax strings. A @techlink{check-procedure} that accepts syntax booleans. } + + + +@close-eval[the-eval] \ No newline at end of file diff --git a/collects/syntax/scribblings/modcollapse.scrbl b/collects/syntax/scribblings/modcollapse.scrbl index 8ad12674e5..263e2aaae7 100644 --- a/collects/syntax/scribblings/modcollapse.scrbl +++ b/collects/syntax/scribblings/modcollapse.scrbl @@ -58,3 +58,8 @@ Like @racket[collapse-module-path], but the input is a @techlink[#:doc refman]{module path index}; in this case, the @racket[rel-to-module-path-v] base is used where the module path index contains the ``self'' index.} + + + + +@close-eval[evaluator] \ No newline at end of file diff --git a/collects/typed-racket/scribblings/guide/begin.scrbl b/collects/typed-racket/scribblings/guide/begin.scrbl index be91b94a20..3cfd2ebefd 100644 --- a/collects/typed-racket/scribblings/guide/begin.scrbl +++ b/collects/typed-racket/scribblings/guide/begin.scrbl @@ -131,3 +131,7 @@ Typed Racket also attempts to detect more than one error in the module. (string-append "a string" (add1 "not a number")) ] } + + + +@close-eval[the-eval] \ No newline at end of file diff --git a/collects/unstable/automata/scribblings/automata.scrbl b/collects/unstable/automata/scribblings/automata.scrbl index 72981dedb5..d3a1f8d88c 100644 --- a/collects/unstable/automata/scribblings/automata.scrbl +++ b/collects/unstable/automata/scribblings/automata.scrbl @@ -212,3 +212,7 @@ This module provides a macro for non-deterministic finite automata with epsilon } @include-section["re.scrbl"] + + + +@close-eval[our-eval] \ No newline at end of file diff --git a/collects/unstable/automata/scribblings/re.scrbl b/collects/unstable/automata/scribblings/re.scrbl index 73f5f087cc..8dc82fc826 100644 --- a/collects/unstable/automata/scribblings/re.scrbl +++ b/collects/unstable/automata/scribblings/re.scrbl @@ -204,3 +204,7 @@ This module provides a few transformers that extend the syntax of regular expres [(list) (list 1) (list 1 0)])] + + + +@close-eval[our-eval] \ No newline at end of file diff --git a/collects/unstable/scribblings/custom-write.scrbl b/collects/unstable/scribblings/custom-write.scrbl index 57099cceaa..0fdf71693d 100644 --- a/collects/unstable/scribblings/custom-write.scrbl +++ b/collects/unstable/scribblings/custom-write.scrbl @@ -64,3 +64,7 @@ When attached to a struct type, automatically generates a printer using (write (point3 3 4 5)) ] } + + + +@close-eval[the-eval] \ No newline at end of file diff --git a/collects/unstable/scribblings/gui/notify.scrbl b/collects/unstable/scribblings/gui/notify.scrbl index 9532be9df3..7918b3ca80 100644 --- a/collects/unstable/scribblings/gui/notify.scrbl +++ b/collects/unstable/scribblings/gui/notify.scrbl @@ -153,3 +153,7 @@ Returns a list of @racket[checkable-menu-item%] controls tied to @racket[notify-box] to its label and invokes @racket[notify-box]'s listeners. } + + + +@close-eval[the-eval] \ No newline at end of file diff --git a/collects/unstable/scribblings/logging.scrbl b/collects/unstable/scribblings/logging.scrbl index 17f3070ed2..dd51907746 100644 --- a/collects/unstable/scribblings/logging.scrbl +++ b/collects/unstable/scribblings/logging.scrbl @@ -86,3 +86,7 @@ will then return a list of the log messages that have been reported. (log-warning "2") (stop-recording l) ]} + + + +@close-eval[the-eval] \ No newline at end of file diff --git a/collects/unstable/scribblings/open-place.scrbl b/collects/unstable/scribblings/open-place.scrbl index 3c722b2e78..2f376149d5 100644 --- a/collects/unstable/scribblings/open-place.scrbl +++ b/collects/unstable/scribblings/open-place.scrbl @@ -19,3 +19,7 @@ variables, which are automatically sent to the newly-created @tech[#:doc '(lib " Note that these variables must have values accepted by @racket[place-message-allowed?], otherwise an @racket[exn:fail:contract] exception is raised. } + + + +@close-eval[the-eval] \ No newline at end of file diff --git a/collects/unstable/scribblings/parameter-group.scrbl b/collects/unstable/scribblings/parameter-group.scrbl index bfd99f6824..ebb9d8c054 100644 --- a/collects/unstable/scribblings/parameter-group.scrbl +++ b/collects/unstable/scribblings/parameter-group.scrbl @@ -57,3 +57,7 @@ Corresponds to @racket[parameterize], but can parameterize parameter groups as w #:contracts ([param-or-group-expr (or/c parameter? parameter-group?)])]{ Corresponds to @racket[parameterize*], but can parameterize parameter groups as well as parameters. } + + + +@close-eval[evaluator] \ No newline at end of file From c1cace28ec8072e77d70ccc40c27011c5f788295 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 1 Nov 2012 14:06:03 -0400 Subject: [PATCH 113/221] This test always errors -- belongs in fail. --- collects/tests/typed-racket/{succeed => fail}/exn-any.rkt | 2 ++ 1 file changed, 2 insertions(+) rename collects/tests/typed-racket/{succeed => fail}/exn-any.rkt (89%) diff --git a/collects/tests/typed-racket/succeed/exn-any.rkt b/collects/tests/typed-racket/fail/exn-any.rkt similarity index 89% rename from collects/tests/typed-racket/succeed/exn-any.rkt rename to collects/tests/typed-racket/fail/exn-any.rkt index 131aec6e28..48b4dab902 100644 --- a/collects/tests/typed-racket/succeed/exn-any.rkt +++ b/collects/tests/typed-racket/fail/exn-any.rkt @@ -1,3 +1,5 @@ +#; +(exn-pred "Any") #lang racket/load (module m typed/racket From 6f5e43b851b613ec9237e565d69fcb8b17e81870 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 1 Nov 2012 07:34:46 -0500 Subject: [PATCH 114/221] added a script that collects log messages for use in performance debugging drracket --- collects/drracket/private/follow-log.rkt | 123 +++++++++++++++++++++++ 1 file changed, 123 insertions(+) create mode 100644 collects/drracket/private/follow-log.rkt diff --git a/collects/drracket/private/follow-log.rkt b/collects/drracket/private/follow-log.rkt new file mode 100644 index 0000000000..d9cd5aa14f --- /dev/null +++ b/collects/drracket/private/follow-log.rkt @@ -0,0 +1,123 @@ +#lang racket +(require racket/gui/base + framework/private/logging-timer) + +#| + +This file sets up a log receiver and then +starts up DrRacket. It catches log messages and +organizes them on event boundaries, printing +out the ones that take the longest +(possibly dropping those where a gc occurs) + +The result shows, for each gui event, the +log messages that occured during its dynamic +extent as well as the number of milliseconds +from the start of the gui event before the +log message was reported. + +|# + +(define lr (make-log-receiver (current-logger) + 'debug 'racket/engine + 'debug 'GC + 'debug 'gui-event + 'debug 'framework/colorer + 'debug 'timeline)) + +(define top-n-events 50) +(define drop-gc? #t) + +(define done-chan (make-channel)) +(void + (thread + (λ () + (let loop ([events '()]) + (sync + (handle-evt + lr + (λ (info) + (loop (cons info events)))) + (handle-evt + done-chan + (λ (resp-chan) + (channel-put resp-chan events)))))))) + +(define f (parameterize ([current-eventspace (make-eventspace)]) + (new frame% [label ""]))) +(define b (new button% [label "Done"] [parent f] + [callback + (λ (_1 _2) + (define resp (make-channel)) + (channel-put done-chan resp) + (show-results (channel-get resp)) + (exit))])) +(send f show #t) + +(struct gui-event (start end name) #:prefab) + +(define (show-results evts) + (define gui-events (filter (λ (x) + (define i (vector-ref x 2)) + (and (gui-event? i) + (number? (gui-event-end i)))) + evts)) + (define interesting-gui-events + (take (sort gui-events > #:key (λ (x) + (define i (vector-ref x 2)) + (- (gui-event-end i) + (gui-event-start i)))) + top-n-events)) + + (define with-other-events + (for/list ([gui-evt (in-list interesting-gui-events)]) + (match (vector-ref gui-evt 2) + [(gui-event start end name) + (define in-the-middle + (append (map (λ (x) (list (list 'δ (- (get-start-time x) start)) x)) + (sort + (filter (λ (x) (and (not (gui-event? (vector-ref x 2))) + (<= start (get-start-time x) end))) + evts) + < + #:key get-start-time)) + (list (list (list 'δ (- end start)) 'end-of-gui-event)))) + (list* (- end start) + gui-evt + in-the-middle)]))) + + (define (has-a-gc-event? x) + (define in-the-middle (cddr x)) + (ormap (λ (x) + (and (vector? (list-ref x 1)) + (gc-info? (vector-ref (list-ref x 1) 2)))) + in-the-middle)) + + (pretty-print + (if drop-gc? + (filter (λ (x) (not (has-a-gc-event? x))) + with-other-events) + with-other-events))) + +(struct gc-info (major? pre-amount pre-admin-amount code-amount + post-amount post-admin-amount + start-process-time end-process-time + start-time end-time) + #:prefab) +(struct engine-info (msec name) #:prefab) + +(define (get-start-time x) + (cond + [(gc-info? (vector-ref x 2)) + (gc-info-start-time (vector-ref x 2))] + [(engine-info? (vector-ref x 2)) + (engine-info-msec (vector-ref x 2))] + [(regexp-match #rx"framework" (vector-ref x 1)) + (vector-ref x 2)] + [(timeline-info? (vector-ref x 2)) + (timeline-info-milliseconds (vector-ref x 2))] + [else + (eprintf "unk: ~s\n" x) + 0])) + +(dynamic-require 'drracket #f) From 478fedeeb76dc0b674df6cb84a12ee0deb7fcf8a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 1 Nov 2012 07:10:38 -0500 Subject: [PATCH 115/221] fix up mac os x version of the redex bitmap tests --- ...eduction-relation-with-computed-labels.png | Bin 6202 -> 7191 bytes 1 file changed, 0 insertions(+), 0 deletions(-) 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 621cd95b56e1a368bd26d4c7cf54d70c0115fe78..16a4e992c62aa6f58bda0ff68cab5c735fe5a178 100644 GIT binary patch literal 7191 zcmbuERZtvEmxc-M8r&wh1$Va)26uM`2`+)bA-KDHAV6?PaM$4OVQ_cXL6&c;{(pCC z_iit`ySgtOdqIElD5ifYl;TZcO;9XDrbu)`Rw2tCs@TgGKAO7 z?I;Z_OvNHp9s=w_Bw6sD`R||MjkTqxq+PzdG3?l?#7m;W@~X3UEk3_+JXxN9W-mDQ z6r~U*Iu&sp&l&NZ5V?c6P9y*mX{N@4r)WNJFj)OakCq|BkHld%#&#gs-9;5;ybpB$ zo8i=n<#)AG72g#5)IM}!quM_9? zA2J!ImZZh)yCe66{|3X%CO61|LdH5>^adV4K-@>}kLv;1+F30UB8m5aom0H?C)Q_$fzj$)J_0;R%~wCpR%9| zta(7vQ2fv?EMNBU|_)S_r$-mQxFP(P>teOWSq)F+^weF4+fQ{&K)F?XBM_i zK60N#&(Xdwu-u5QlBv+jWGzD;o=hU^2(%dKUA%OlGRZIOmBWPD6?E@I#KR`|q|s#n z;v~+%A4}f(fk#RZKxc!5Zy_`}2pZ%D&T=Owkr0>wwH@FUK!}6!{kvc*fhkQi6zI=i zQ$yazi?#4bNJ-h*qc6`;d-ZStI=w4WK2@s=o9ReeEtPPFp+uLqTb&-z!K!6eY!|;` zP_U1ZE+z3j=_jWEM5}7+E@JO;1T7p}v5>xq@5hSDbfQm`A=lU=;FUOSt{reSn_6yNGE9`odlrwf&uOa5{UpC+*T$}Wt zzZUNYY(7{MGJS?2%rz#I3U=hhAM%5!8pk~z6p83A3+eb_Tna2y=t>RbYepPh^!HKL70i&J&{$~8KD>|$95-NCw!0XGBE z+w^!Jbx+HAD236IF{A5t@!C3w%}`SdV66FjC^rEe);KQt1x|$d#XlLz1bB{t0qKGL zD{GvrS5K-Nin_WC#-KGB4XtXZ2f2N!agfiXVivFAk!W+l=BC-@)m21ntmS-#Zf{}< zU{TU-$W;83>I{&8@!crMPuRmth<nk&JTF?{t`QxvC(2I;8^7^P`*!i z+H8%>H$J0?>h)>nv+CGW1Wgz&`^CJSu5WPf2?_D=@Tg(+n+}%Z5GJoYfdUwAn%guV z>7|jl=hbcNruk`sm1+$Hz!WtmT_PI8HZ52|e+@Msxq=^vD7Zy*rHwX>MspcTSq%92 zKY#&0VyA$JQl&o-8C!qNC6=%LiXAje{H~4p>4FKEQ=Il_lZY#UI;Sb$Fb#pQ6crcC zk&~12GD~5H_TX~al-4nupckouwA;P~3#!RQVEt-~6=QvSx(;S$am%=e06^SC8X$SS zC+^Rpt@eU(6=P;i?FG5ear4f?dY}zwo!(NgR%vPJUJPRS7aCxqAYv64Sz6$1gqm+> za=m8)ZdvlXk+7t0llYF;7jM#30J78!KIBn!FHftqqeZW*(lN1xfHX6+W$XHDXoFDG z4vY(*SY~XVX(DgLq4NCZDKaV{pVvb8POMzAmQb}o!EwFhccO~0EV7UumwLn0q(}-r zrK$xSFNShux3*JRCiSO{ueKg}JH3h@9;?y#T4QlbS%!StZb*gbBupJmh=3HC_-rX{B7byl$XdCU=2Ld3+ zUWm5r;A<}(1?*t`oRzsGJJ;~w&q!-9n72yQ zjXZ$>bW)*!&|hRdfl^a&`bKepE7>t*$A3hk=%47Tz@ZzXg(ZLVH^c)W?=# z#DN5|%SEgc1gn;mWKN67c&g}?f*2H&#pkS$FC8k2)KnHccFW$EzFk21ddPpVjEjC9 z9Rgk+jBeci7tfa6ZB{}<5p8U3?e#(d=n?I3`NegbRLpjwi))Aqmf7_KVq|+sw7~tD zx&R9^aiM@j#SvNLG4sk23lCa^{N?7D8`GR5AKRWmM#q}OLi_vYBIFet{AM@a%uYfl z7Z)medZZwUXfbNY_G7dSM0Vp=BXDmxeh36FU8HV$+}^S0(a@_SsZf`jT=N-fsne9v zgk}T+mE?c)NfS?DZsy^$j?~|wirkcdx+jc9rn8&EuCA_D7`11%vKof|bu53X0Q&Z%t)mYikDo|*}_fJYwgssU58RUunB`o3c_$vREGxg2#n z4#%Jautfe0XdVP{ax!N!jsWR-Szr`rF`0(l^Am>Rza;+r!a&c%(v?^RK~5h;kN*%g zb~f%(P)>k*t7_4j#CNqjX1?_&24rF3e7&!_j8B8y%iy9-t6Lp*vHABalN(2VoTYNJ zv$$aMLE_DCXP?0&kr|Zc(Jg$Q3Q_+rCX%lBwYM`5d3{t$4hGU!2{(50p0(C3iC@$y zsjZ%EP;b_1HmYu(w2g$(p5mr{>d1RMYTe6y9&AwdUmr{u-N3hRkO{A-0+?5eqpBN)g|u;L0o^J>vulHX+x+Y zu6tU@X`3Ggy(ymW|IaTRb#-+lT~}WcQqqV0!Z>7f^zDVtmz)3Ge+$CLz;gAdXR-Ij zs~XOq&X9M$6O_d^w*-On^=s%xWAq-rTzwV#HUcAjWE)t{*pzk10xG&qXe#Qn?_;w` zZfV371~*T$j{ZSaZO*S>)K5H6UM*mR;F0Rd%1k^@5_Z5Wz+yexGYDMNt+9Etq^O~2pJ zwxzG%QAM2gq!H4Yklk-&;xfI*{S+J?_>PrVW0^R^cl9C9kqLmpM@~VBMygo z05O;eJ+@NramvtPUo_UwMWH)C)H^Oq(4Op+6=oO zUqm8mQYnwu;xZ)8GFjLrXfWpFXzAUkF~}ZH=H~)CB;-cR>sHQC-FCu^v8(eJFDYo_^(Jff5)6O zDP9PomYZ-w*O%va>ke*hwWlO%{x^2I3;fo|V@3;&aKC*-R!X9z;^aOs_OTp6OH_6id*Pn0fX#@zdt0xkNjIKrild@~m5aNy9f?6_A z15LQxiz7QX@LdvweQAqYq&4=>{U3ZYKYNY9OAz7es`|u#y$xZ}YSJf2E2-eTcDJ%fPWo9^b%u4;>QKc;4 z^j7Ub*-P|iGTgSpl=0wAiEgs%vf|bSgc92Rs^KgKvZH>*v^VJW$`ivj)Q!x`qFpT? zF30BUgWs5^4YQo)QIDWb2+V}r_CpcVu)12k`#_e>b#f^1MnUyNeA+VFv;7{wD9wEv zdEH&Q$1;?j$};7k%s1$Ur7Ow)50uHlHv*#7sG1PosCU;Ax_K@p3AC$e-|x8n1e4hGOI})y3`|vM?@sME_Wj97zwy;g2=j? zf(aSX&${j?)`en=Y@zYvdEhp(QkBiB{6-QUten+SktZ_*74CB+^;cgE! zeqSmq5iGnNZ@!Ya9oQG?2PMiW`^+0haE&1M9jZCm?I_eLtTs5^T7=Ow&YhJrfs_a3 zH5`m0H)^RZgWdwB);WhjpN?N2+?=Jeu;W;_?V0R6Le@7nB-GS!#a`~W*mu1$dVC!V zV*Jo;wYM;@jA=cJchF{?kNK08o;zSz8z-GgiMJ+1U5$!2)E2}VV?yQUgN8jyGeWhF zLZT_pM(BbbPn308 z5?LS;EeyFFVx;_PqRbs65cwyNAU5ky4E!X!}x4~|y=U}EJ zjDBWht=5(jeyp=(Vl#6>6kuXVHe?|v$=iq1W{UBSR5ZVAAw@!Q32D%WaEqh{-pUxu z4C}7)WiHt_nC|e7hFs{gt35||&Kz{nd`^Sh4@+_OEaPY^#5RDfoAT83xh13tk%jJ9 zTw64aQRtk4gc2(oE_MCz?9=(F|Mc^-=Yw#mW0mRH>wE0qA7a-roZ+kWrKYX+s$A*$ z&yUYuUrpIaXRp22C#nUyqp21%9RB*UuoLH@UWaaJTn4pM_M;*d z2B^y;<3{y%%?E00hwirK)G#lHNUdp#`Y)J>LB#aTL39+rxpi`mwBcBm;-L|N4o@Kp z3NSTTmDAA-9p_O}QYza+h?cl=JgvGj?Vpsn$J&E#hrx_k#(mkerqX4J-o;1tjg5ll z9%Sc%Zb$PQySsn%9ou<+v?)B{FA>gjK;mcW`4MwzXnbgKt&p@+*|y$@ulb9ahh-qqbs@jn~%#Gw{V)6 z;`Q@{O5GJZ@wg%xzrE#OYQ0&1xsoqi{;roeNM^pd`EE1xvd%H^pD7C;Y7ZE`d0Rqj zyxK-;oP8*XD8+kaXUkLAn%y&t1~)9$FiP z?V9S3nh_%8LSt`b*}PT~D>mFipXenf75TIN;6e04Y(ex~;!@PUOnxX5NVg_^}aT{ydYMVOv|9^%vsYqoxT_Xmo5W=G#0pH=`NuG>`pU z&?_45l4Hxsi74tyC(Q3Pp5WGw)kJ$b?CV$$6SyVod|v}3k9C#g5AfzH+d`)<47cH;{Go3-iLfjXIRTg-s@+JW25ipwrV1lp=TtRDL2axFI4 zlkSb@Q1kMpUTh6u2~1$R3imS&f@N#+1`=V!OPF*@WoN3_;8mbJqULbJTgPs-bk!kt9~UZ6JBmJ1g}D*LdKo< zhhf%iye97M-9=FOP2uW~z9c2DqX6fjc7|=2L$Rc zC|9m`0+nd!O#yea4m-M{m__jMp5D%_&pxjXU3!JYzym}&;oMhlx z7iw>SUvn68{+K$HfwW^&SYuAsELqWe7Ayh_j%sMXPmI<(F?oA6oZq}m{%zHYRIwWcEmHWKsf$Wn}X!y$f)6sFefEe zkKkFe)^@v8-(J|oY8@7rxf6vy(HX`=x^vft4{Vhq0einILS&yfNYxfuXQ%te!ksfz zGTg5}ZPci-%#!sU0jHdxP`5GktwiHzi~D}w)8&0DmUh`qI9c5^cuh-TJzpvDdpHQl z4F2sA(lEhO*}UW3;Qx&E)n6>cw25>!$Fe}*GY}{`fmd_t36d{hU|0N{M-gagd%^ym z9diQ4KdTQhd+WqLrLDv1k7lDJ9WW78H8S8Qr`BoH7!le+R|A$jC?LB=!BcnTVo2eK zwJgN>-Q#tq`gQ}>7F~S76dN?rs$RU8Ek>n>|oypm8VAPCT$3te_l+%=W801}JgtqlBJIC+i=hU~D zTh6Km{y~3vzVN9mKwvS)n-uGeLZ=p^bx)(G>7cODX(a5KI}FKk?|B(|eq{3c)J}O; z%#kUX9Iow6U08K~<7mD&W#WWO&pD3U0Hs^BL&oBYx2)2CC>A^>)$0`Rx%a&l;l3s0 zDIzIw&1UBZ{yVX$Zhy*rI5D|546Zn=VAU5F>1#$%TyHmVYd&U6bSB;3*xOzE zfx7hGDE9ujHjr(ik;8uY#;|iZC)?SzW!g9JyGz&3t!?^)&oMv5p;1)@oVF3YOs@S> zf!aUOyxHL%8NsS;XHQXP8WW=w^YKm<`{BN;?e9cFvuNC=Bzb+Tc6 z@~t%2T+RnGH>#Ue$6wAF-fM1(q`E!U^u+i4x#jX8#ZfF!=rMu32&CfWOrJ z_9&7Gxu?>yt7#_|EQZ|s=o1Yv#&^u Y1{|fv;tQ5&OZzz#t9){x}Lf(Rx3UtMW6#c{Cc0M)MP->@C*=0BQ?U!V|KK^3zO5!jtl~Ky_Y{K#)|WZO^H$+$-Qk z71it6GuLKu<5p%@S>>7w3JO|VTdh(Q;mN0GeZpYSbS9xRWn4fa*H9EiQHFvT0Em&~ z$a2$#8~}W|Wj{otNC&_Xie<7~aU>TVc@^n=Q-Lv(bWtP+06$Bil1l)@A8j-hE{g;Z zdBH$Y6s0N?b^ia5}PNaQMtqM%Vo0B*bHDNT-$ zBg|5?Zm@TpdMG zI)xD6h>ueprFT~1Au$?_pM3Jkh7B9^di}$fMtI^d7kzK~G#9;{{FKq#wFA2u5{4JO>$3~G=Ena4 zo${+sqIo9*9Dd|t-kVvoSrKvFGgPJtrbo*FZcO~b*eubuh{TQ~8gRUr9UGk|@_YSl z#4S4^ufKgb4iE)S?iwq1^|8$O;)^dzOG_W%Y7GWMU0q#nZtjT_CmtX>VR+EHKD(g1 zKR+2bW7;s*pGgGb3mP{s^Z=kPY5?T0XzJA!-^jqv(tWes34pQkn}|d>GVU$66DOYq zVh*C?qq)W4rwcr~jxbn&{+{$Z=iVz!-)IRr=2rv z3~^XPtoHa@!Jdv0WWP8)6#q145QHI6>^H~~Ab7Ngy zqsBl{6lKt+=HNT=W!0smdhaitDVtG(cCEo0TOJ0*I;URJcYF+4~b?0%4#i()j>4 zUL+~&r5SB3%Z+cJvsY0R)!qYU&s?k7Ret`4-pk9nD-muy005qy=l_h~-6W9R&jJ4%? z;WS!Gxq67JLm&)3b^z*&KHdI>Oxm#qjX)UQbaZcwRRRWwCs(cQWpO5fFl?}E|7$e# zxF~=?7=GCGpM*ddUJ%g}Yz`uNg3Zw-`W{!e69~hP4$&J7R{=+c^N?1CKzJ0`0Z>-v zMTJKyfSntovwx@`>M9Wkg9}-PK(IN;K$c*05YZEC4kCJj%|S#@usMk62{s22J;CN6 zq9@oK=22qwTD|uC;ggIRfzvz&^95F7%0RFx=B5l|emZ_q>9&aHYoYAEOc~A`;{qJ9 zyvJ9{tpzb(J(xlx1r)}Yl*87^G7K#}LlHjKF`1H*9) zIHS6)A?wGKfeFa=?@o&1(P%UpFDmazFl9J<_H221xmAiHJo&JoIFZ?IEaI1t-LENw zPA)X<<;Q2`NK66#WR@YI9z#Bk#<%onF0PTJY zy_z!U!M*5SF6n1KgwS z0#&8+0f-tY3(?apO&I_{6!B_%kSMp`ujXRa_1or0eL^-jK2vlcEvfq4rJ_u!0^s*& z%8(i-J-=h|#4`m_Age!92B}o~eZ{;wrwL_9ot3&&Juq&)Bo&w z0wH9@4cd(!W&_o3rVJ(woktx3SPlvX+mt~l6bgmH0bM14Uw{2IFE8)TojV~RAp^}z z7{(ZS+G*$h{N!%(OFW`z|4(1{O)>cHZe|BNg5Fa_+cs}lE`0Sl;66J$v?=HESNeD8iEu6G)yAo?WX{mS@KXC3kCT0dzBE&?zDT zZe&;QLR?VOZP4%-nlhX`dD3V!TB9Vw6Un`^H=GWMa$|Dar%L)ZWuPd^piwo})iw8K zw(yvlG7xN>?xqYBMNzuu#>U2Gi)NOXG7yFj#FT+xb3CXigHf;68klS*@#Z58d+Y#X zd3G#~;q2<3Dbp0qw8HE;f$*3@_mA26hpxo~SAkcbCWSef3`FDaS78GA5I`M8dG9qm@_xFmsBypixc~PZ;)?LV(mK1-uhiBVXu2 z2T)r@rY#A>89JcO;CUxPe6;>Z{yE&K%lYKzh$3H~p{^K#Fj&xzi@9^-ip}@B6KoD5dV1A- z$Jc6BIBDq#Hb*y820GJeu-pD2vt%%;tG_#Xwhe6~#|JDNg7XuG4E@dOZ}--9nlf~> z^!n;p+RTHEeFbf@5;sy8`DIiN!RuMNtB3iap`oG6aw@Jr`m+;;kjoWchb{{Z4Glfg zphJ82rqh(c=Ml8PUKlp#@b_EcPg}9Is?8d8y+4fF>$Nvq`%l+Fed!KbfPcodmip4Iv;hC?Yb}FUw*jI~ zi}k0i_(BbJN~}Nag9FOJ@5YXLBhVE>Eq1z)t|`P>GrO!q(Z*ygi7-E6o-ec=l!E=`1ZB0FWi56ubKQ9 zVAc1Ryk`F;64>_RrNOJ)fH2;uiaw3_cmBw}Q5km{qQ7wac_+`N2L^YsMA=K79~i?0|1AKD;DfqS6tVr<8^=Rhr<`Ec`Vij1Oe?VMJtR^A@u=KpT1 z^0r!QdEN`<`M{d>)7X_K@-TkgI~;c3MHH_042?_WNpfVl>7I&YK4)d69spGG%*16u z%W@#ek_b7)tLBFkHaWXOkr|hM-lR^wA}u;o23G)pJvVfX?4u*yEp*I7b!+R&i^1J8 zkqN+9|1Ccid`a1!wKDUR)|d;NJ7^Z=C&h3>JM=yK2KE7t^(*h(hB|n9eefKX!)X{WrYqO_^GY zzS@yi?YJ&#)ts^R1O3p9*y*0J!6Rmd+|P7yu`<0^o@1M4HxU(UG-wYCc)0{GG1^4TFVQzdVUDiN5O2s$@8Tw@szEBi#+onNy#;=b65QDIqGSD z@n0@^emPH75`5|NuvtxS>qcpqoMy8QRw@UmAI9;<(8-tU+I z;PO()8pBEv9l-4h-n$2bcE8C609MTB2cLS@1;BrQe$eY#m;O%SvUE?0PrfWAVRzN} zGg4VGz;AEBG~mAVsuvvqm=j;-0$_mY%Z&#T_n+Fx3psfp4v6RaGI7lG4SEEP$C>6| zLVCF_3sVNhC?+hz&C{8dAxuae^IWjm+4io{21?6vz zxFiK~Uia%b!Wc6VDARPCEgCm&+@eK``ulWx;M%ooEiElmr%q+D`u+YaxvQ$cjCaPF zeBC0{Q;=yBPC1cu>l6dQylyUC%}Eohzh+C0F12_N5A}_u63-VV@quTUR-KA z3*FwHInn`+&QA7@PTf56`owAUGo}WGIrbS-o%L6~kNfS%)QjGx1a6apYchS^yUKj} zp9P0wet~EIiU-;n4%bd>E~&Uxy2E>Z7z&;jw8%R#YSMnIMzM)Q)7ESx7BF=1HZmL_|MM& z$Px!W%cRqrPh(}h^(TuB#x{y?~U(x18|%DcSFI_=2l0K z(d{}e-?uLE)*@+CtoH~)_CJmA`oBDxOt%m0CiCVAV*Jq)y^>xhc85Q zX!Od<#Xv5fW0vIZ#i~;=3q-x0%fgg_>ANrqTH){L(!lo=-!GS_n3}IY|S+_&~b1{Ve6CeIb*u{$%4;?!6*=L_U zh~fc&HDv)#)^{IL8w|g6+rxg=Pa)o3bff(?R$sY4;>6_1W*?6J=U;xg=acB_JDMNT zT~9^W`gv15m@KBf=7*Enx6JbxaZ96X|G!OLb?K)8UQs(tpSiR0w&q>y5J}th?2q5e zzS23O)$IK^j27^>yv6}cj{=}OvpW?Jw3Pq*wpbYKJC@CKcC0&dH2K^EPVUlOoH;<* z@zPplQ)OYA>-HFuVK2^JP8-YvSM&0^S#War2O&U@b~QX4rWL9`cn>H5xcJv z0N|BacQg_*KF8a8dZ>&Oc{J;<=8dt>AERP8hz{bodrk-~d`=<~LXkKnRSriM#`IRR zIji{qxDg8`ckOLD83#^ekQLsDARQhX$v;hBEyH6#q zj`CaKPYXz{G%0Yjf64AwVwb$^7yBM>g}?W9t>WO@rlCOfkz`uH{J1Np<_G)x1^Cl8 z9n=E)YlW_>KaN|wI{)U~QKON#c1soDGTJ3^^_D98NwQ@Xt^r|!55j1Hu}Ae26d4h` zUF{Q4%n5T}tz1o8@i*RzFj`>XM*06e=#_a(a@OvAb3QHhJwa?3Eim}x#3iqf@6>B+ z?ZF!0RMRha`zoX#To%U!1qu9lAG}8km=#?GAwG5uNPdvV8qD7&iTK6Ip%dIarw4s1 zl8Ct|UdG9~cY==vI5JEUcYAep41mbhubPjNwO2|~5w)QATQ`lOC}UG0!!yOK8>3e? zslae%yRmy}iS^3*8wMAayBnJhXw_=;6YN->=I0vC$>^2vQ< zvpU+U3>IgtN%!;1X;t1-8|W?`qaXNZ)={6^O0AL3WV4w) z%rV?m-c%XrbXO+Z>0xG8fc6T*(UpBqQEe^CR=6?mr^DSRZJH)^D}%*ybMC*3*cbC= zXq8Q>7PxwPFzKd1+Rp4gm#kFpjheFTa+h?EodQ}iV&_$deYfpJ%lV9XBL%c6Jh^J^ zG&UUo-D9Du?2;=#rS7{8UQPg<+&sFw^qAq~=G8T3V6yv~iBeV-9Vplztw6doxKr_k z2{S*Le)RC8RXhL~T7ly2i3!u@z7=KBmu1K7PD;MgjQbM3qubc0tx_H4Xt&;HX6)U@ z4rmUl4|=b#gNvJ09=bWOJf5;fIRMkGE4)12iOud^@J40jmj{k~vMQ4!I&KkqwXLby zCn?cV@lEHCZr}U84B(kcHtiiGQ-bIy0^v!4-qTha~P8f$*rY)dgn+8-@gMCD Date: Thu, 1 Nov 2012 14:38:36 -0500 Subject: [PATCH 116/221] adjust generate-term so that it has an '=' in its concrete syntax when generating something from a metafunction export redex-generator (and add docs) rename generate-types.rkt to typing-rules-no-ellipses.rkt --- ...types.rkt => typing-rules-no-ellipses.rkt} | 29 +++++---- collects/redex/private/generate-term.rkt | 15 +++-- collects/redex/private/judgment-form.rkt | 2 +- collects/redex/reduction-semantics.rkt | 1 + collects/redex/scribblings/ref.scrbl | 24 ++++++- collects/redex/tests/gen-test.rkt | 63 +++++++++---------- collects/redex/tests/rg-test.rkt | 6 +- 7 files changed, 86 insertions(+), 54 deletions(-) rename collects/redex/examples/define-judgment-form/{generate-types.rkt => typing-rules-no-ellipses.rkt} (71%) diff --git a/collects/redex/examples/define-judgment-form/generate-types.rkt b/collects/redex/examples/define-judgment-form/typing-rules-no-ellipses.rkt similarity index 71% rename from collects/redex/examples/define-judgment-form/generate-types.rkt rename to collects/redex/examples/define-judgment-form/typing-rules-no-ellipses.rkt index 0f7c898581..22cff83039 100644 --- a/collects/redex/examples/define-judgment-form/generate-types.rkt +++ b/collects/redex/examples/define-judgment-form/typing-rules-no-ellipses.rkt @@ -8,9 +8,8 @@ ;; This file makes some small changes to the system in ;; typing-rules.rkt (in the same directory) to allow generation ;; of terms that satisfy the "typeof" judgment-form. Specifically, -;; since this kind of random generation doesn't yet support ellipses, -;; they have to be eliminated form the judgment-form and the -;; metafunctions it depends on. +;; since generation doesn't yet support ellipses, they have to be +;; eliminated from the judgment-form and the metafunctions it depends on. (define-language STLC (e (λ (x τ) e) @@ -77,12 +76,20 @@ (typeof () e τ) 5)) -(define (random-terms n) +(define (random-typed-terms n) + (define gen-one (redex-generator STLC (typeof () e τ) 5)) (for/list ([_ n]) - (match (random-typed-term) - [`(typeof () ,e ,t) - (define types (judgment-holds (typeof () ,e τ) τ)) - (unless (= 1 (length types)) - (error 'typeof "non-unique types: ~s in ~s\n" types e)) - (test-equal (car types) t) - e]))) + (extract-term-from-derivation + (gen-one)))) + +(define (extract-term-from-derivation t) + (match t + [`(typeof () ,e ,t) + ;; test to make sure the generator + ;; generated something that the + ;; judgment form actually accepts + (define types (judgment-holds (typeof () ,e τ) τ)) + (unless (= 1 (length types)) + (error 'typeof "non-unique types: ~s in ~s\n" types e)) + (test-equal (car types) t) + e])) diff --git a/collects/redex/private/generate-term.rkt b/collects/redex/private/generate-term.rkt index c4638ca384..cff8ddc97a 100644 --- a/collects/redex/private/generate-term.rkt +++ b/collects/redex/private/generate-term.rkt @@ -341,12 +341,19 @@ (let ([body-code (λ (res size) #`(generate-mf-pat language (jf/mf-id . args) #,res #,size))]) - (syntax-case #'rest () - [(res) + (syntax-case #'rest (=) + [(= res) #`(λ (size) - #,(body-code #'size))] - [(res size) + #,(body-code #'res #'size))] + [(= res size) (body-code #'res #'size)] + [(x . y) + (or (not (identifier? #'x)) + (not (free-identifier=? #'= #'x))) + (raise-syntax-error 'generate-term + "expected to find =" + stx + #'x)] [whatever (signal-error #'whatever)]))))] [(judgment-form-id? #'jf/mf-id) diff --git a/collects/redex/private/judgment-form.rkt b/collects/redex/private/judgment-form.rkt index 2505bc0cfc..b8dfb75502 100644 --- a/collects/redex/private/judgment-form.rkt +++ b/collects/redex/private/judgment-form.rkt @@ -413,7 +413,7 @@ ; Introduce the names before using them, to allow ; judgment form definition at the top-level. #`(begin - (define-syntaxes (judgment-form-runtime-proc judgment-form-lws) (values)) + (define-syntaxes (judgment-form-runtime-proc judgment-form-lws judgment-runtime-gen-clauses) (values)) #,definitions) definitions)) 'disappeared-use diff --git a/collects/redex/reduction-semantics.rkt b/collects/redex/reduction-semantics.rkt index 7fb73dae3b..c292e58cc1 100644 --- a/collects/redex/reduction-semantics.rkt +++ b/collects/redex/reduction-semantics.rkt @@ -64,6 +64,7 @@ generate-term check-metafunction check-reduction-relation + redex-generator exn:fail:redex:generation-failure? (struct-out exn:fail:redex:test) (struct-out counterexample)) diff --git a/collects/redex/scribblings/ref.scrbl b/collects/redex/scribblings/ref.scrbl index deb7b1213e..eda7ec61c1 100644 --- a/collects/redex/scribblings/ref.scrbl +++ b/collects/redex/scribblings/ref.scrbl @@ -1641,7 +1641,7 @@ metafunctions or unnamed reduction-relation cases) to application counts.} (generate-term term-spec)] ([term-spec (code:line language @#,ttpattern) (code:line language #:satisfying (judgment-form-id @#,ttpattern ...)) - (code:line language #:satisfying (metafunction-id @#,ttpattern ...) @#,ttpattern) + (code:line language #:satisfying (metafunction-id @#,ttpattern ...) = @#,ttpattern) (code:line #:source metafunction) (code:line #:source relation-expr)] [kw-args (code:line #:attempt-num attempts-expr) @@ -1824,6 +1824,27 @@ term that does not match @racket[pattern].} (add1 (abs n))) #:attempts 3)] +@defform/subs[(redex-generator language-id satisfying size-expr) + ([satisfying (judgment-form-id @#,ttpattern ...) + (code:line (metafunction-id @#,ttpattern ...) = @#,ttpattern)]) + #:contracts ([size-expr natural-number/c])]{ + + @italic{WARNING: @racket[redex-generator] is a new, experimental form, + and its API may change.} + + Returns a thunk that, each time it is called, either generates a random + s-expression based on @racket[satisfying] or fails to (and returns @racket[#f]). + The terms returned by a particular thunk are guaranteed to be distinct. + + @examples[#:eval + redex-eval + (define gen-sum (redex-generator nats (sum n_1 n_2 n_3) 5)) + (gen-sum) + (gen-sum) + (gen-sum) + (gen-sum)] +} + @defstruct[counterexample ([term any/c]) #:inspector #f]{ Produced by @racket[redex-check], @racket[check-reduction-relation], and @racket[check-metafunction] when testing falsifies a property.} @@ -1834,6 +1855,7 @@ Raised by @racket[redex-check], @racket[check-reduction-relation], and The @racket[exn:fail:redex:test-source] component contains the exception raised by the property, and the @racket[exn:fail:redex:test-term] component contains the term that induced the exception.} + @defform/subs[(check-reduction-relation relation property kw-args ...) ([kw-arg (code:line #:attempts attempts-expr) (code:line #:retries retries-expr) diff --git a/collects/redex/tests/gen-test.rkt b/collects/redex/tests/gen-test.rkt index 3983f848a6..a3a12c94a0 100644 --- a/collects/redex/tests/gen-test.rkt +++ b/collects/redex/tests/gen-test.rkt @@ -133,8 +133,7 @@ (test-equal (generate-term STLC #:satisfying - (lookup x ([x int] ([x (int → int)] •))) - (int → int) + (lookup x ([x int] ([x (int → int)] •))) = (int → int) 6) #f)) @@ -317,7 +316,7 @@ (void)])) (for ([_ 50]) - (define t (generate-term l #:satisfying (fltr n e) e_1 5)) + (define t (generate-term l #:satisfying (fltr n e) = e_1 5)) (match t [`((fltr ,n ,e) = ,e1) (test-equal (term (fltr ,n ,e)) e1)] @@ -332,9 +331,7 @@ [`((fltr ,n ,e) = ,e1) (test-equal (term (fltr ,n ,e)) e1)]) terms) - (void) - - ) + (void)) (let () @@ -360,30 +357,30 @@ [(is-a/b/c/d/e? e) T]) - (test-equal (generate-term L #:satisfying (is-a? a) any +inf.0) + (test-equal (generate-term L #:satisfying (is-a? a) = any +inf.0) '((is-a? a) = T)) - (test-equal (generate-term L #:satisfying (is-a? b) any +inf.0) + (test-equal (generate-term L #:satisfying (is-a? b) = any +inf.0) '((is-a? b) = F)) - (test-equal (generate-term L #:satisfying (is-a? c) any +inf.0) + (test-equal (generate-term L #:satisfying (is-a? c) = any +inf.0) '((is-a? c) = F)) - (test-equal (generate-term L #:satisfying (is-a/b? a) any +inf.0) + (test-equal (generate-term L #:satisfying (is-a/b? a) = any +inf.0) '((is-a/b? a) = T)) - (test-equal (generate-term L #:satisfying (is-a/b? b) any +inf.0) + (test-equal (generate-term L #:satisfying (is-a/b? b) = any +inf.0) '((is-a/b? b) = T)) - (test-equal (generate-term L #:satisfying (is-a/b? c) any +inf.0) + (test-equal (generate-term L #:satisfying (is-a/b? c) = any +inf.0) '((is-a/b? c) = F)) - (test-equal (generate-term L #:satisfying (is-a/b/c/d/e? a) any +inf.0) + (test-equal (generate-term L #:satisfying (is-a/b/c/d/e? a) = any +inf.0) '((is-a/b/c/d/e? a) = T)) - (test-equal (generate-term L #:satisfying (is-a/b/c/d/e? b) any +inf.0) + (test-equal (generate-term L #:satisfying (is-a/b/c/d/e? b) = any +inf.0) '((is-a/b/c/d/e? b) = T)) - (test-equal (generate-term L #:satisfying (is-a/b/c/d/e? c) any +inf.0) + (test-equal (generate-term L #:satisfying (is-a/b/c/d/e? c) = any +inf.0) '((is-a/b/c/d/e? c) = T)) - (test-equal (generate-term L #:satisfying (is-a/b/c/d/e? d) any +inf.0) + (test-equal (generate-term L #:satisfying (is-a/b/c/d/e? d) = any +inf.0) '((is-a/b/c/d/e? d) = T)) - (test-equal (generate-term L #:satisfying (is-a/b/c/d/e? e) any +inf.0) + (test-equal (generate-term L #:satisfying (is-a/b/c/d/e? e) = any +inf.0) '((is-a/b/c/d/e? e) = T)) - (test-equal (generate-term L #:satisfying (is-a/b/c/d/e? f) any +inf.0) + (test-equal (generate-term L #:satisfying (is-a/b/c/d/e? f) = any +inf.0) '((is-a/b/c/d/e? f) = F))) ;; errors for unsupprted pats @@ -394,7 +391,7 @@ (define-metafunction L [(f n) (g n)]) (test (with-handlers ((exn:fail? exn-message)) - (generate-term L #:satisfying (f any) any +inf.0) + (generate-term L #:satisfying (f any) = any +inf.0) "didn't raise an exception") #rx".*generate-term:.*side-condition.*")) (let () @@ -404,7 +401,7 @@ (define-metafunction L [(f n) (g n)]) (test (with-handlers ((exn:fail? exn-message)) - (generate-term L #:satisfying (f any) any +inf.0) + (generate-term L #:satisfying (f any) = any +inf.0) "didn't raise an exception") #rx".*generate-term:.*repeat.*")) @@ -441,7 +438,7 @@ (where q_3 (f q_2))]) (test (with-handlers ([exn:fail? exn-message]) - (generate-term L #:satisfying (f r_1) r_2 +inf.0)) + (generate-term L #:satisfying (f r_1) = r_2 +inf.0)) #rx".*generate-term:.*undatum.*")) @@ -451,7 +448,7 @@ [(n any) any]) (define-metafunction L [(f n) (n 1)]) - (test-equal (generate-term L #:satisfying (f any_1) any_2 +inf.0) + (test-equal (generate-term L #:satisfying (f any_1) = any_2 +inf.0) '((f 2) = (2 1)))) (let () @@ -460,7 +457,7 @@ [(n any) any]) (define-metafunction L [(f n) n]) - (test-equal (generate-term L #:satisfying (f any_1) any_2 +inf.0) + (test-equal (generate-term L #:satisfying (f any_1) = any_2 +inf.0) '((f 2) = 2))) (let () @@ -477,25 +474,25 @@ [(t n_1 n_2) 4]) - (test-equal (generate-term l #:satisfying (t 1 1) 1 +inf.0) + (test-equal (generate-term l #:satisfying (t 1 1) = 1 +inf.0) '((t 1 1) = 1)) - (test-equal (generate-term l #:satisfying (t 1 1) 2 +inf.0) + (test-equal (generate-term l #:satisfying (t 1 1) = 2 +inf.0) #f) - (test-equal (generate-term l #:satisfying (t 1 2) 2 +inf.0) + (test-equal (generate-term l #:satisfying (t 1 2) = 2 +inf.0) '((t 1 2) = 2)) - (test-equal (generate-term l #:satisfying (t 1 2) 3 +inf.0) + (test-equal (generate-term l #:satisfying (t 1 2) = 3 +inf.0) #f) - (test-equal (generate-term l #:satisfying (t 1 3) 3 +inf.0) + (test-equal (generate-term l #:satisfying (t 1 3) = 3 +inf.0) '((t 1 3) = 3)) - (test-equal (generate-term l #:satisfying (t 1 3) 4 +inf.0) + (test-equal (generate-term l #:satisfying (t 1 3) = 4 +inf.0) #f) - (test-equal (generate-term l #:satisfying (t 6 7) 4 +inf.0) + (test-equal (generate-term l #:satisfying (t 6 7) = 4 +inf.0) '((t 6 7) = 4)) - (test-equal (generate-term l #:satisfying (t 6 7) 3 +inf.0) + (test-equal (generate-term l #:satisfying (t 6 7) = 3 +inf.0) #f) - (test-equal (generate-term l #:satisfying (t 6 7) 2 +inf.0) + (test-equal (generate-term l #:satisfying (t 6 7) = 2 +inf.0) #f) - (test-equal (generate-term l #:satisfying (t 6 7) 1 +inf.0) + (test-equal (generate-term l #:satisfying (t 6 7) = 1 +inf.0) #f)) #; diff --git a/collects/redex/tests/rg-test.rkt b/collects/redex/tests/rg-test.rkt index 5615e98f5a..e322321d3b 100644 --- a/collects/redex/tests/rg-test.rkt +++ b/collects/redex/tests/rg-test.rkt @@ -1322,15 +1322,13 @@ (test (generate-term nats #:satisfying - (sum z z) - n + (sum z z) = n 5) '((sum z z) = z)) (test (generate-term nats #:satisfying - (sum (s z) (s z)) - n + (sum (s z) (s z)) = n 5) '((sum (s z) (s z)) = (s (s z))))) From 916046dacd965f0a73fc7f41cc8be249007cfd69 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 2 Nov 2012 07:16:55 -0500 Subject: [PATCH 117/221] don't run follow-log.rkt in drdr --- collects/meta/props | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/meta/props b/collects/meta/props index 718c307940..71eaafb24a 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -693,6 +693,7 @@ path/s is either such a string or a list of them. "collects/drracket/main.rkt" drdr:command-line (mzc *) "collects/drracket/private/dock-icon.rkt" drdr:command-line (raco "make" *) "collects/drracket/private/drracket-normal.rkt" drdr:command-line (mzc *) +"collects/drracket/private/follow-log.rkt" drdr:command-line (mzc *) "collects/drracket/private/launcher-mred-bootstrap.rkt" drdr:command-line (mzc *) "collects/drracket/private/launcher-mz-bootstrap.rkt" drdr:command-line (mzc *) "collects/drracket/private/stick-figures.rkt" drdr:command-line (mzc *) From b5205239509310fdafeb1eb851ce3c7e7df101fb Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 1 Nov 2012 14:40:08 -0600 Subject: [PATCH 118/221] change GC to specialize pairs a little more This change doesn't speed up anything, so far. GC performance of pairs (or anything) is determined almost completely by its size in bytes, and this change doesn't affect the size of pairs. At the same time, the change mostly replaces the obsolete "xtagged" support, and I might have a better idea that builds on this change, so I'm keeping it for now. --- src/racket/gc2/README | 9 ++- src/racket/gc2/backtrace.c | 18 ++--- src/racket/gc2/fnls.c | 13 +--- src/racket/gc2/gc2.h | 13 ---- src/racket/gc2/gc2_dump.h | 5 +- src/racket/gc2/newgc.c | 131 +++++++++++++++++++------------------ src/racket/src/jitalloc.c | 8 ++- src/racket/src/list.c | 13 +++- src/racket/src/salloc.c | 17 ++--- 9 files changed, 104 insertions(+), 123 deletions(-) diff --git a/src/racket/gc2/README b/src/racket/gc2/README index 44ffbb6a14..26e29964d6 100644 --- a/src/racket/gc2/README +++ b/src/racket/gc2/README @@ -103,9 +103,7 @@ Racket allocates the following kinds of memory objects: objects, the mark and fixup operations might be applied to all of them.) - * Xtagged - The object is somehow tagged, but not with a leading - `short'. Racket provides a single mark and fixup operation (no - size operation) for all xtagged objects. + * Pair - specialization of Tagged to pairs. * Interior Array - Like array objects, but pointers to the object can reference its interior, rather than just the start of the object, @@ -210,8 +208,9 @@ This function installs a finalizer to be queued for invocation when `p' would otherwise be collected. All ready finalizers should be called at the end of a collection. (A finalization can trigger calls back to the collector, but such a collection will not run more -finalizers.) The `p' argument must point to the beginning of a tagged -(if `tagged' is 1) or xtagged (if `tagged' is 0) object. +finalizers.) The `p' argument must normally point to the beginning of +a tagged (including atomic or pair) object; that is, `tagged' is +currently required to be non-zero. The `level' argument refers to an ordering of finalizers. It can be 1, 2, or 3. During a collection, level 1 finalizers are queued first, diff --git a/src/racket/gc2/backtrace.c b/src/racket/gc2/backtrace.c index 14a0b872bb..7edaa15fde 100644 --- a/src/racket/gc2/backtrace.c +++ b/src/racket/gc2/backtrace.c @@ -13,7 +13,7 @@ TRACE_PAGE_ARRAY TRACE_PAGE_TAGGED_ARRAY TRACE_PAGE_ATOMIC - TRACE_PAGE_XTAGGED + TRACE_PAGE_PAIR TRACE_PAGE_MALLOCFREE TRACE_PAGE_BAD trace_page_is_big @@ -39,7 +39,6 @@ static void register_traced_object(void *p) static void *print_out_pointer(const char *prefix, void *p, GC_get_type_name_proc get_type_name, - GC_get_xtagged_name_proc get_xtagged_name, GC_print_tagged_value_proc print_tagged_value) { trace_page_t *page; @@ -52,11 +51,12 @@ static void *print_out_pointer(const char *prefix, void *p, } p = trace_pointer_start(page, p); - if (trace_page_type(page) == TRACE_PAGE_TAGGED) { + if ((trace_page_type(page) == TRACE_PAGE_TAGGED) + || (trace_page_type(page) == TRACE_PAGE_PAIR)) { Type_Tag tag; tag = *(Type_Tag *)p; if ((tag >= 0) && get_type_name && get_type_name(tag)) { - print_tagged_value(prefix, p, 0, 0, 1000, "\n"); + print_tagged_value(prefix, p, 0, 1000, "\n"); } else { GCPRINT(GCOUTF, "%s<#%d> %p\n", prefix, tag, p); } @@ -67,11 +67,6 @@ static void *print_out_pointer(const char *prefix, void *p, what = "TARRAY"; } else if (trace_page_type(page) == TRACE_PAGE_ATOMIC) { what = "ATOMIC"; - } else if (trace_page_type(page) == TRACE_PAGE_XTAGGED) { - if (get_xtagged_name) - what = get_xtagged_name(p); - else - what = "XTAGGED"; } else if (trace_page_type(page) == TRACE_PAGE_MALLOCFREE) { what = "MALLOCED"; } else { @@ -90,7 +85,6 @@ static void *print_out_pointer(const char *prefix, void *p, static void print_traced_objects(int path_length_limit, GC_get_type_name_proc get_type_name, - GC_get_xtagged_name_proc get_xtagged_name, GC_print_tagged_value_proc print_tagged_value) { int i, j, k, dp = 0, counter, each; @@ -105,7 +99,7 @@ static void print_traced_objects(int path_length_limit, void *p; int limit = path_length_limit; p = found_objects[i]; - p = print_out_pointer("==* ", p, get_type_name, get_xtagged_name, print_tagged_value); + p = print_out_pointer("==* ", p, get_type_name, print_tagged_value); j = 0; counter = 0; each = 1; while (p && limit) { @@ -127,7 +121,7 @@ static void print_traced_objects(int path_length_limit, counter = 0; } } - p = print_out_pointer(" <- ", p, get_type_name, get_xtagged_name, print_tagged_value); + p = print_out_pointer(" <- ", p, get_type_name, print_tagged_value); limit--; } } diff --git a/src/racket/gc2/fnls.c b/src/racket/gc2/fnls.c index 0c07abc99e..8dc8102480 100644 --- a/src/racket/gc2/fnls.c +++ b/src/racket/gc2/fnls.c @@ -92,21 +92,12 @@ void GC_set_finalizer(void *p, int tagged, int level, void (*f)(void *p, void *d m = find_page(p); if (tagged) { - if (m->type != MTYPE_TAGGED) { + if ((m->type != MTYPE_TAGGED) + || (m->type != MTYPE_PAIR)) { GCPRINT(GCOUTF, "Not tagged: %lx (%d)\n", (intptr_t)p, m->type); CRASH(4); } - } else { - if (m->type != MTYPE_XTAGGED) { - GCPRINT(GCOUTF, "Not xtagged: %lx (%d)\n", - (intptr_t)p, m->type); - CRASH(5); - } - if (m->flags & MFLAG_BIGBLOCK) - fnl->size = m->u.size; - else - fnl->size = ((intptr_t *)p)[-1]; } } #endif diff --git a/src/racket/gc2/gc2.h b/src/racket/gc2/gc2.h index 64ff37fa1e..4139bb6b1f 100644 --- a/src/racket/gc2/gc2.h +++ b/src/racket/gc2/gc2.h @@ -203,19 +203,6 @@ GC2_EXTERN void *GC_malloc_pair(void *car, void *cdr); The main potential advantage is that `car' and `cdr' don't have to be retained by the callee in the case of a GC. */ -GC2_EXTERN void *GC_malloc_one_xtagged(size_t); -/* - Alloc an item, initially zeroed. Rather than having a specific tag, - all objects allocated this way are marked/fixedup via the function - in GC_mark_xtagged and GC_fixup_xtagged. Racket sets - GC_{mark,fixup}_xtagged. */ - -GC2_EXTERN void (*GC_mark_xtagged)(void *obj); -GC2_EXTERN void (*GC_fixup_xtagged)(void *obj); -/* - Mark and fixup functions for memory allocated with - GC_malloc_one_xtagged(). */ - GC2_EXTERN void *GC_malloc_array_tagged(size_t); /* Alloc an array of tagged items. Racket sets the tag in the first diff --git a/src/racket/gc2/gc2_dump.h b/src/racket/gc2/gc2_dump.h index d5f92bc846..a6260055f8 100644 --- a/src/racket/gc2/gc2_dump.h +++ b/src/racket/gc2/gc2_dump.h @@ -5,17 +5,15 @@ #define __mzscheme_gc_2_dump__ typedef char *(*GC_get_type_name_proc)(short t); -typedef char *(*GC_get_xtagged_name_proc)(void *p); typedef void (*GC_for_each_found_proc)(void *p); typedef void (*GC_for_each_struct_proc)(void *p); typedef void (*GC_print_tagged_value_proc)(const char *prefix, - void *v, int xtagged, uintptr_t diff, int max_w, + void *v, uintptr_t diff, int max_w, const char *suffix); GC2_EXTERN void GC_dump_with_traces(int flags, GC_get_type_name_proc get_type_name, - GC_get_xtagged_name_proc get_xtagged_name, GC_for_each_found_proc for_each_found, short min_trace_for_tag, short max_trace_for_tag, GC_print_tagged_value_proc print_tagged_value, @@ -27,7 +25,6 @@ GC2_EXTERN void GC_dump_variable_stack(void **var_stack, void *limit, void *stack_mem, GC_get_type_name_proc get_type_name, - GC_get_xtagged_name_proc get_xtagged_name, GC_print_tagged_value_proc print_tagged_value); # define GC_DUMP_SHOW_DETAILS 0x1 diff --git a/src/racket/gc2/newgc.c b/src/racket/gc2/newgc.c index d11f2c884c..f2778db83c 100644 --- a/src/racket/gc2/newgc.c +++ b/src/racket/gc2/newgc.c @@ -93,7 +93,7 @@ enum { PAGE_ATOMIC = 1, PAGE_ARRAY = 2, PAGE_TARRAY = 3, - PAGE_XTAGGED = 4, + PAGE_PAIR = 4, PAGE_BIG = 5, /* the number of page types. */ PAGE_TYPES = 6, @@ -128,7 +128,7 @@ static const char *type_name[PAGE_TYPES] = { "atomic", "array", "tagged array", - "xtagged", + "pair", "big" }; @@ -276,8 +276,6 @@ MAYBE_UNUSED static void GCVERBOSEprintf(NewGC *gc, const char *fmt, ...) { /* the externals */ void (*GC_out_of_memory)(void); void (*GC_report_out_of_memory)(void); -void (*GC_mark_xtagged)(void *obj); -void (*GC_fixup_xtagged)(void *obj); GC_collect_start_callback_Proc GC_set_collect_start_callback(GC_collect_start_callback_Proc func) { NewGC *gc = GC_get_GC(); @@ -632,8 +630,8 @@ static void dump_page_map(NewGC *gc, const char *when) case PAGE_TARRAY: kind = 'y'; break; - case PAGE_XTAGGED: - kind = 'x'; + case PAGE_PAIR: + kind = 'p'; break; default: kind = '?'; @@ -1377,7 +1375,7 @@ void *GC_malloc_pair(void *car, void *cdr) NewGC *gc = GC_get_GC(); gc->park[0] = car; gc->park[1] = cdr; - pair = GC_malloc_one_tagged(sizeof(Scheme_Simple_Object)); + pair = allocate(sizeof(Scheme_Simple_Object), PAGE_PAIR); car = gc->park[0]; cdr = gc->park[1]; gc->park[0] = NULL; @@ -1393,7 +1391,7 @@ void *GC_malloc_pair(void *car, void *cdr) memset(info, 0, sizeof(objhead)); /* init objhead */ - /* info->type = type; */ /* We know that the type field is already 0 */ + info->type = PAGE_PAIR; info->size = BYTES_MULTIPLE_OF_WORD_TO_WORDS(allocate_size); /* ALIGN_BYTES_SIZE bumbed us up to the next word boundary */ pair = OBJHEAD_TO_OBJPTR(info); @@ -1405,7 +1403,7 @@ void *GC_malloc_pair(void *car, void *cdr) { Scheme_Simple_Object *obj = (Scheme_Simple_Object *) pair; obj->iso.so.type = scheme_pair_type; - obj->iso.so.keyex = 0; /* init first word of SchemeObject to 0 */ + obj->iso.so.keyex = 0; /* init first word of Scheme_Object to 0 */ obj->u.pair_val.car = car; obj->u.pair_val.cdr = cdr; } @@ -1416,7 +1414,6 @@ void *GC_malloc_pair(void *car, void *cdr) /* the allocation mechanism we present to the outside world */ void *GC_malloc(size_t s) { return allocate(s, PAGE_ARRAY); } void *GC_malloc_one_tagged(size_t s) { return allocate(s, PAGE_TAGGED); } -void *GC_malloc_one_xtagged(size_t s) { return allocate(s, PAGE_XTAGGED); } void *GC_malloc_array_tagged(size_t s) { return allocate(s, PAGE_TARRAY); } void *GC_malloc_atomic(size_t s) { return allocate(s, PAGE_ATOMIC); } void *GC_malloc_atomic_uncollectable(size_t s) { return ofm_malloc_zero(s); } @@ -1432,7 +1429,7 @@ intptr_t GC_compute_alloc_size(intptr_t sizeb) return COMPUTE_ALLOC_SIZE_FOR_OBJECT_SIZE(sizeb); } -intptr_t GC_initial_word(int request_size) +static intptr_t initial_word(int request_size, int type) { intptr_t w = 0; objhead info; @@ -1440,6 +1437,7 @@ intptr_t GC_initial_word(int request_size) const size_t allocate_size = COMPUTE_ALLOC_SIZE_FOR_OBJECT_SIZE(request_size); memset(&info, 0, sizeof(objhead)); + info.type = type; info.size = BYTES_MULTIPLE_OF_WORD_TO_WORDS(allocate_size); /* ALIGN_BYTES_SIZE bumped us up to the next word boundary */ memcpy(&w, &info, sizeof(objhead)); @@ -1447,21 +1445,19 @@ intptr_t GC_initial_word(int request_size) return w; } +intptr_t GC_initial_word(int request_size) +{ + return initial_word(request_size, PAGE_TAGGED); +} + +intptr_t GC_pair_initial_word(int request_size) +{ + return initial_word(request_size, PAGE_PAIR); +} + intptr_t GC_array_initial_word(int request_size) { - intptr_t w = 0; - objhead info; - - const size_t allocate_size = COMPUTE_ALLOC_SIZE_FOR_OBJECT_SIZE(request_size); - - memset(&info, 0, sizeof(objhead)); - info.type = PAGE_ARRAY; - - info.size = BYTES_MULTIPLE_OF_WORD_TO_WORDS(allocate_size); /* ALIGN_BYTES_SIZE bumped us up to the next word boundary */ - - memcpy(&w, &info, sizeof(objhead)); - - return w; + return initial_word(request_size, PAGE_ARRAY); } intptr_t GC_alloc_alignment() @@ -3277,8 +3273,13 @@ static inline void propagate_marks_worker(NewGC *gc, Mark2_Proc *mark_table, voi } break; } - case PAGE_XTAGGED: - GC_mark_xtagged(start); break; + case PAGE_PAIR: + { + Scheme_Object *p = (Scheme_Object *)start; + GC_mark2(SCHEME_CAR(p), gc); + GC_mark2(SCHEME_CDR(p), gc); + } + break; } } @@ -3400,7 +3401,7 @@ static void *trace_pointer_start(mpage *page, void *p) { # define TRACE_PAGE_ARRAY PAGE_ARRAY # define TRACE_PAGE_TAGGED_ARRAY PAGE_TARRAY # define TRACE_PAGE_ATOMIC PAGE_ATOMIC -# define TRACE_PAGE_XTAGGED PAGE_XTAGGED +# define TRACE_PAGE_PAIR PAGE_PAIR # define TRACE_PAGE_MALLOCFREE PAGE_TYPES # define TRACE_PAGE_BAD PAGE_TYPES # define trace_page_is_big(page) (page)->size_class @@ -3409,14 +3410,13 @@ static void *trace_pointer_start(mpage *page, void *p) { #else # define reset_object_traces() /* */ # define register_traced_object(p) /* */ -# define print_traced_objects(x, y, q, z) /* */ +# define print_traced_objects(x, q, z) /* */ #endif #define MAX_DUMP_TAG 256 void GC_dump_with_traces(int flags, GC_get_type_name_proc get_type_name, - GC_get_xtagged_name_proc get_xtagged_name, GC_for_each_found_proc for_each_found, short min_trace_for_tag, short max_trace_for_tag, GC_print_tagged_value_proc print_tagged_value, @@ -3437,30 +3437,32 @@ void GC_dump_with_traces(int flags, for (i = 0; i < MAX_DUMP_TAG; i++) { counts[i] = sizes[i] = 0; } - for (page = gc->gen1_pages[PAGE_TAGGED]; page; page = page->next) { - void **start = PAGE_START_VSS(page); - void **end = PAGE_END_VSS(page); + for (i = 0; i < 2; i++) { + for (page = gc->gen1_pages[!i ? PAGE_TAGGED : PAGE_PAIR]; page; page = page->next) { + void **start = PAGE_START_VSS(page); + void **end = PAGE_END_VSS(page); - while(start < end) { - objhead *info = (objhead *)start; - if(!info->dead) { - void *obj_start = OBJHEAD_TO_OBJPTR(start); - unsigned short tag = *(unsigned short *)obj_start; - ASSERT_TAG(tag); - if (tag < MAX_DUMP_TAG) { - counts[tag]++; - sizes[tag] += info->size; - } - if ((tag == scheme_proc_struct_type) || (tag == scheme_structure_type)) { - if (for_each_struct) for_each_struct(obj_start); - } - if ((tag >= min_trace_for_tag) && (tag <= max_trace_for_tag)) { - register_traced_object(obj_start); - if (for_each_found) - for_each_found(obj_start); + while(start < end) { + objhead *info = (objhead *)start; + if(!info->dead) { + void *obj_start = OBJHEAD_TO_OBJPTR(start); + unsigned short tag = *(unsigned short *)obj_start; + ASSERT_TAG(tag); + if (tag < MAX_DUMP_TAG) { + counts[tag]++; + sizes[tag] += info->size; + } + if ((tag == scheme_proc_struct_type) || (tag == scheme_structure_type)) { + if (for_each_struct) for_each_struct(obj_start); + } + if ((tag >= min_trace_for_tag) && (tag <= max_trace_for_tag)) { + register_traced_object(obj_start); + if (for_each_found) + for_each_found(obj_start); + } } + start += info->size; } - start += info->size; } } for (page = gc->gen1_pages[PAGE_BIG]; page; page = page->next) { @@ -3586,7 +3588,7 @@ void GC_dump_with_traces(int flags, GCWARN((GCOUTF,"# of immobile boxes: %i\n", num_immobiles)); if (flags & GC_DUMP_SHOW_TRACE) { - print_traced_objects(path_length_limit, get_type_name, get_xtagged_name, print_tagged_value); + print_traced_objects(path_length_limit, get_type_name, print_tagged_value); } if (for_each_found) @@ -3595,7 +3597,7 @@ void GC_dump_with_traces(int flags, void GC_dump(void) { - GC_dump_with_traces(0, NULL, NULL, NULL, 0, -1, NULL, 0, NULL); + GC_dump_with_traces(0, NULL, NULL, 0, -1, NULL, 0, NULL); } #ifdef MZ_GC_BACKTRACE @@ -3611,7 +3613,8 @@ int GC_is_tagged(void *p) page = pagemap_find_page(MASTERGC->page_maps, p); } #endif - return page && (page->page_type == PAGE_TAGGED); + return page && ((page->page_type == PAGE_TAGGED) + || (page->page_type == PAGE_PAIR)); } int GC_is_tagged_start(void *p) @@ -3974,8 +3977,12 @@ static void repair_heap(NewGC *gc) case PAGE_ARRAY: while(start < end) gcFIXUP2(*(start++), gc); break; - case PAGE_XTAGGED: - GC_fixup_xtagged(start); + case PAGE_PAIR: + { + Scheme_Object *p = (Scheme_Object *)start; + gcFIXUP2(SCHEME_CAR(p), gc); + gcFIXUP2(SCHEME_CDR(p), gc); + } break; case PAGE_TARRAY: { unsigned short tag = *(unsigned short *)start; @@ -4074,11 +4081,13 @@ static void repair_heap(NewGC *gc) } } break; - case PAGE_XTAGGED: + case PAGE_PAIR: while(start < end) { objhead *info = (objhead *)start; if(info->mark) { - GC_fixup_xtagged(OBJHEAD_TO_OBJPTR(start)); + Scheme_Object *p = (Scheme_Object *)OBJHEAD_TO_OBJPTR(start); + gcFIXUP2(SCHEME_CAR(p), gc); + gcFIXUP2(SCHEME_CDR(p), gc); info->mark = 0; } else { info->dead = 1; @@ -4086,8 +4095,9 @@ static void repair_heap(NewGC *gc) killing_debug(gc, page, info); #endif } - start += info->size; + start += PAIR_SIZE_IN_BYTES >> LOG_WORD_SIZE; } + break; } } } else GCDEBUG((DEBUGOUTF,"Not Cleaning page %p\n", page)); @@ -4759,13 +4769,12 @@ intptr_t GC_propagate_hierarchy_memory_use() #if MZ_GC_BACKTRACE static GC_get_type_name_proc stack_get_type_name; -static GC_get_xtagged_name_proc stack_get_xtagged_name; static GC_print_tagged_value_proc stack_print_tagged_value; static void dump_stack_pos(void *a) { GCPRINT(GCOUTF, " @%p: ", a); - print_out_pointer("", *(void **)a, stack_get_type_name, stack_get_xtagged_name, stack_print_tagged_value); + print_out_pointer("", *(void **)a, stack_get_type_name, stack_print_tagged_value); } # define GC_X_variable_stack GC_do_dump_variable_stack @@ -4781,11 +4790,9 @@ void GC_dump_variable_stack(void **var_stack, void *limit, void *stack_mem, GC_get_type_name_proc get_type_name, - GC_get_xtagged_name_proc get_xtagged_name, GC_print_tagged_value_proc print_tagged_value) { stack_get_type_name = get_type_name; - stack_get_xtagged_name = get_xtagged_name; stack_print_tagged_value = print_tagged_value; GC_do_dump_variable_stack(var_stack, delta, limit, stack_mem, GC_get_GC()); } diff --git a/src/racket/src/jitalloc.c b/src/racket/src/jitalloc.c index 29590f6c20..c3dda0ddc1 100644 --- a/src/racket/src/jitalloc.c +++ b/src/racket/src/jitalloc.c @@ -35,6 +35,7 @@ #ifdef CAN_INLINE_ALLOC THREAD_LOCAL_DECL(extern uintptr_t GC_gen0_alloc_page_ptr); intptr_t GC_initial_word(int sizeb); +intptr_t GC_pair_initial_word(int sizeb); intptr_t GC_array_initial_word(int sizeb); intptr_t GC_compute_alloc_size(intptr_t sizeb); @@ -153,7 +154,12 @@ int scheme_inline_alloc(mz_jit_state *jitter, int amt, Scheme_Type ty, int immut /* GC header: */ if (ty >= 0) { - a_word = GC_initial_word(amt); + if ((ty == scheme_pair_type) + || (ty == scheme_mutable_pair_type) + || (ty == scheme_raw_pair_type)) + a_word = GC_pair_initial_word(amt); + else + a_word = GC_initial_word(amt); jit_movi_l(JIT_R2, a_word); jit_str_l(JIT_V1, JIT_R2); diff --git a/src/racket/src/list.c b/src/racket/src/list.c index f0ce69936d..ffc4edc0e7 100644 --- a/src/racket/src/list.c +++ b/src/racket/src/list.c @@ -821,10 +821,14 @@ Scheme_Object *scheme_make_pair(Scheme_Object *car, Scheme_Object *cdr) Scheme_Object *scheme_make_mutable_pair(Scheme_Object *car, Scheme_Object *cdr) { Scheme_Object *cons; +#ifdef MZ_PRECISE_GC + cons = GC_malloc_pair(car, cdr); +#else cons = scheme_alloc_object(); - cons->type = scheme_mutable_pair_type; SCHEME_CAR(cons) = car; SCHEME_CDR(cons) = cdr; +#endif + cons->type = scheme_mutable_pair_type; return cons; } @@ -836,10 +840,15 @@ Scheme_Object *scheme_make_raw_pair(Scheme_Object *car, Scheme_Object *cdr) tools expect pairs to always contain tagged values. A raw pair contains arbitrary pointers. */ +#ifdef MZ_PRECISE_GC + cons = GC_malloc_pair(car, cdr); +#else cons = scheme_alloc_object(); - cons->type = scheme_raw_pair_type; SCHEME_CAR(cons) = car; SCHEME_CDR(cons) = cdr; +#endif + + cons->type = scheme_raw_pair_type; return cons; } diff --git a/src/racket/src/salloc.c b/src/racket/src/salloc.c index 7b26cae3c7..b2ba46f2e5 100644 --- a/src/racket/src/salloc.c +++ b/src/racket/src/salloc.c @@ -1882,7 +1882,6 @@ static void count_managed(Scheme_Custodian *m, int *c, int *a, int *u, int *t, #endif #if MZ_PRECISE_GC_TRACE -char *(*GC_get_xtagged_name)(void *p) = NULL; static Scheme_Object *cons_accum_result; static void cons_onto_list(void *p) { @@ -1928,7 +1927,7 @@ static int check_home(Scheme_Object *o) } static void print_tagged_value(const char *prefix, - void *v, int xtagged, uintptr_t diff, int max_w, + void *v, uintptr_t diff, int max_w, const char *suffix) { char buffer[256]; @@ -1940,7 +1939,7 @@ static void print_tagged_value(const char *prefix, scheme_check_print_is_obj = check_home; - if (!xtagged) { + { if (SCHEME_TYPE(v) > _scheme_compiled_values_types_) { sprintf(hashstr, "{%" PRIdPTR "}", scheme_hash_key(v)); hash_code = hashstr; @@ -2112,13 +2111,8 @@ static void print_tagged_value(const char *prefix, } sep = "="; - } else if (scheme_external_dump_type) { - type = scheme_external_dump_type(v); - if (*type) - sep = ":"; - } else - type = ""; - + } + if (diff) sprintf(diffstr, "%lx", diff); @@ -2160,7 +2154,6 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[]) # define path_length_limit 10000 # define for_each_found NULL # define for_each_struct NULL -# define GC_get_xtagged_name NULL # define print_tagged_value NULL # endif #endif @@ -2508,7 +2501,6 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[]) } GC_dump_variable_stack(var_stack, delta, limit, NULL, scheme_get_type_name_or_null, - GC_get_xtagged_name, print_tagged_value); } else { scheme_console_printf(" done\n"); @@ -2532,7 +2524,6 @@ Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[]) # ifdef MZ_PRECISE_GC GC_dump_with_traces(flags, scheme_get_type_name_or_null, - GC_get_xtagged_name, for_each_found, trace_for_tag, trace_for_tag, print_tagged_value, From 008f476210498537dc4e6812b154aadb9cf4e864 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 2 Nov 2012 06:51:20 -0600 Subject: [PATCH 119/221] Scribble PDF/Latex: Hangul support --- collects/scribble/latex-render.rkt | 56 ++++++++++++++++-------------- collects/scribble/scribble.tex | 3 +- 2 files changed, 32 insertions(+), 27 deletions(-) diff --git a/collects/scribble/latex-render.rkt b/collects/scribble/latex-render.rkt index 8d542a02b4..082a7e54c1 100644 --- a/collects/scribble/latex-render.rkt +++ b/collects/scribble/latex-render.rkt @@ -966,33 +966,37 @@ [(#\u207a) "$^+$"] [(#\u207b) "$^-$"] [else - ;; Detect characters that can be formed with combining characters - ;; and translate them to Latex combinations: - (define s (string-normalize-nfd (string c))) - (define len (string-length s)) (cond - [(len . > . 1) - (define combiner (case (string-ref s (sub1 len)) - [(#\u300) "\\`{~a}"] - [(#\u301) "\\'{~a}"] - [(#\u302) "\\^{~a}"] - [(#\u303) "\\~~{~a}"] - [(#\u304) "\\={~a}"] - [(#\u306) "\\u{~a}"] - [(#\u307) "\\.{~a}"] - [(#\u308) "\\\"{~a}"] - [(#\u30a) "\\r{~a}"] - [(#\u30b) "\\H{~a}"] - [(#\u30c) "\\v{~a}"] - [(#\u327) "\\c{~a}"] - [(#\u328) "\\k{~a}"] - [else #f])) - (define base (string-normalize-nfc (substring s 0 (sub1 len)))) - (if (and combiner - (= 1 (string-length base))) - (format combiner (char-loop (string-ref base 0))) - c)] - [else c])]) + [(char<=? #\uAC00 c #\uD7AF) ; Korean Hangul + (format "\\begin{CJK}{UTF8}{mj}~a\\end{CJK}" c)] + [else + ;; Detect characters that can be formed with combining characters + ;; and translate them to Latex combinations: + (define s (string-normalize-nfd (string c))) + (define len (string-length s)) + (cond + [(len . > . 1) + (define combiner (case (string-ref s (sub1 len)) + [(#\u300) "\\`{~a}"] + [(#\u301) "\\'{~a}"] + [(#\u302) "\\^{~a}"] + [(#\u303) "\\~~{~a}"] + [(#\u304) "\\={~a}"] + [(#\u306) "\\u{~a}"] + [(#\u307) "\\.{~a}"] + [(#\u308) "\\\"{~a}"] + [(#\u30a) "\\r{~a}"] + [(#\u30b) "\\H{~a}"] + [(#\u30c) "\\v{~a}"] + [(#\u327) "\\c{~a}"] + [(#\u328) "\\k{~a}"] + [else #f])) + (define base (string-normalize-nfc (substring s 0 (sub1 len)))) + (if (and combiner + (= 1 (string-length base))) + (format combiner (char-loop (string-ref base 0))) + c)] + [else c])])]) c)]))) (loop (add1 i))))))) diff --git a/collects/scribble/scribble.tex b/collects/scribble/scribble.tex index 29a3bd43ea..e897e143af 100644 --- a/collects/scribble/scribble.tex +++ b/collects/scribble/scribble.tex @@ -11,7 +11,8 @@ \usepackage[htt]{hyphenat} \usepackage[usenames,dvipsnames]{color} \hypersetup{bookmarks=true,bookmarksopen=true,bookmarksnumbered=true} -\IfFileExists{tocstyle.sty}{\usepackage{tocstyle}\usetocstyle{standard}} +\IfFileExists{tocstyle.sty}{\usepackage{tocstyle}\usetocstyle{standard}}{} +\IfFileExists{CJK.sty}{\usepackage{CJK}}{} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Configuration that is especially meant to be overridden: From 3ca7300a0dd8fde68bf551c587f911f4116034e2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 2 Nov 2012 06:51:35 -0600 Subject: [PATCH 120/221] improvements to GC backtrace info --- src/racket/gc2/backtrace.c | 12 +++++++----- src/racket/gc2/newgc.c | 19 +++++++++++++++++-- 2 files changed, 24 insertions(+), 7 deletions(-) diff --git a/src/racket/gc2/backtrace.c b/src/racket/gc2/backtrace.c index 7edaa15fde..dab7299429 100644 --- a/src/racket/gc2/backtrace.c +++ b/src/racket/gc2/backtrace.c @@ -39,14 +39,15 @@ static void register_traced_object(void *p) static void *print_out_pointer(const char *prefix, void *p, GC_get_type_name_proc get_type_name, - GC_print_tagged_value_proc print_tagged_value) + GC_print_tagged_value_proc print_tagged_value, + int *_kind) { trace_page_t *page; const char *what; page = pagemap_find_page(GC_instance->page_maps, p); if (!page || (trace_page_type(page) == TRACE_PAGE_BAD)) { - GCPRINT(GCOUTF, "%s??? %p\n", prefix, p); + GCPRINT(GCOUTF, "%s%s %p %p\n", prefix, trace_source_kind(*_kind), p); return NULL; } p = trace_pointer_start(page, p); @@ -80,7 +81,7 @@ static void *print_out_pointer(const char *prefix, void *p, p); } - return trace_backpointer(page, p); + return trace_backpointer(page, p, _kind); } static void print_traced_objects(int path_length_limit, @@ -98,8 +99,9 @@ static void print_traced_objects(int path_length_limit, for (i = 0; i < found_object_count; i++) { void *p; int limit = path_length_limit; + int kind = 0; p = found_objects[i]; - p = print_out_pointer("==* ", p, get_type_name, print_tagged_value); + p = print_out_pointer("==* ", p, get_type_name, print_tagged_value, &kind); j = 0; counter = 0; each = 1; while (p && limit) { @@ -121,7 +123,7 @@ static void print_traced_objects(int path_length_limit, counter = 0; } } - p = print_out_pointer(" <- ", p, get_type_name, print_tagged_value); + p = print_out_pointer(" <- ", p, get_type_name, print_tagged_value, &kind); limit--; } } diff --git a/src/racket/gc2/newgc.c b/src/racket/gc2/newgc.c index f2778db83c..b4abf7009d 100644 --- a/src/racket/gc2/newgc.c +++ b/src/racket/gc2/newgc.c @@ -1939,13 +1939,14 @@ static void copy_backtrace_source(mpage *to_page, void *to_ptr, to_page->backtrace[to_delta+1] = from_page->backtrace[from_delta+1]; } -static void *get_backtrace(mpage *page, void *ptr) +static void *get_backtrace(mpage *page, void *ptr, int *kind) /* ptr is after objhead */ { uintptr_t delta; if (!page->backtrace) { /* This shouldn't happen, but fail more gracefully if it does. */ + *kind = -1; return NULL; } @@ -1957,6 +1958,8 @@ static void *get_backtrace(mpage *page, void *ptr) } delta = PPTR(ptr) - PPTR(page->addr); + *kind = ((intptr_t *)page->backtrace)[delta]; + return page->backtrace[delta - 1]; } @@ -3406,6 +3409,17 @@ static void *trace_pointer_start(mpage *page, void *p) { # define TRACE_PAGE_BAD PAGE_TYPES # define trace_page_is_big(page) (page)->size_class # define trace_backpointer get_backtrace +const char *trace_source_kind(int kind) +{ + switch (kind) { + case BT_STACK: return "STACK"; + case BT_ROOT: return "ROOT"; + case BT_FINALIZER: return "FINALIZER"; + case BT_WEAKLINK: return "WEAK-LINK"; + case BT_IMMOBILE: return "IMMOBILE"; + default: return "???"; + } +} # include "backtrace.c" #else # define reset_object_traces() /* */ @@ -4773,8 +4787,9 @@ static GC_print_tagged_value_proc stack_print_tagged_value; static void dump_stack_pos(void *a) { + int kind = 0; GCPRINT(GCOUTF, " @%p: ", a); - print_out_pointer("", *(void **)a, stack_get_type_name, stack_print_tagged_value); + print_out_pointer("", *(void **)a, stack_get_type_name, stack_print_tagged_value, &kind); } # define GC_X_variable_stack GC_do_dump_variable_stack From a830f77403a1f51de7359c7946b01ef10d401cee Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 2 Nov 2012 07:39:33 -0600 Subject: [PATCH 121/221] scribble: more control over version formatting Add "Version" in front of a version name via `.version:before' or `.versionNoNav:before' and `\SVersionBefore', so that they can be configured through overriding CSS or Latex macro declarations. Also, improve the documentation for how the `#:version' argument of `title' is propagated to a `part' style property. Closes PR 13227 --- collects/scribble/html-render.rkt | 2 +- collects/scribble/scribble.css | 4 ++++ collects/scribble/scribble.tex | 5 +++-- collects/scribblings/scribble/core.scrbl | 7 ++++++- collects/scribblings/scribble/decode.scrbl | 10 ++++++---- 5 files changed, 20 insertions(+), 8 deletions(-) diff --git a/collects/scribble/html-render.rkt b/collects/scribble/html-render.rkt index e8f8ad4d4b..016fb29d55 100644 --- a/collects/scribble/html-render.rkt +++ b/collects/scribble/html-render.rkt @@ -890,7 +890,7 @@ (list (make-element (if (include-navigation?) "version" "versionNoNav") - (list "Version: " v))) + v)) d ri)))))) diff --git a/collects/scribble/scribble.css b/collects/scribble/scribble.css index 7f502cba51..d521d28f30 100644 --- a/collects/scribble/scribble.css +++ b/collects/scribble/scribble.css @@ -154,6 +154,10 @@ table td { font-size: xx-small; /* avoid overlap with author */ } +.version:before, .versionNoNav:before { + content: "Version "; +} + /* ---------------------------------------- */ /* Margin notes */ diff --git a/collects/scribble/scribble.tex b/collects/scribble/scribble.tex index e897e143af..b7ec1d8629 100644 --- a/collects/scribble/scribble.tex +++ b/collects/scribble/scribble.tex @@ -141,12 +141,13 @@ \newenvironment{refcolumnleft}{\begin{refcolumn}}{\end{refcolumn}} % Macros used by `title' and `author': -\newcommand{\titleAndVersionAndAuthors}[3]{\title{#1\\{\normalsize Version #2}}\author{#3}\maketitle} -\newcommand{\titleAndVersionAndEmptyAuthors}[3]{\title{#1\\{\normalsize Version #2}}#3\maketitle} +\newcommand{\titleAndVersionAndAuthors}[3]{\title{#1\\{\normalsize \SVersionBefore{}#2}}\author{#3}\maketitle} +\newcommand{\titleAndVersionAndEmptyAuthors}[3]{\title{#1\\{\normalsize \SVersionBefore{}#2}}#3\maketitle} \newcommand{\titleAndEmptyVersionAndAuthors}[3]{\title{#1}\author{#3}\maketitle} \newcommand{\titleAndEmptyVersionAndEmptyAuthors}[3]{\title{#1}\maketitle} \newcommand{\SAuthor}[1]{#1} \newcommand{\SAuthorSep}[1]{\qquad} +\newcommand{\SVersionBefore}[1]{Version } % Useful for some styles, such as sigalternate: \newcommand{\SNumberOfAuthors}[1]{} diff --git a/collects/scribblings/scribble/core.scrbl b/collects/scribblings/scribble/core.scrbl index 71cda87166..7ded2d58f6 100644 --- a/collects/scribblings/scribble/core.scrbl +++ b/collects/scribblings/scribble/core.scrbl @@ -400,7 +400,12 @@ The recognized @tech{style properties} are as follows: not @racket[""] may be used when rendering a document; at a minimum, a non-@racket[""] version is rendered when it is attached to a part representing the whole document. The default - version for a document is @racket[(version)].} + version for a document is @racket[(version)]. In rendered form, + the version is normally prefixed with the word ``Version,'' but + this formatting can be controlled by overriding + @tt{.version:before} and/or @tt{.versionNoNav:before} in CSS + for HTML rendering or by redefining the @tt{\SVersionBefore} + macro for Latex rendering (see @secref["config"]).} @item{@racket[document-date] structure --- A date for the part, normally used on a document's main part for for Latex diff --git a/collects/scribblings/scribble/decode.scrbl b/collects/scribblings/scribble/decode.scrbl index 25e9cfaf21..2b51d32fe0 100644 --- a/collects/scribblings/scribble/decode.scrbl +++ b/collects/scribblings/scribble/decode.scrbl @@ -168,18 +168,20 @@ otherwise.} @defstruct[title-decl ([tag-prefix (or/c #f string?)] [tags (listof string?)] [version (or/c string? #f)] - [style any/c] + [style style?] [content content?])]{ -See @racket[decode] and @racket[decode-part]. The @racket[_tag-prefix] -and @racket[_style] fields are propagated to the resulting +See @racket[decode] and @racket[decode-part]. The @racket[tag-prefix] +and @racketidfont{style} fields are propagated to the resulting +@racket[part]. If the @racketidfont{version} field is not @racket[#f], +it is propagated as a @racket[document-version] style property on the @racket[part].} @defstruct[part-start ([depth integer?] [tag-prefix (or/c #f string?)] [tags (listof string?)] - [style any/c] + [style style?] [title content?])]{ Like @racket[title-decl], but for a sub-part. See @racket[decode] and From 6c760b086fc87163bf3c7086c16efbe845a9b08b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 2 Nov 2012 08:16:08 -0500 Subject: [PATCH 122/221] reindent the implementation of open-input-text-editor Apologies for the gratuitious reindent, but I was having a lot of trouble reading this file; it appears to have last been worked on in an Emacs that used tabs for indentation and doesn't use the same tab width as drracket. --- collects/mred/private/snipfile.rkt | 220 ++++++++++++++--------------- 1 file changed, 110 insertions(+), 110 deletions(-) diff --git a/collects/mred/private/snipfile.rkt b/collects/mred/private/snipfile.rkt index 8f4c91ee71..831dd5ea3d 100644 --- a/collects/mred/private/snipfile.rkt +++ b/collects/mred/private/snipfile.rkt @@ -25,126 +25,126 @@ #:lock-while-reading? [lock-while-reading? #f]) ;; Check arguments: (unless (text . is-a? . text%) - (raise-argument-error 'open-input-text-editor "(is-a?/c text%)" text)) + (raise-argument-error 'open-input-text-editor "(is-a?/c text%)" text)) (check-non-negative-integer 'open-input-text-editor start) (unless (or (eq? end 'end) - (and (integer? end) (exact? end) (not (negative? end)))) - (raise-argument-error 'open-input-text-editor "(or/c exact-nonnegative-integer? 'end)" end)) + (and (integer? end) (exact? end) (not (negative? end)))) + (raise-argument-error 'open-input-text-editor "(or/c exact-nonnegative-integer? 'end)" end)) (let ([last (send text last-position)]) - (when (start . > . last) + (when (start . > . last) (raise-range-error 'open-input-text-editor "editor" "starting " start text 0 last #f)) - (unless (eq? end 'end) - (unless (<= start end last) + (unless (eq? end 'end) + (unless (<= start end last) (raise-range-error 'open-input-text-editor "editor" "ending " end text start last 0)))) (let ([end (if (eq? end 'end) (send text last-position) end)] - [snip (send text find-snip start 'after-or-none)]) - ;; If the region is small enough, and if the editor contains - ;; only string snips, then it's probably better to move - ;; all of the text into a string port: - (if (or (not snip) - (and (is-a? snip wx:string-snip%) - (let ([s (send text find-next-non-string-snip snip)]) - (or (not s) - ((send text get-snip-position s) . >= . end))))) - (if (or expect-to-read-all? - ((- end start) . < . 4096)) - ;; It's all text, and it's short enough: just read it into a string - (open-input-string (send text get-text start end) port-name) - ;; It's all text, so the reading process is simple: + [snip (send text find-snip start 'after-or-none)]) + ;; If the region is small enough, and if the editor contains + ;; only string snips, then it's probably better to move + ;; all of the text into a string port: + (if (or (not snip) + (and (is-a? snip wx:string-snip%) + (let ([s (send text find-next-non-string-snip snip)]) + (or (not s) + ((send text get-snip-position s) . >= . end))))) + (if (or expect-to-read-all? + ((- end start) . < . 4096)) + ;; It's all text, and it's short enough: just read it into a string + (open-input-string (send text get-text start end) port-name) + ;; It's all text, so the reading process is simple: (let ([start start]) (when lock-while-reading? (send text begin-edit-sequence) (send text lock #t)) (let-values ([(pipe-r pipe-w) (make-pipe)]) - (make-input-port/read-to-peek + (make-input-port/read-to-peek port-name - (lambda (s) - (let ([v (read-bytes-avail!* s pipe-r)]) - (if (eq? v 0) - (let ([n (min 4096 (- end start))]) - (if (zero? n) - (begin + (lambda (s) + (let ([v (read-bytes-avail!* s pipe-r)]) + (if (eq? v 0) + (let ([n (min 4096 (- end start))]) + (if (zero? n) + (begin (close-output-port pipe-w) - (when lock-while-reading? + (when lock-while-reading? (set! lock-while-reading? #f) (send text lock #f) (send text end-edit-sequence)) eof) - (begin - (write-string (send text get-text start (+ start n)) pipe-w) - (set! start (+ start n)) - (let ([ans (read-bytes-avail!* s pipe-r)]) + (begin + (write-string (send text get-text start (+ start n)) pipe-w) + (set! start (+ start n)) + (let ([ans (read-bytes-avail!* s pipe-r)]) (when lock-while-reading? (when (eof-object? ans) (set! lock-while-reading? #f) (send text lock #f) (send text edit-edit-sequence))) ans)))) - v))) + v))) (lambda (s skip general-peek) - (let ([v (peek-bytes-avail!* s skip #f pipe-r)]) - (if (eq? v 0) - (general-peek s skip) - v))) - void)))) - ;; General case, which handles non-text context: - (with-method ([gsp (text get-snip-position)] - [grn (text get-revision-number)]) - (let-values ([(pipe-r pipe-w) (make-pipe)]) - (let* ([get-text-generic (generic wx:snip% get-text)] - [get-count-generic (generic wx:snip% get-count)] - [next-generic (generic wx:snip% next)] - [revision (grn)] - [next? #f] - [update-str-to-snip - (lambda (to-str) - (if snip - (let ([snip-start (gsp snip)]) - (cond - [(snip-start . >= . end) - (set! snip #f) - (set! next? #f) - 0] - [(is-a? snip wx:string-snip%) - (set! next? #t) - (let ([c (min (send-generic snip get-count-generic) (- end snip-start))]) - (write-string (send-generic snip get-text-generic 0 c) pipe-w) - (read-bytes-avail!* to-str pipe-r))] - [else - (set! next? #f) - 0])) - (begin - (set! next? #f) - 0)))] - [next-snip - (lambda (to-str) - (unless (= revision (grn)) - (raise-arguments-error - 'text-input-port - "editor has changed since port was opened" - "editor" text)) - (set! snip (send-generic snip next-generic)) - (update-str-to-snip to-str))] - [read-chars (lambda (to-str) - (cond - [next? - (next-snip to-str)] - [snip - (let ([the-snip (snip-filter snip)]) - (next-snip empty-string) - (lambda (file line col ppos) - (if (is-a? the-snip wx:snip%) - (if (is-a? the-snip wx:readable-snip<%>) - (send the-snip read-special file line col ppos) - (send the-snip copy)) - the-snip)))] - [else eof]))] - [close (lambda () (void))] - [port (make-input-port/read-to-peek - port-name - (lambda (s) + (let ([v (peek-bytes-avail!* s skip #f pipe-r)]) + (if (eq? v 0) + (general-peek s skip) + v))) + void)))) + ;; General case, which handles non-text context: + (with-method ([gsp (text get-snip-position)] + [grn (text get-revision-number)]) + (let-values ([(pipe-r pipe-w) (make-pipe)]) + (let* ([get-text-generic (generic wx:snip% get-text)] + [get-count-generic (generic wx:snip% get-count)] + [next-generic (generic wx:snip% next)] + [revision (grn)] + [next? #f] + [update-str-to-snip + (lambda (to-str) + (if snip + (let ([snip-start (gsp snip)]) + (cond + [(snip-start . >= . end) + (set! snip #f) + (set! next? #f) + 0] + [(is-a? snip wx:string-snip%) + (set! next? #t) + (let ([c (min (send-generic snip get-count-generic) (- end snip-start))]) + (write-string (send-generic snip get-text-generic 0 c) pipe-w) + (read-bytes-avail!* to-str pipe-r))] + [else + (set! next? #f) + 0])) + (begin + (set! next? #f) + 0)))] + [next-snip + (lambda (to-str) + (unless (= revision (grn)) + (raise-arguments-error + 'text-input-port + "editor has changed since port was opened" + "editor" text)) + (set! snip (send-generic snip next-generic)) + (update-str-to-snip to-str))] + [read-chars (lambda (to-str) + (cond + [next? + (next-snip to-str)] + [snip + (let ([the-snip (snip-filter snip)]) + (next-snip empty-string) + (lambda (file line col ppos) + (if (is-a? the-snip wx:snip%) + (if (is-a? the-snip wx:readable-snip<%>) + (send the-snip read-special file line col ppos) + (send the-snip copy)) + the-snip)))] + [else eof]))] + [close (lambda () (void))] + [port (make-input-port/read-to-peek + port-name + (lambda (s) (let* ([v (read-bytes-avail!* s pipe-r)] [res (if (eq? v 0) (read-chars s) v)]) (when (eof-object? res) @@ -154,25 +154,25 @@ (send text end-edit-sequence))) res)) (lambda (s skip general-peek) - (let ([v (peek-bytes-avail!* s skip #f pipe-r)]) - (if (eq? v 0) - (general-peek s skip) - v))) - close)]) - (when lock-while-reading? + (let ([v (peek-bytes-avail!* s skip #f pipe-r)]) + (if (eq? v 0) + (general-peek s skip) + v))) + close)]) + (when lock-while-reading? (send text begin-edit-sequence) (send text lock #t)) (if (is-a? snip wx:string-snip%) - ;; Special handling for initial snip string in - ;; case it starts too early: - (let* ([snip-start (gsp snip)] - [skip (- start snip-start)] - [c (min (- (send-generic snip get-count-generic) skip) - (- end snip-start))]) - (set! next? #t) - (display (send-generic snip get-text-generic skip c) pipe-w)) - (update-str-to-snip empty-string)) - port))))))) + ;; Special handling for initial snip string in + ;; case it starts too early: + (let* ([snip-start (gsp snip)] + [skip (- start snip-start)] + [c (min (- (send-generic snip get-count-generic) skip) + (- end snip-start))]) + (set! next? #t) + (display (send-generic snip get-text-generic skip c) pipe-w)) + (update-str-to-snip empty-string)) + port))))))) (define (jump-to-submodule in-port expected-module k) (let ([header (bytes-append #"^#~" From 95841b9303a753c5b85a929dbfe6167b12407343 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 2 Nov 2012 08:33:40 -0500 Subject: [PATCH 123/221] lift the restriction that the port passed to open-input-text-editor cannot change its revision number during reading This restriction was enforced only for editors that have non string-snip% snips. The restriction was in place because the implementation strategy was to chain thru the snips in the editor using (send snip next) and that isn't safe if the revision number changes. The lifting of the restriction is implemented by tracking the position in the editor where the last snip ended and, if the revision number changes, starting over trying to get a snip from that position. This has the effect that, if the revision number never changes, the code should behave the same as it was doing before (so hopefully any new bugs I've introduced in this commit will only show up if the old implementation would have raised an error) Also, exploit the lifting of this restriction in the colorer so it doesn't to restart the port during to coloring that happens along with the parsing --- collects/framework/private/color.rkt | 3 -- collects/mred/private/snipfile.rkt | 32 ++++++++++------ collects/tests/gracket/editor.rktl | 57 ++++++++++++++++++++++++++++ 3 files changed, 77 insertions(+), 15 deletions(-) diff --git a/collects/framework/private/color.rkt b/collects/framework/private/color.rkt index e340683e51..ec9a03a91c 100644 --- a/collects/framework/private/color.rkt +++ b/collects/framework/private/color.rkt @@ -320,9 +320,6 @@ added get-regions (define re-tokenize-lexer-mode-argument #f) (define/private (continue-re-tokenize start-time did-something?) (cond - [(not (= rev (get-revision-number))) - (c-log "revision number changed unexpectedly") - #f] [(and did-something? ((+ start-time 20) . <= . (current-inexact-milliseconds))) #f] [else diff --git a/collects/mred/private/snipfile.rkt b/collects/mred/private/snipfile.rkt index 831dd5ea3d..86113ee5a1 100644 --- a/collects/mred/private/snipfile.rkt +++ b/collects/mred/private/snipfile.rkt @@ -91,15 +91,17 @@ void)))) ;; General case, which handles non-text context: (with-method ([gsp (text get-snip-position)] - [grn (text get-revision-number)]) + [grn (text get-revision-number)] + [fs (text find-snip)]) (let-values ([(pipe-r pipe-w) (make-pipe)]) (let* ([get-text-generic (generic wx:snip% get-text)] [get-count-generic (generic wx:snip% get-count)] [next-generic (generic wx:snip% next)] [revision (grn)] [next? #f] + [snip-end-position (+ (gsp snip) (send-generic snip get-count-generic))] [update-str-to-snip - (lambda (to-str) + (lambda (skip to-str) (if snip (let ([snip-start (gsp snip)]) (cond @@ -109,8 +111,9 @@ 0] [(is-a? snip wx:string-snip%) (set! next? #t) - (let ([c (min (send-generic snip get-count-generic) (- end snip-start))]) - (write-string (send-generic snip get-text-generic 0 c) pipe-w) + (let ([c (min (- (send-generic snip get-count-generic) skip) + (- end snip-start))]) + (write-string (send-generic snip get-text-generic skip c) pipe-w) (read-bytes-avail!* to-str pipe-r))] [else (set! next? #f) @@ -120,13 +123,18 @@ 0)))] [next-snip (lambda (to-str) - (unless (= revision (grn)) - (raise-arguments-error - 'text-input-port - "editor has changed since port was opened" - "editor" text)) - (set! snip (send-generic snip next-generic)) - (update-str-to-snip to-str))] + (cond + [(= revision (grn)) + (set! snip (send-generic snip next-generic)) + (set! snip-end-position (and snip (+ (gsp snip) (send-generic snip get-count-generic)))) + (update-str-to-snip 0 to-str)] + [else + (set! revision (grn)) + (define old-snip-end-position snip-end-position) + (set! snip (fs snip-end-position 'after-or-none)) + (define snip-start-position (and snip (gsp snip))) + (set! snip-end-position (and snip (+ snip-start-position (send-generic snip get-count-generic)))) + (update-str-to-snip (if snip (- old-snip-end-position snip-start-position) 0) to-str)]))] [read-chars (lambda (to-str) (cond [next? @@ -171,7 +179,7 @@ (- end snip-start))]) (set! next? #t) (display (send-generic snip get-text-generic skip c) pipe-w)) - (update-str-to-snip empty-string)) + (update-str-to-snip 0 empty-string)) port))))))) (define (jump-to-submodule in-port expected-module k) diff --git a/collects/tests/gracket/editor.rktl b/collects/tests/gracket/editor.rktl index 41532ae582..d70c33ad1b 100644 --- a/collects/tests/gracket/editor.rktl +++ b/collects/tests/gracket/editor.rktl @@ -304,6 +304,62 @@ (test #f 'peek-t (peek-byte-or-special i 0)) (test 49 'read-1 (peek-byte-or-special i 1)))) +(let () + (define t (new text%)) + (send t insert "aa\nbb\ncc\ndd\nee\nff\n") + (send t insert (make-object image-snip% + (collection-file-path "recycle.png" "icons"))) + + (define p (open-input-text-editor t)) + + (define rev-at-start (send t get-revision-number)) + (define line1 (read-line p)) + + (define sl (send t get-style-list)) + (define d (make-object style-delta% 'change-bold)) + (define s (send sl find-or-create-style (send sl basic-style) d)) + (send t change-style s 6 7) + + (define rev-after-cs (send t get-revision-number)) + (define line2 (read-line p)) + + (test #t 'revision-changed (> rev-after-cs rev-at-start)) + (test "aa" 'revision-changed-line1 line1) + (test "bb" 'revision-changed-line1 line2)) + +(let () + (define t (new text%)) + (send t insert "abcd\n") + (send t insert (make-object image-snip% + (collection-file-path "recycle.png" "icons"))) + + (define (count-snips) + (let loop ([s (send t find-first-snip)]) + (cond + [s (+ 1 (loop (send s next)))] + [else 0]))) + + (send t split-snip 1) + (define before-snip-count (count-snips)) + (define rev-at-start (send t get-revision-number)) + + (define p (open-input-text-editor t)) + + (define char1 (read-char p)) + + (define s (send (send t get-style-list) basic-style)) + (send t change-style s 0 4) + (define after-snip-count (count-snips)) + (define rev-after-cs (send t get-revision-number)) + + (define chars (string (read-char p) (read-char p) (read-char p))) + + (test 4 'snips-joined1 before-snip-count) + (test 3 'snips-joined2 after-snip-count) + (test #t 'snips-joined3 (> rev-after-cs rev-at-start)) + (test #\a 'snips-joined4 char1) + (test "bcd" 'snips-joined5 chars)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Snips and Streams ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -325,6 +381,7 @@ snip)) (super-instantiate ()))) + (define snip-class (make-object (mk-number-snip-class% #t))) (send snip-class set-classname (format "~s" `(lib "number-snip.ss" "drscheme" "private"))) (send (get-the-snip-class-list) add snip-class) From 4ead534227fcbf8e90d0cc5e890f0a67fe6b05cb Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 2 Nov 2012 09:59:29 -0500 Subject: [PATCH 124/221] It appears that the colorer was always creating a new port to read from, each time it starts on a new event boundary (this means that in the old (5.3) version of the colorer, it also created a new co-routine on each event boundary! (in other words, most of the reason one would want co-routines here was bogus)) So, refactor the code to just always do this and eliminate a bunch of set!'s and private fields in favor of just passing arguments like sane code does. (We can't eliminate all of that, because we still do need to be able to abort and thus all calls must be tail calls.) --- collects/framework/private/color.rkt | 123 ++++++++++++--------------- 1 file changed, 53 insertions(+), 70 deletions(-) diff --git a/collects/framework/private/color.rkt b/collects/framework/private/color.rkt index ec9a03a91c..1879642e2a 100644 --- a/collects/framework/private/color.rkt +++ b/collects/framework/private/color.rkt @@ -236,11 +236,11 @@ added get-regions (start-colorer token-sym->style get-token pairs))) ;; ---------------------- Multi-threading --------------------------- - ;; If there is some incomplete coloring waiting to happen - (define colorer-pending? #f) ;; The editor revision when the last coloring was started - (define rev #f) - + (define revision-when-started-parsing #f) + + ;; The editor revision when after the last edit to the buffer + (define revision-after-last-edit #f) (inherit change-style begin-edit-sequence end-edit-sequence highlight-range get-style-list in-edit-sequence? get-start-position get-end-position @@ -272,8 +272,7 @@ added get-regions (update-lexer-state-observers) (set! restart-callback #f) (set! force-recolor-after-freeze #f) - (set! colorer-pending? #f) - (set! rev #f)) + (set! revision-when-started-parsing #f)) ;; Discard extra tokens at the first of invalid-tokens (define/private (sync-invalid ls) @@ -290,46 +289,38 @@ added get-regions (set-lexer-state-invalid-tokens-mode! ls mode)) (sync-invalid ls)))) - (define/private (start-re-tokenize start-time) - (set! re-tokenize-lses lexer-states) - (re-tokenize-move-to-next-ls start-time)) - - (define/private (re-tokenize-move-to-next-ls start-time) + (define/private (re-tokenize-move-to-next-ls start-time did-something?) (cond [(null? re-tokenize-lses) ;; done: return #t #t] [else - (set! re-tokenize-ls-argument (car re-tokenize-lses)) + (define ls (car re-tokenize-lses)) (set! re-tokenize-lses (cdr re-tokenize-lses)) - (set! re-tokenize-in-start-pos (lexer-state-current-pos re-tokenize-ls-argument)) - (set! re-tokenize-lexer-mode-argument (lexer-state-current-lexer-mode re-tokenize-ls-argument)) - (set! re-tokenize-in-argument - (open-input-text-editor this - (lexer-state-current-pos re-tokenize-ls-argument) - (lexer-state-end-pos re-tokenize-ls-argument) - (λ (x) #f))) - (port-count-lines! re-tokenize-in-argument) - (set! rev (get-revision-number)) - (continue-re-tokenize start-time #t)])) + (define in + (open-input-text-editor this + (lexer-state-current-pos ls) + (lexer-state-end-pos ls) + (λ (x) #f))) + (port-count-lines! in) + (continue-re-tokenize start-time did-something? ls in + (lexer-state-current-pos ls) + (lexer-state-current-lexer-mode ls))])) (define re-tokenize-lses #f) - (define re-tokenize-ls-argument #f) - (define re-tokenize-in-argument #f) - (define re-tokenize-in-start-pos #f) - (define re-tokenize-lexer-mode-argument #f) - (define/private (continue-re-tokenize start-time did-something?) + + (define/private (continue-re-tokenize start-time did-something? ls in in-start-pos lexer-mode) (cond - [(and did-something? ((+ start-time 20) . <= . (current-inexact-milliseconds))) + [(and did-something? ((+ start-time 20.0) . <= . (current-inexact-milliseconds))) #f] [else ;(define-values (_line1 _col1 pos-before) (port-next-location in)) (define-values (lexeme type data new-token-start new-token-end backup-delta new-lexer-mode) - (get-token re-tokenize-in-argument re-tokenize-in-start-pos re-tokenize-lexer-mode-argument)) + (get-token in in-start-pos lexer-mode)) ;(define-values (_line2 _col2 pos-after) (port-next-location in)) (cond [(eq? 'eof type) - (re-tokenize-move-to-next-ls start-time)] + (re-tokenize-move-to-next-ls start-time #t)] [else (unless (exact-nonnegative-integer? new-token-start) (error 'color:text<%> "expected an exact nonnegative integer for the token start, got ~e" new-token-start)) @@ -337,10 +328,10 @@ added get-regions (error 'color:text<%> "expected an exact nonnegative integer for the token end, got ~e" new-token-end)) (unless (exact-nonnegative-integer? backup-delta) (error 'color:text<%> "expected an exact nonnegative integer for the backup delta, got ~e" backup-delta)) - (unless (0 . < . (- new-token-end new-token-start)) - (error 'color:text<%> "expected the distance between the start and end position for each token to be positive, but start was ~e and end was ~e" new-token-start new-token-end)) - #; (printf "~s at ~a to ~a\n" lexeme (+ in-start-pos (sub1 new-token-start)) - (+ in-start-pos (sub1 new-token-end))) + (unless (new-token-start . < . new-token-end) + (error 'color:text<%> + "expected the distance between the start and end position for each token to be positive, but start was ~e and end was ~e" + new-token-start new-token-end)) (let ((len (- new-token-end new-token-start))) #; (unless (= len (- pos-after pos-before)) @@ -348,34 +339,33 @@ added get-regions ;; when this check fails, bad things can happen non-deterministically later on (eprintf "pos changed bad ; len ~s pos-before ~s pos-after ~s (token ~s mode ~s)\n" len pos-before pos-after lexeme new-lexer-mode)) - (set-lexer-state-current-pos! re-tokenize-ls-argument (+ len (lexer-state-current-pos re-tokenize-ls-argument))) - (set-lexer-state-current-lexer-mode! re-tokenize-ls-argument new-lexer-mode) - (sync-invalid re-tokenize-ls-argument) + (set-lexer-state-current-pos! ls (+ len (lexer-state-current-pos ls))) + (set-lexer-state-current-lexer-mode! ls new-lexer-mode) + (sync-invalid ls) (when (and should-color? (should-color-type? type) (not frozen?)) - (add-colorings type re-tokenize-in-start-pos new-token-start new-token-end)) + (add-colorings type in-start-pos new-token-start new-token-end)) ;; Using the non-spec version takes 3 times as long as the spec ;; version. In other words, the new greatly outweighs the tree ;; operations. ;;(insert-last! tokens (new token-tree% (length len) (data type))) - (insert-last-spec! (lexer-state-tokens re-tokenize-ls-argument) len (make-data type new-lexer-mode backup-delta)) + (insert-last-spec! (lexer-state-tokens ls) len (make-data type new-lexer-mode backup-delta)) #; (show-tree (lexer-state-tokens ls)) - (send (lexer-state-parens re-tokenize-ls-argument) add-token data len) + (send (lexer-state-parens ls) add-token data len) (cond - [(and (not (send (lexer-state-invalid-tokens re-tokenize-ls-argument) is-empty?)) - (= (lexer-state-invalid-tokens-start re-tokenize-ls-argument) - (lexer-state-current-pos re-tokenize-ls-argument)) + [(and (not (send (lexer-state-invalid-tokens ls) is-empty?)) + (= (lexer-state-invalid-tokens-start ls) + (lexer-state-current-pos ls)) (equal? new-lexer-mode - (lexer-state-invalid-tokens-mode re-tokenize-ls-argument))) - (send (lexer-state-invalid-tokens re-tokenize-ls-argument) search-max!) - (send (lexer-state-parens re-tokenize-ls-argument) merge-tree - (send (lexer-state-invalid-tokens re-tokenize-ls-argument) get-root-end-position)) - (insert-last! (lexer-state-tokens re-tokenize-ls-argument) - (lexer-state-invalid-tokens re-tokenize-ls-argument)) - (set-lexer-state-invalid-tokens-start! re-tokenize-ls-argument +inf.0) - (re-tokenize-move-to-next-ls start-time)] + (lexer-state-invalid-tokens-mode ls))) + (send (lexer-state-invalid-tokens ls) search-max!) + (send (lexer-state-parens ls) merge-tree + (send (lexer-state-invalid-tokens ls) get-root-end-position)) + (insert-last! (lexer-state-tokens ls) + (lexer-state-invalid-tokens ls)) + (set-lexer-state-invalid-tokens-start! ls +inf.0) + (re-tokenize-move-to-next-ls start-time #t)] [else - (set! re-tokenize-lexer-mode-argument new-lexer-mode) - (continue-re-tokenize start-time #t)]))])])) + (continue-re-tokenize start-time #t ls in in-start-pos new-lexer-mode)]))])])) (define/private (add-colorings type in-start-pos new-token-start new-token-end) (define sp (+ in-start-pos (sub1 new-token-start))) @@ -509,24 +499,17 @@ added get-regions (unless (andmap lexer-state-up-to-date? lexer-states) (begin-edit-sequence #f #f) (c-log "starting to color") - (define finished? - (cond - [(and colorer-pending? (= rev (get-revision-number))) - (continue-re-tokenize (current-inexact-milliseconds) #f)] - [else - (start-re-tokenize (current-inexact-milliseconds))])) + (set! re-tokenize-lses lexer-states) + (define finished? (re-tokenize-move-to-next-ls (current-inexact-milliseconds) #f)) (c-log (format "coloring stopped ~a" (if finished? "because it finished" "with more to do"))) - (cond - [finished? - (set! colorer-pending? #f) - (for-each (lambda (ls) - (set-lexer-state-up-to-date?! ls #t)) - lexer-states) - (update-lexer-state-observers) - (c-log "updated observers")] - [else - (set! colorer-pending? #t)]) - (end-edit-sequence))) + (when finished? + (for ([ls (in-list lexer-states)]) + (set-lexer-state-up-to-date?! ls #t)) + (update-lexer-state-observers) + (c-log "updated observers")) + (c-log "starting end-edit-sequence") + (end-edit-sequence) + (c-log "finished end-edit-sequence"))) (define/private (colorer-callback) (cond From 948e898406d01fa07b9ebe12e21128c9bc5e6f32 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Fri, 2 Nov 2012 11:05:20 -0400 Subject: [PATCH 125/221] Fix continuation mark chaperones Failed to redirect correctly on `continuation-mark-set-first` when the mark set argument was #f. --- collects/tests/racket/contract-test.rktl | 19 +++++++++++++++++++ src/racket/src/fun.c | 5 +++-- 2 files changed, 22 insertions(+), 2 deletions(-) diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index dd93b870c4..0286c604f5 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -4350,6 +4350,25 @@ (with-continuation-mark mark (lambda (x) (+ x 1)) (do-mark mark)))) + (test/pos-blame + 'continuation-mark-key/c-ho-10 + '(let* ([mark (make-continuation-mark-key)] + [ctc-mark (contract (continuation-mark-key/c number?) + mark + 'pos + 'neg)]) + (with-continuation-mark mark "not a number" + (+ 1 (continuation-mark-set-first #f ctc-mark))))) + + (test/spec-passed + 'continuation-mark-key/c-ho-11 + '(let* ([mark (make-continuation-mark-key)] + [ctc-mark (contract (continuation-mark-key/c number?) + mark + 'pos + 'neg)]) + (continuation-mark-set-first #f ctc-mark))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; make-contract diff --git a/src/racket/src/fun.c b/src/racket/src/fun.c index a251f97e59..1bdad50a0b 100644 --- a/src/racket/src/fun.c +++ b/src/racket/src/fun.c @@ -7889,6 +7889,9 @@ scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set, Scheme_Object *key } } + if (key_arg != key && val != NULL) + val = scheme_chaperone_do_continuation_mark("continuation-mark-set-first", 1, key_arg, val); + pos = startpos - findpos; if (pos > 16) { pos >>= 1; @@ -7931,8 +7934,6 @@ scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set, Scheme_Object *key } else cht = NULL; - if (key_arg != key) - val = scheme_chaperone_do_continuation_mark("continuation-mark-set-first", 1, key_arg, val); if (!cache || !SCHEME_VECTORP(cache)) { /* No cache so far, so map one key */ cache = scheme_make_vector(4, NULL); From 466d6e73945de0f64990f357030a31871c8e49ee Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 2 Nov 2012 09:54:12 -0600 Subject: [PATCH 126/221] fixes for PPC JIT Related to recent structure-operation changes. --- src/racket/src/jit.h | 8 ++++---- src/racket/src/jitcall.c | 2 +- src/racket/src/jitcommon.c | 6 +++++- src/racket/src/jitinline.c | 16 +++++++++++----- 4 files changed, 21 insertions(+), 11 deletions(-) diff --git a/src/racket/src/jit.h b/src/racket/src/jit.h index 24e92ff4e7..73d9459fb5 100644 --- a/src/racket/src/jit.h +++ b/src/racket/src/jit.h @@ -1113,15 +1113,15 @@ static void emit_indentation(mz_jit_state *jitter) #endif #define PAST_LIMIT() ((uintptr_t)jit_get_ip().ptr > (uintptr_t)jitter->limit) -#define CHECK_LIMIT() if (PAST_LIMIT()) return past_limit(jitter); +#define CHECK_LIMIT() if (PAST_LIMIT()) return past_limit(jitter, __FILE__, __LINE__); #if 1 -# define past_limit(j) 0 +# define past_limit(j, f, l) 0 #else -static int past_limit(mz_jit_state *jitter) +static int past_limit(mz_jit_state *jitter, const char *file, int line) { if (((uintptr_t)jit_get_ip().ptr > (uintptr_t)jitter->limit + JIT_BUFFER_PAD_SIZE) || (jitter->retain_start)) { - printf("way past\n"); abort(); + printf("way past %s %d\n", file, line); abort(); } return 0; } diff --git a/src/racket/src/jitcall.c b/src/racket/src/jitcall.c index 97f80683da..bfbda3673a 100644 --- a/src/racket/src/jitcall.c +++ b/src/racket/src/jitcall.c @@ -988,7 +988,7 @@ int scheme_generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc #endif if (unboxed_args) { /* no slow path here; return NULL to box arguments fall back to generic */ - jit_movi_p(JIT_R0, NULL); + (void)jit_movi_p(JIT_R0, NULL); if (pop_and_jump) { mz_epilog(JIT_V1); } diff --git a/src/racket/src/jitcommon.c b/src/racket/src/jitcommon.c index f3af854d10..a68f80cf77 100644 --- a/src/racket/src/jitcommon.c +++ b/src/racket/src/jitcommon.c @@ -605,6 +605,7 @@ static int common2(mz_jit_state *jitter, void *_data) int argc, j; void *code; for (j = 0; j < 2; j++) { + CHECK_LIMIT(); code = jit_get_ip().ptr; if (!i) { if (!j) @@ -1463,6 +1464,7 @@ int scheme_generate_struct_op(mz_jit_state *jitter, int kind, int for_branch, __START_INNER_TINY__(1); ref2 = jit_beqi_i(jit_forward(), JIT_R2, scheme_structure_type); ref3 = jit_beqi_i(jit_forward(), JIT_R2, scheme_proc_struct_type); + CHECK_LIMIT(); ref9 = jit_beqi_i(jit_forward(), JIT_R2, scheme_chaperone_type); __END_INNER_TINY__(1); bref2 = jit_bnei_i(jit_forward(), JIT_R2, scheme_proc_chaperone_type); @@ -1576,6 +1578,7 @@ int scheme_generate_struct_op(mz_jit_state *jitter, int kind, int for_branch, } else { refdone = NULL; } + CHECK_LIMIT(); /* False branch: */ if (branch_info) { @@ -2101,7 +2104,8 @@ static int common4c(mz_jit_state *jitter, void *_data) else sjc.struct_constr_nary_code = code; num_args =-1; - } + } else + num_args = 0; scheme_generate_struct_alloc(jitter, num_args, 1, 1, ii == 2, ii == 1); diff --git a/src/racket/src/jitinline.c b/src/racket/src/jitinline.c index 44beb5a28c..1a63080d1a 100644 --- a/src/racket/src/jitinline.c +++ b/src/racket/src/jitinline.c @@ -407,6 +407,7 @@ static int generate_inlined_struct_op(int kind, mz_jit_state *jitter, if (kind == INLINE_STRUCT_PROC_SET) scheme_restore_struct_temp(jitter, JIT_V1); __END_SHORT_JUMPS__(1); + CHECK_LIMIT(); } else { ref = NULL; refslow = NULL; @@ -482,6 +483,7 @@ static int generate_inlined_struct_op(int kind, mz_jit_state *jitter, } } else if (kind == INLINE_STRUCT_PROC_CONSTR) { scheme_generate_struct_alloc(jitter, rand2 ? 2 : 1, 0, 0, is_tail, multi_ok); + CHECK_LIMIT(); } else { scheme_signal_error("internal error: unknown struct-op mode"); } @@ -511,13 +513,15 @@ static int generate_inlined_struct_op(int kind, mz_jit_state *jitter, jkind = 3; } else jkind = 1; - + + CHECK_LIMIT(); scheme_generate_struct_op(jitter, jkind, !!for_branch, for_branch, branch_short, result_ignored, 0, 0, tpos, pos, 0, refslow, refslow, NULL, NULL); + CHECK_LIMIT(); if (ref2) { __START_SHORT_JUMPS__(1); @@ -808,13 +812,14 @@ int scheme_generate_struct_alloc(mz_jit_state *jitter, int num_args, #ifdef CAN_INLINE_ALLOC int i; jit_movr_p(JIT_R0, JIT_R2); - jit_movi_p(JIT_R1, 0); /* clear register that might get saved as a pointer */ + (void)jit_movi_p(JIT_R1, 0); /* clear register that might get saved as a pointer */ inline_struct_alloc(jitter, num_args, inline_slow); /* allocation result is in V1 */ jit_stxi_p((intptr_t)&((Scheme_Structure *)0x0)->stype + OBJHEAD_SIZE, JIT_V1, JIT_R0); for (i = 0; i < num_args; i++) { jit_ldxi_p(JIT_R1, JIT_RUNSTACK, WORDS_TO_BYTES(i)); jit_stxi_p((intptr_t)&(((Scheme_Structure *)0x0)->slots[0]) + OBJHEAD_SIZE + WORDS_TO_BYTES(i), JIT_V1, JIT_R1); + CHECK_LIMIT(); } jit_addi_p(JIT_R0, JIT_V1, OBJHEAD_SIZE); #else @@ -827,6 +832,7 @@ int scheme_generate_struct_alloc(mz_jit_state *jitter, int num_args, jit_retval(JIT_R0); #endif } + CHECK_LIMIT(); if (pop_and_jump) { mz_epilog(JIT_V1); @@ -853,7 +859,7 @@ static int generate_inlined_constant_varref_test(mz_jit_state *jitter, Scheme_Ob int pos; if (SCHEME_VARREF_FLAGS(obj) & 0x1) { - jit_movi_p(JIT_R0, scheme_true); + (void)jit_movi_p(JIT_R0, scheme_true); return 1; } @@ -3329,11 +3335,11 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int scheme_add_branch_false(for_branch, reffalse); __END_SHORT_JUMPS__(branch_short); } else { - jit_movi_p(JIT_R0, scheme_true); + (void)jit_movi_p(JIT_R0, scheme_true); reftrue = jit_jmpi(jit_forward()); mz_patch_branch(reffalse); - jit_movi_p(JIT_R0, scheme_false); + (void)jit_movi_p(JIT_R0, scheme_false); mz_patch_branch(reftrue); __END_TINY_JUMPS__(1); From 3d68fc25057d65522a8f9799b440bc49f695d6d8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 2 Nov 2012 10:29:11 -0600 Subject: [PATCH 127/221] fix allocation of bytecode-validation stack overflow --- src/racket/src/validate.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/racket/src/validate.c b/src/racket/src/validate.c index 964033c723..ed8fe61150 100644 --- a/src/racket/src/validate.c +++ b/src/racket/src/validate.c @@ -1212,7 +1212,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, *_2st_ht = *_st_ht; } - args = MALLOC_N_ATOMIC(int, 11); + args = MALLOC_N_ATOMIC(int, 12); p->ku.k.p1 = (void *)port; p->ku.k.p2 = (void *)expr; @@ -1232,7 +1232,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, args[10] = tl_timestamp; args[11] = expected_results; - pr = MALLOC_N(void*, 6); + pr = MALLOC_N(void*, 7); pr[0] = (void *)args; pr[1] = (void *)app_rator; pr[2] = (void *)tls; From 56a46916649baa0c9d148aaed6976af9e23cdd0d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 2 Nov 2012 10:32:51 -0600 Subject: [PATCH 128/221] tweak test to hit a less bad overflow point --- collects/tests/racket/stress/module-stack.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/tests/racket/stress/module-stack.rkt b/collects/tests/racket/stress/module-stack.rkt index a4348ca0fe..dc559569fe 100644 --- a/collects/tests/racket/stress/module-stack.rkt +++ b/collects/tests/racket/stress/module-stack.rkt @@ -33,5 +33,5 @@ -1) (sub1 v))) (if (eval-jit-enabled) - 500 + 503 50)))) From f232e56623731da5077f1949dfc60e3e84ce6300 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 2 Nov 2012 10:54:02 -0600 Subject: [PATCH 129/221] tweak optimization tests Use `racket/base' to speed up the test suite --- collects/tests/racket/optimize.rktl | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/tests/racket/optimize.rktl b/collects/tests/racket/optimize.rktl index 9e47596018..971b34345c 100644 --- a/collects/tests/racket/optimize.rktl +++ b/collects/tests/racket/optimize.rktl @@ -1299,10 +1299,10 @@ (let ([try-equiv (lambda (extras) (lambda (a b) - (test-comp `(module m racket + (test-comp `(module m racket/base (define (f x) (apply x ,@extras ,a))) - `(module m racket + `(module m racket/base (define (f x) (x ,@extras ,@b))))))]) (map (lambda (try-equiv) @@ -1321,7 +1321,7 @@ (try-equiv '(0)) (try-equiv '(0 1))))) -(test-comp '(module m mzscheme +(test-comp '(module m racket/base (define (q x) ;; Single-use bindings should be inlined always: (let* ([a (lambda (x) (+ x 10))] @@ -1336,7 +1336,7 @@ [j (lambda (x) (+ 1 (i x)))] [k (lambda (x) (+ 1 (j x)))]) (k x)))) - '(module m mzscheme + '(module m racket/base (define (q x) (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ x 10)))))))))))))) From a635fe817b002825c01799a8436049ab0c5ab8e9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 2 Nov 2012 11:44:43 -0600 Subject: [PATCH 130/221] remove unused local variable --- src/racket/src/future.c | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/racket/src/future.c b/src/racket/src/future.c index 5e9056b6b1..77a12fc9c6 100644 --- a/src/racket/src/future.c +++ b/src/racket/src/future.c @@ -1425,12 +1425,10 @@ static void run_would_be_future(future_t *ft) mz_jmp_buf newbuf, *savebuf; Scheme_Thread *p; Scheme_Future_State *fs; - Scheme_Future_Thread_State *fts; int aborted = 0; p = scheme_current_thread; fs = scheme_future_state; - fts = scheme_future_thread_state; /* Setup the future thread state */ p->futures_slow_path_tracing++; From 3fd5b5eb6e050a8d62ce42e80adba88440a75fc1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 2 Nov 2012 12:03:57 -0600 Subject: [PATCH 131/221] backtrace fix --- src/racket/gc2/backtrace.c | 2 +- src/racket/gc2/newgc.c | 10 ++++++++++ 2 files changed, 11 insertions(+), 1 deletion(-) diff --git a/src/racket/gc2/backtrace.c b/src/racket/gc2/backtrace.c index dab7299429..69882a42df 100644 --- a/src/racket/gc2/backtrace.c +++ b/src/racket/gc2/backtrace.c @@ -47,7 +47,7 @@ static void *print_out_pointer(const char *prefix, void *p, page = pagemap_find_page(GC_instance->page_maps, p); if (!page || (trace_page_type(page) == TRACE_PAGE_BAD)) { - GCPRINT(GCOUTF, "%s%s %p %p\n", prefix, trace_source_kind(*_kind), p); + GCPRINT(GCOUTF, "%s%s %p\n", prefix, trace_source_kind(*_kind), p); return NULL; } p = trace_pointer_start(page, p); diff --git a/src/racket/gc2/newgc.c b/src/racket/gc2/newgc.c index b4abf7009d..f456871d90 100644 --- a/src/racket/gc2/newgc.c +++ b/src/racket/gc2/newgc.c @@ -351,6 +351,10 @@ inline static void check_used_against_max(NewGC *gc, size_t len) page_count = size_to_apage_count(len); gc->used_pages += page_count; +#if MZ_GC_BACKTRACE + if (gc->dumping_avoid_collection) return; +#endif + if(gc->in_unsafe_allocation_mode) { if(gc->used_pages > gc->max_pages_in_heap) gc->unsafe_allocation_abort(gc); @@ -3412,6 +3416,12 @@ static void *trace_pointer_start(mpage *page, void *p) { const char *trace_source_kind(int kind) { switch (kind) { + case PAGE_TAGGED: return "_TAGGED"; + case PAGE_ATOMIC: return "_ATOMIC"; + case PAGE_ARRAY: return "_ARRAY"; + case PAGE_TARRAY: return "_TARRAY"; + case PAGE_PAIR: return "_PAIR"; + case PAGE_BIG: return "_BIG"; case BT_STACK: return "STACK"; case BT_ROOT: return "ROOT"; case BT_FINALIZER: return "FINALIZER"; From 1f0508d77efee34909e880ebba123c8ae02424ce Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 2 Nov 2012 13:01:37 -0600 Subject: [PATCH 132/221] fix initialization of local --- src/racket/src/eval.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/racket/src/eval.c b/src/racket/src/eval.c index ddd3e8223d..74df9a6a68 100644 --- a/src/racket/src/eval.c +++ b/src/racket/src/eval.c @@ -919,6 +919,7 @@ static Scheme_Object *link_toplevel(Scheme_Object **exprs, int which, Scheme_Env modname = env->module->modname; mod_phase = env->mod_phase; } + shape = NULL; } else if (SCHEME_PAIRP(expr)) { varname = SCHEME_CAR(expr); modname = SCHEME_CDR(expr); @@ -926,6 +927,7 @@ static Scheme_Object *link_toplevel(Scheme_Object **exprs, int which, Scheme_Env mod_phase = SCHEME_INT_VAL(SCHEME_CDR(modname)); modname = SCHEME_CAR(modname); } + shape = NULL; } else { modname = SCHEME_VEC_ELS(expr)[0]; varname = SCHEME_VEC_ELS(expr)[1]; From 55170581c4179d37d42c6e0975b290ee08dd14d0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 2 Nov 2012 12:56:09 -0600 Subject: [PATCH 133/221] fix locking for futures on uniprocessors The scheme_is_multiprocessor() function wasn't the right guard for whether to use a locking compare-and-swap instruction; any use of pthread-based futures needs the compare-and-swap. Merge to v5.3.1 --- src/racket/src/future.c | 19 ++++++++----------- src/racket/src/hash.c | 4 +--- src/racket/src/jitcommon.c | 4 ++-- src/racket/src/jitinline.c | 2 +- src/racket/src/schpriv.h | 2 +- 5 files changed, 13 insertions(+), 18 deletions(-) diff --git a/src/racket/src/future.c b/src/racket/src/future.c index 77a12fc9c6..2028c5006f 100644 --- a/src/racket/src/future.c +++ b/src/racket/src/future.c @@ -156,7 +156,7 @@ static Scheme_Object *processor_count(int argc, Scheme_Object *argv[]) return scheme_make_integer(1); } -int scheme_is_multiprocessor(int now) +int scheme_is_multithreaded(int now) { return 0; } @@ -2195,17 +2195,14 @@ static void init_cpucount(void) #endif } -int scheme_is_multiprocessor(int now) +int scheme_is_multithreaded(int now) { - if (cpucount > 1) { - if (!now) - return 1; - else { - Scheme_Future_State *fs = scheme_future_state; - return (fs && fs->future_threads_created); - } - } else - return 0; + if (!now) + return 1; + else { + Scheme_Future_State *fs = scheme_future_state; + return (fs && fs->future_threads_created); + } } Scheme_Object *processor_count(int argc, Scheme_Object *argv[]) diff --git a/src/racket/src/hash.c b/src/racket/src/hash.c index 3df6636489..58ebf57d30 100644 --- a/src/racket/src/hash.c +++ b/src/racket/src/hash.c @@ -61,8 +61,6 @@ static void register_traversers(void); running in a future and setting flags on pairs. */ SHARED_OK static uintptr_t keygen; -XFORM_NONGCING extern int scheme_is_multiprocessor(); - XFORM_NONGCING static MZ_INLINE uintptr_t PTR_TO_LONG(Scheme_Object *o) { @@ -92,7 +90,7 @@ uintptr_t PTR_TO_LONG(Scheme_Object *o) #endif if (!v) v = 0x1AD0; #ifdef MZ_USE_FUTURES - if (SCHEME_PAIRP(o) && scheme_is_multiprocessor(1)) { + if (SCHEME_PAIRP(o) && scheme_is_multithreaded(1)) { /* Use CAS to avoid losing a hash code due to a conflict with JIT-generated `list?' test, which itself uses CAS to set "is a list" or "not a list" flags on pairs. */ diff --git a/src/racket/src/jitcommon.c b/src/racket/src/jitcommon.c index a68f80cf77..c338efc6be 100644 --- a/src/racket/src/jitcommon.c +++ b/src/racket/src/jitcommon.c @@ -2530,7 +2530,7 @@ static int common7(mz_jit_state *jitter, void *_data) jit_ldxi_s(JIT_R2, JIT_R1, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso)); #ifdef MZ_USE_FUTURES - if (scheme_is_multiprocessor(0)) { + if (scheme_is_multithreaded(0)) { /* Need an atomic update in case another thread is setting a hash code on the target pair. */ ref5 = jit_bmsi_i(jit_forward(), JIT_R2, PAIR_IS_LIST); @@ -2567,7 +2567,7 @@ static int common7(mz_jit_state *jitter, void *_data) jit_ldxi_s(JIT_R2, JIT_R1, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso)); #ifdef MZ_USE_FUTURES /* As above: */ - if (scheme_is_multiprocessor(0)) { + if (scheme_is_multithreaded(0)) { ref5 = jit_bmsi_i(jit_forward(), JIT_R2, PAIR_IS_NON_LIST); jit_movr_i(JIT_R0, JIT_R2); jit_ori_i(JIT_R2, JIT_R2, PAIR_IS_NON_LIST); diff --git a/src/racket/src/jitinline.c b/src/racket/src/jitinline.c index 1a63080d1a..a601bf54a0 100644 --- a/src/racket/src/jitinline.c +++ b/src/racket/src/jitinline.c @@ -3318,7 +3318,7 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int /* This is the actual CAS: */ #ifdef MZ_USE_FUTURES - if (scheme_is_multiprocessor(0)) { + if (scheme_is_multithreaded(0)) { jit_lock_cmpxchgr_l(JIT_R1, JIT_V1); /* implicitly uses JIT_R0 */ reffalse = (JNEm(jit_forward(), 0,0,0), _jit.x.pc); } else diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index e8a9f8e73d..9620c62046 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -303,7 +303,7 @@ void scheme_free_dynamic_extensions(void); void scheme_free_all_code(void); void scheme_free_ghbn_data(void); -XFORM_NONGCING int scheme_is_multiprocessor(int now); +XFORM_NONGCING int scheme_is_multithreaded(int now); /* Type readers & writers for compiled code data */ typedef Scheme_Object *(*Scheme_Type_Reader)(Scheme_Object *list); From 6f1f04f99c919bc7e877214f8bb98b5159a38e27 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 2 Nov 2012 15:35:05 -0400 Subject: [PATCH 134/221] Typed Racket HISTORY. --- doc/release-notes/typed-racket/HISTORY.txt | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/doc/release-notes/typed-racket/HISTORY.txt b/doc/release-notes/typed-racket/HISTORY.txt index 42577848d0..67868c2269 100644 --- a/doc/release-notes/typed-racket/HISTORY.txt +++ b/doc/release-notes/typed-racket/HISTORY.txt @@ -1,3 +1,7 @@ +5.3.1 +- Revised handling of `Any` exported to untyped code +- Added `cast` +- Correctly compute variance of polymorphic type application 5.3 - Keyword and optional arguments - Faster startup From 4948ca0863a26f9b1ab68ad2a5e606a8c7f538b2 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Fri, 2 Nov 2012 18:16:56 -0400 Subject: [PATCH 135/221] Fix typo Closes PR 13158 --- collects/scribblings/gui/menu-item-intf.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/gui/menu-item-intf.scrbl b/collects/scribblings/gui/menu-item-intf.scrbl index 68256560ac..7f86372afa 100644 --- a/collects/scribblings/gui/menu-item-intf.scrbl +++ b/collects/scribblings/gui/menu-item-intf.scrbl @@ -10,7 +10,7 @@ A @racket[menu-item<%>] object is an element within a @racket[menu%], @racket[menu-item<%>] object. A menu item is either a @racket[separator-menu-item%] object (merely - a separator), of a @racket[labelled-menu-item<%>] object; the latter + a separator), or a @racket[labelled-menu-item<%>] object; the latter is more specifically an instance of either @racket[menu-item%] (a plain menu item), @racket[checkable-menu-item%] (a checkable menu item), or @racket[menu%] (a submenu). From 27aa99944657c5827eee3772f715df7dd971d1e0 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Fri, 2 Nov 2012 18:30:47 -0400 Subject: [PATCH 136/221] Fix docs on continuation barriers Closes PR 13085 --- collects/scribblings/reference/eval-model.scrbl | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/collects/scribblings/reference/eval-model.scrbl b/collects/scribblings/reference/eval-model.scrbl index 1c1e86a6b6..6cdbf66c86 100644 --- a/collects/scribblings/reference/eval-model.scrbl +++ b/collects/scribblings/reference/eval-model.scrbl @@ -683,13 +683,14 @@ the marks associated with the relevant frames are also captured. A @deftech{continuation barrier} is another kind of continuation frame that prohibits certain replacements of the current continuation with another. Specifically, a continuation can be replaced by another only -when the replacement does not introduce any continuation barriers (but -it may remove them). A continuation barrier thus prevents ``downward -jumps'' into a continuation that is protected by a barrier. Certain operations -install barriers automatically; in particular, when an exception -handler is called, a continuation barrier prohibits the continuation -of the handler from capturing the continuation past the exception -point. +when the replacement does not introduce any continuation barriers. It +may remove continuation barriers only through jumps to continuations +that are a tail of the current continuation. A continuation barrier +thus prevents ``downward jumps'' into a continuation that is protected +by a barrier. Certain operations install barriers automatically; in +particular, when an exception handler is called, a continuation +barrier prohibits the continuation of the handler from capturing the +continuation past the exception point. A @deftech{escape continuation} is essentially a derived concept. It combines a prompt for escape purposes with a continuation for From 0377bda9474f8848a97509ace898174c83361006 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 2 Nov 2012 19:37:42 -0500 Subject: [PATCH 137/221] make popup menus respond to mouse-up events, not mouse-down ones --- collects/framework/private/keymap.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/framework/private/keymap.rkt b/collects/framework/private/keymap.rkt index 4c9fdd0e63..6556aa5fd0 100644 --- a/collects/framework/private/keymap.rkt +++ b/collects/framework/private/keymap.rkt @@ -337,7 +337,7 @@ [mouse-popup-menu (λ (edit event) - (when (send event button-down?) + (when (send event button-up?) (let ([a (send edit get-admin)]) (when a (let ([m (make-object popup-menu%)]) From c375042f10fc1440fb56a2ef867f42e24f16bb39 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 3 Nov 2012 10:19:59 -0500 Subject: [PATCH 138/221] fix test so that labels can be regexps (as was already documented) and tidy up framework/test docs --- collects/framework/test.rkt | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/collects/framework/test.rkt b/collects/framework/test.rkt index 87845539c9..1f64b784c2 100644 --- a/collects/framework/test.rkt +++ b/collects/framework/test.rkt @@ -253,22 +253,26 @@ (define object-tag 'test:find-object) -;; find-object : class (union string (object -> boolean)) -> object +;; find-object : class (union string regexp (object -> boolean)) -> object (define (find-object obj-class b-desc) (λ () (cond [(or (string? b-desc) + (regexp? b-desc) (procedure? b-desc)) (let* ([active-frame (test:get-active-top-level-window)] [_ (unless active-frame (error object-tag - "could not find object: ~a, no active frame" + "could not find object: ~e, no active frame" b-desc))] [child-matches? (λ (child) (cond [(string? b-desc) (equal? (send child get-label) b-desc)] + [(regexp? b-desc) + (and (send child get-label) + (regexp-match? b-desc (send child get-label)))] [(procedure? b-desc) (b-desc child)]))] [found @@ -287,13 +291,13 @@ (send panel get-children)))]) (or found (error object-tag - "no object of class ~a named ~e in active frame" + "no object of class ~e named ~e in active frame" obj-class b-desc)))] [(is-a? b-desc obj-class) b-desc] [else (error object-tag - "expected either a string or an object of class ~a as input, received: ~a" + "expected either a string or an object of class ~e as input, received: ~e" obj-class b-desc)]))) @@ -936,7 +940,8 @@ (proc-doc/names test:keystroke (->* ((or/c char? symbol?)) - ((listof (symbols 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometea 'noshift))) + ((listof (or/c 'alt 'control 'meta 'shift + 'noalt 'nocontrol 'nometea 'noshift))) void?) ((key) ((modifier-list null))) @@ -973,10 +978,11 @@ (proc-doc/names test:mouse-click (->* - ((symbols 'left 'middle 'right) + ((or/c 'left 'middle 'right) (and/c exact? integer?) (and/c exact? integer?)) - ((listof (symbols 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometa 'noshift))) + ((listof (or/c 'alt 'control 'meta 'shift 'noalt + 'nocontrol 'nometa 'noshift))) void?) ((button x y) ((modifiers null))) @@ -985,7 +991,7 @@ @method[canvas<%> on-event] method. Use @racket[test:button-push] to click on a button. - On the Macintosh, @racket['right] corresponds to holding down the command + Under Mac OS X, @racket['right] corresponds to holding down the command modifier key while clicking and @racket['middle] cannot be generated. Under Windows, @racket['middle] can only be generated if the user has a From e1760fa7c0690697a97343faf3d4991990c19c91 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 3 Nov 2012 10:20:36 -0500 Subject: [PATCH 139/221] add find-labelled-windows --- collects/tests/utils/gui.rkt | 119 ++++++++++++++++++----------------- 1 file changed, 63 insertions(+), 56 deletions(-) diff --git a/collects/tests/utils/gui.rkt b/collects/tests/utils/gui.rkt index 069e29d38e..b4709ac1bb 100644 --- a/collects/tests/utils/gui.rkt +++ b/collects/tests/utils/gui.rkt @@ -1,8 +1,10 @@ -(module gui mzscheme - (require mred - mzlib/class - mzlib/etc) - (provide find-labelled-window whitespace-string=?) +#lang racket/base + + (require racket/gui/base + racket/class) + (provide find-labelled-window + find-labelled-windows + whitespace-string=?) ;; whitespace-string=? : string string -> boolean ;; determines if two strings are equal, up to their whitespace. @@ -60,59 +62,64 @@ [else #f]))) ;; whitespace-string=? tests - '(map (lambda (x) (apply equal? x)) - (list (list #t (whitespace-string=? "a" "a")) - (list #f (whitespace-string=? "a" "A")) - (list #f (whitespace-string=? "a" " ")) - (list #f (whitespace-string=? " " "A")) - (list #t (whitespace-string=? " " " ")) - (list #t (whitespace-string=? " " " ")) - (list #t (whitespace-string=? " " " ")) - (list #t (whitespace-string=? " " " ")) - (list #t (whitespace-string=? "a a" "a a")) - (list #t (whitespace-string=? "a a" "a a")) - (list #t (whitespace-string=? "a a" "a a")) - (list #t (whitespace-string=? " a" "a")) - (list #t (whitespace-string=? "a" " a")) - (list #t (whitespace-string=? "a " "a")) - (list #t (whitespace-string=? "a" "a ")))) + (module+ test + (require rackunit) + (check-equal? #t (whitespace-string=? "a" "a")) + (check-equal? #f (whitespace-string=? "a" "A")) + (check-equal? #f (whitespace-string=? "a" " ")) + (check-equal? #f (whitespace-string=? " " "A")) + (check-equal? #t (whitespace-string=? " " " ")) + (check-equal? #t (whitespace-string=? " " " ")) + (check-equal? #t (whitespace-string=? " " " ")) + (check-equal? #t (whitespace-string=? " " " ")) + (check-equal? #t (whitespace-string=? "a a" "a a")) + (check-equal? #t (whitespace-string=? "a a" "a a")) + (check-equal? #t (whitespace-string=? "a a" "a a")) + (check-equal? #t (whitespace-string=? " a" "a")) + (check-equal? #t (whitespace-string=? "a" " a")) + (check-equal? #t (whitespace-string=? "a " "a")) + (check-equal? #t (whitespace-string=? "a" "a "))) ;;; find-labelled-window : (union ((union #f string) -> window<%>) ;;; ((union #f string) (union #f class) -> window<%>) ;;; ((union #f string) (union class #f) area-container<%> -> window<%>)) ;;;; may call error, if no control with the label is found - (define find-labelled-window - (opt-lambda (label - [class #f] - [window (get-top-level-focus-window)] - [failure (lambda () - (error 'find-labelled-window "no window labelled ~e in ~e~a" - label - window - (if class - (format " matching class ~e" class) - "")))]) - (unless (or (not label) - (string? label)) - (error 'find-labelled-window "first argument must be a string or #f, got ~e; other args: ~e ~e" - label class window)) - (unless (or (class? class) - (not class)) - (error 'find-labelled-window "second argument must be a class or #f, got ~e; other args: ~e ~e" - class label window)) - (unless (is-a? window area-container<%>) - (error 'find-labelled-window "third argument must be a area-container<%>, got ~e; other args: ~e ~e" - window label class)) - (let ([ans - (let loop ([window window]) - (cond - [(and (or (not class) - (is-a? window class)) - (let ([win-label (and (is-a? window window<%>) - (send window get-label))]) - (equal? label win-label))) - window] - [(is-a? window area-container<%>) (ormap loop (send window get-children))] - [else #f]))]) - (or ans - (failure)))))) + (define (find-labelled-window label + [class #f] + [window (get-top-level-focus-window)] + [failure (λ () + (error 'find-labelled-window "no window labelled ~e in ~e~a" + label + window + (if class + (format " matching class ~e" class) + "")))]) + (define windows (find-labelled-windows label class window)) + (cond + [(null? windows) (failure)] + [else (car windows)])) + + (define (find-labelled-windows label [class #f] [window (get-top-level-focus-window)]) + (unless (or (not label) + (string? label)) + (error 'find-labelled-windows "first argument must be a string or #f, got ~e; other args: ~e ~e" + label class window)) + (unless (or (class? class) + (not class)) + (error 'find-labelled-windows "second argument must be a class or #f, got ~e; other args: ~e ~e" + class label window)) + (unless (is-a? window area-container<%>) + (error 'find-labelled-windows "third argument must be a area-container<%>, got ~e; other args: ~e ~e" + window label class)) + (let loop ([window window]) + (cond + [(and (or (not class) + (is-a? window class)) + (let ([win-label (and (is-a? window window<%>) + (send window get-label))]) + (equal? label win-label))) + (list window)] + [(is-a? window area-container<%>) (apply append (map loop (send window get-children)))] + [else '()]))) + + From 5768009e3b716ce430244244cf85b7635ccbbbc4 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 27 Oct 2012 18:38:18 -0500 Subject: [PATCH 140/221] Revise the language dialog to emphasize the teaching languages and the 'in the source' language at the expense of all other dialog-based languages --- .../private/language-configuration.rkt | 572 +++++++++++------- collects/drracket/private/main.rkt | 1 + collects/scribblings/tools/tools.scrbl | 9 +- .../private/english-string-constants.rkt | 5 +- .../drracket/private/drracket-test-util.rkt | 106 ++-- 5 files changed, 412 insertions(+), 281 deletions(-) diff --git a/collects/drracket/private/language-configuration.rkt b/collects/drracket/private/language-configuration.rkt index f577a46ff9..1ef2dceb7f 100644 --- a/collects/drracket/private/language-configuration.rkt +++ b/collects/drracket/private/language-configuration.rkt @@ -17,7 +17,7 @@ (define original-output (current-output-port)) (define (oprintf . args) (apply fprintf original-output args)) - (define-values (sc-use-language-in-source sc-choose-a-language mouse-event-uses-shortcut-prefix?) + (define-values (sc-use-language-in-source sc-use-teaching-language sc-choose-a-language mouse-event-uses-shortcut-prefix?) (let* ([shortcut-prefix (get-default-shortcut-prefix)] [menukey-string (apply string-append @@ -40,8 +40,10 @@ shortcut-prefix)) (values (string-append (string-constant use-language-in-source) (format " (~aU)" menukey-string)) - (string-append (string-constant choose-a-language) - (format " (~aC)" menukey-string)) + (string-append (string-constant teaching-languages) + (format " (~aT)" menukey-string)) + (string-append (string-constant other-languages) + (format " (~aO)" menukey-string)) mouse-event-uses-shortcut-prefix?))) (define sc-lang-in-source-discussion (string-constant lang-in-source-discussion)) @@ -257,7 +259,7 @@ (add-welcome dialog welcome-before-panel welcome-after-panel)) (send dialog stretchable-width #f) - (send dialog stretchable-height #t) + (send dialog stretchable-height #f) (unless parent (send dialog center 'both)) @@ -276,8 +278,8 @@ ;; if re-center is a dialog, when the show details button is clicked, the dialog is recenterd. (define fill-language-dialog (λ (parent show-details-parent language-settings-to-show - [re-center #f] - [ok-handler void]) ; en/disable button, execute it + [re-center #f] + [ok-handler void]) ; en/disable button, execute it (define-values (language-to-show settings-to-show) (let ([request-lang-to-show (language-settings-language language-settings-to-show)]) @@ -376,9 +378,13 @@ (cond [(and i (is-a? i hieritem-language<%>)) (define pos (send (send i get-language) get-language-position)) - (preferences:set 'drracket:language-dialog:hierlist-default pos) - (set! most-recent-languages-hier-list-selection pos) - (something-selected i)] + (if (eq? this teaching-languages-hier-list) + (preferences:set 'drracket:language-dialog:teaching-hierlist-default pos) + (preferences:set 'drracket:language-dialog:hierlist-default pos)) + (if (eq? this teaching-languages-hier-list) + (set! most-recent-teaching-languages-hier-list-selection pos) + (set! most-recent-languages-hier-list-selection pos)) + (something-selected this i)] [else (non-language-selected)])) ;; this is used only because we set `on-click-always' @@ -388,7 +394,7 @@ ;; double-click selects a language (define/override (on-double-select i) (when (and i (is-a? i hieritem-language<%>)) - (something-selected i) + (something-selected this i) (ok-handler 'execute))) (super-new [parent parent]) ;; do this so we can expand/collapse languages on a single click @@ -396,9 +402,12 @@ (on-click-always #t) (allow-deselect #t))) - (define outermost-panel (new horizontal-pane% [parent parent])) + (define outermost-panel (new horizontal-panel% + [parent parent] + [alignment '(left top)])) (define languages-choice-panel (new vertical-panel% [parent outermost-panel] + [stretchable-height #f] [alignment '(left top)])) (define use-language-in-source-rb @@ -411,7 +420,8 @@ (use-language-in-source-rb-callback))])) (define (use-language-in-source-rb-callback) (module-language-selected) - (send use-chosen-language-rb set-selection #f)) + (send use-chosen-language-rb set-selection #f) + (send use-teaching-language-rb set-selection #f)) (define in-source-discussion-panel (new horizontal-panel% [parent languages-choice-panel] [stretchable-height #f])) @@ -421,6 +431,39 @@ [min-width 32])) (define in-source-discussion-editor-canvas (add-discussion in-source-discussion-panel)) (define most-recent-languages-hier-list-selection (preferences:get 'drracket:language-dialog:hierlist-default)) + (define most-recent-teaching-languages-hier-list-selection (preferences:get 'drracket:language-dialog:teaching-hierlist-default)) + + (define use-teaching-language-rb + (new radio-box% + [label #f] + [choices (list sc-use-teaching-language)] + [parent languages-choice-panel] + [callback + (λ (rb evt) + (use-teaching-language-rb-callback))])) + (define (use-teaching-language-rb-callback) + (when most-recent-teaching-languages-hier-list-selection + (select-a-language-in-hierlist teaching-languages-hier-list + (cdr most-recent-teaching-languages-hier-list-selection))) + (send use-chosen-language-rb set-selection #f) + (send use-language-in-source-rb set-selection #f) + (send use-teaching-language-rb set-selection 0) + (send other-languages-hier-list select #f) + (send teaching-languages-hier-list focus)) + + (define teaching-languages-hier-list-panel + (new horizontal-panel% [parent languages-choice-panel] [stretchable-height #f])) + (define teaching-languages-hier-list-spacer + (new horizontal-panel% + [parent teaching-languages-hier-list-panel] + [stretchable-width #f] + [min-width 16])) + + (define teaching-languages-hier-list + (new selectable-hierlist% + [parent teaching-languages-hier-list-panel] + [style '(no-border no-hscroll auto-vscroll transparent)])) + (define use-chosen-language-rb (new radio-box% [label #f] @@ -430,19 +473,35 @@ (λ (this-rb evt) (use-chosen-language-rb-callback))])) (define (use-chosen-language-rb-callback) + (when (member ellipsis-spacer-panel (send languages-hier-list-panel get-children)) + (send languages-hier-list-panel change-children + (λ (l) + (list languages-hier-list-spacer other-languages-hier-list)))) (when most-recent-languages-hier-list-selection - (select-a-language-in-hierlist most-recent-languages-hier-list-selection)) + (select-a-language-in-hierlist other-languages-hier-list + most-recent-languages-hier-list-selection)) (send use-language-in-source-rb set-selection #f) - (send languages-hier-list focus)) - (define languages-hier-list-panel (new horizontal-panel% [parent languages-choice-panel])) + (send use-teaching-language-rb set-selection #f) + (send teaching-languages-hier-list select #f) + (send other-languages-hier-list focus)) + + (define languages-hier-list-panel (new horizontal-panel% + [parent languages-choice-panel] + [stretchable-height #f])) + (define ellipsis-spacer-panel (new horizontal-panel% + [parent languages-hier-list-panel] + [stretchable-width #f] + [min-width 32])) + (define ellipsis-message (new message% [label "..."] [parent languages-hier-list-panel])) + (define languages-hier-list-spacer (new horizontal-panel% [parent languages-hier-list-panel] [stretchable-width #f] [min-width 16])) - (define languages-hier-list (new selectable-hierlist% - [parent languages-hier-list-panel] - [style '(no-border no-hscroll auto-vscroll transparent)])) + (define other-languages-hier-list (new selectable-hierlist% + [parent languages-hier-list-panel] + [style '(no-border no-hscroll auto-vscroll transparent)])) (define details-outer-panel (make-object vertical-pane% outermost-panel)) (define details/manual-parent-panel (make-object vertical-panel% details-outer-panel)) (define details-panel (make-object panel:single% details/manual-parent-panel)) @@ -493,9 +552,11 @@ (define (module-language-selected) ;; need to deselect things in the languages-hier-list at this point. - (send languages-hier-list select #f) - (send use-chosen-language-rb set-selection #f) + (send other-languages-hier-list select #f) + (send teaching-languages-hier-list select #f) (send use-language-in-source-rb set-selection 0) + (send use-chosen-language-rb set-selection #f) + (send use-teaching-language-rb set-selection #f) (ok-handler 'enable) (send details-button enable #t) (update-gui-based-on-selected-language module-language*language @@ -504,12 +565,14 @@ ;; no-language-selected : -> void ;; updates the GUI for the situation where no language at all selected, and - ;; and thus neither of the radio buttons should be selected. + ;; and thus none of the radio buttons should be selected. ;; this generally happens when there is no preference setting for the language ;; (ie the user has just started drracket for the first time) (define (no-language-selected) (non-language-selected) - (send use-chosen-language-rb set-selection #f)) + (send use-language-in-source-rb set-selection #f) + (send use-chosen-language-rb set-selection #f) + (send use-teaching-language-rb set-selection #f)) (define module-language*language 'module-language*-not-yet-set) (define module-language*get-language-details-panel 'module-language*-not-yet-set) @@ -519,8 +582,6 @@ ;; updates the GUI and selected-language and get/set-selected-language-settings ;; for when some non-language is selected in the hierlist (define (non-language-selected) - (send use-chosen-language-rb set-selection 0) - (send use-language-in-source-rb set-selection #f) (send revert-to-defaults-button enable #f) (send details-panel active-child no-details-panel) (send one-line-summary-message set-label "") @@ -530,10 +591,18 @@ (send details-button enable #f)) ;; something-selected : item -> void - (define (something-selected item) - (send use-chosen-language-rb set-selection 0) + (define (something-selected hierlist item) (send use-language-in-source-rb set-selection #f) - (ok-handler 'enable) + (cond + [(eq? hierlist other-languages-hier-list) + (send use-teaching-language-rb set-selection #f) + (send use-chosen-language-rb set-selection 0) + (send teaching-languages-hier-list select #f)] + [else + (send use-teaching-language-rb set-selection 0) + (send use-chosen-language-rb set-selection #f) + (send other-languages-hier-list select #f)]) + (ok-handler 'enable) (send details-button enable #t) (send item selected)) @@ -546,34 +615,38 @@ ;; when `language' matches language-to-show, update the settings ;; panel to match language-to-show, otherwise set to defaults. (define (add-language-to-dialog language) - (let ([positions (send language get-language-position)] - [numbers (send language get-language-numbers)]) + (define positions (send language get-language-position)) + (define numbers (send language get-language-numbers)) + (define teaching-language? (and (pair? positions) + (equal? (car positions) + (string-constant teaching-languages)))) + + ;; don't show the initial language ... + (unless (equal? positions initial-language-position) + (unless (and (list? positions) + (list? numbers) + (pair? positions) + (pair? numbers) + (andmap number? numbers) + (andmap string? positions) + (= (length positions) (length numbers)) + ((length numbers) . >= . 1)) + (error 'drracket:language + (string-append + "languages position and numbers must be lists of strings and numbers," + " respectively, must have the same length, and must each contain at" + " least one element, got: ~e ~e") + positions numbers)) - ;; don't show the initial language ... - (unless (equal? positions initial-language-position) - (unless (and (list? positions) - (list? numbers) - (pair? positions) - (pair? numbers) - (andmap number? numbers) - (andmap string? positions) - (= (length positions) (length numbers)) - ((length numbers) . >= . 1)) + (when (null? (cdr positions)) + (unless (equal? positions (list (string-constant module-language-name))) (error 'drracket:language - (string-append - "languages position and numbers must be lists of strings and numbers," - " respectively, must have the same length, and must each contain at" - " least one element, got: ~e ~e") - positions numbers)) - - (when (null? (cdr positions)) - (unless (equal? positions (list (string-constant module-language-name))) - (error 'drracket:language - "Only the module language may be at the top level. Other languages must have at least two levels"))) - - (send languages-hier-list clear-fringe-cache) - - #| + "Only the module language may be at the top level. Other languages must have at least two levels"))) + + (send other-languages-hier-list clear-fringe-cache) + (send teaching-languages-hier-list clear-fringe-cache) + + #| inline the first level of the tree into just items in the hierlist keep track of the starting (see call to sort method below) by @@ -581,67 +654,72 @@ what the sorting number is for its level above (in the second-number mixin) |# - - (let add-sub-language ([ht languages-table] - [hier-list languages-hier-list] - [positions positions] - [numbers numbers] - [first? #t] - [second-number #f]) ;; only non-#f during the second iteration in which case it is the first iterations number - (cond - [(null? (cdr positions)) - (let* ([language-details-panel #f] - [real-get/set-settings - (case-lambda - [() - (cond - [(and language-to-show - settings-to-show - (equal? (send language-to-show get-language-position) - (send language get-language-position))) - settings-to-show] - [else - (send language default-settings)])] - [(x) (void)])] - [get-language-details-panel (lambda () language-details-panel)] - [get/set-settings (lambda x (apply real-get/set-settings x))] - [position (car positions)] - [number (car numbers)]) - - (set! construct-details - (let ([old construct-details]) - (lambda () - (old) - (let-values ([(language-details-panel-real get/set-settings) - (make-details-panel language)]) - (set! language-details-panel language-details-panel-real) - (set! real-get/set-settings get/set-settings)) - - (let-values ([(vis-lang vis-settings) - (cond - [(and (not selected-language) - (eq? language-to-show language)) - (values language-to-show settings-to-show)] - [(eq? selected-language language) - (values language - (if (eq? language language-to-show) - settings-to-show - (send language default-settings)))] - [else (values #f #f)])]) - (cond - [(and vis-lang - (equal? (send vis-lang get-language-position) - (send language get-language-position))) - (get/set-settings vis-settings) - (send details-panel active-child language-details-panel)] - [else - (get/set-settings (send language default-settings))]))))) - - (cond - [(equal? positions (list (string-constant module-language-name))) - (set! module-language*language language) - (set! module-language*get-language-details-panel get-language-details-panel) - (set! module-language*get/set-settings get/set-settings)] + (let add-sub-language ([ht languages-table] + [hier-list (if teaching-language? + teaching-languages-hier-list + other-languages-hier-list)] + [positions (if teaching-language? + (cdr positions) + positions)] + [numbers (if teaching-language? + (cdr numbers) + numbers)] + [first? #t] + [second-number #f]) ;; only non-#f during the second iteration in which case it is the first iterations number + (cond + [(null? (cdr positions)) + (let* ([language-details-panel #f] + [real-get/set-settings + (case-lambda + [() + (cond + [(and language-to-show + settings-to-show + (equal? (send language-to-show get-language-position) + (send language get-language-position))) + settings-to-show] + [else + (send language default-settings)])] + [(x) (void)])] + [get-language-details-panel (lambda () language-details-panel)] + [get/set-settings (lambda x (apply real-get/set-settings x))] + [position (car positions)] + [number (car numbers)]) + + (set! construct-details + (let ([old construct-details]) + (lambda () + (old) + (let-values ([(language-details-panel-real get/set-settings) + (make-details-panel language)]) + (set! language-details-panel language-details-panel-real) + (set! real-get/set-settings get/set-settings)) + + (let-values ([(vis-lang vis-settings) + (cond + [(and (not selected-language) + (eq? language-to-show language)) + (values language-to-show settings-to-show)] + [(eq? selected-language language) + (values language + (if (eq? language language-to-show) + settings-to-show + (send language default-settings)))] + [else (values #f #f)])]) + (cond + [(and vis-lang + (equal? (send vis-lang get-language-position) + (send language get-language-position))) + (get/set-settings vis-settings) + (send details-panel active-child language-details-panel)] + [else + (get/set-settings (send language default-settings))]))))) + + (cond + [(equal? positions (list (string-constant module-language-name))) + (set! module-language*language language) + (set! module-language*get-language-details-panel get-language-details-panel) + (set! module-language*get/set-settings get/set-settings)] [else (let* ([mixin (compose number-mixin @@ -671,61 +749,62 @@ (send language get-style-delta) 0 (send text last-position))])))]))] - [else (let* ([position (car positions)] - [number (car numbers)] - [sub-ht/sub-hier-list - (hash-ref - ht - (string->symbol position) - (λ () - (if first? - (let* ([item (send hier-list new-item number-mixin)] - [x (list (make-hasheq) hier-list item)]) - (hash-set! ht (string->symbol position) x) - (send item set-number number) - (send item set-allow-selection #f) - (let* ([editor (send item get-editor)] - [pos (send editor last-position)]) - (send editor insert "\n") - (send editor insert position) - (send editor change-style small-size-delta pos (+ pos 1)) - (send editor change-style section-style-delta - (+ pos 1) (send editor last-position))) - x) - (let* ([new-list (send hier-list new-list - (if second-number - (compose second-number-mixin number-mixin) - number-mixin))] - [x (list (make-hasheq) new-list #f)]) - (send new-list set-number number) - (when second-number - (send new-list set-second-number second-number)) - (send new-list set-allow-selection #t) - (send new-list open) - (send (send new-list get-editor) insert position) - (hash-set! ht (string->symbol position) x) - x))))]) - (cond - [first? - (unless (= number (send (caddr sub-ht/sub-hier-list) get-number)) - (error 'add-language "language ~s; expected number for ~e to be ~e, got ~e" - (send language get-language-name) - position - (send (caddr sub-ht/sub-hier-list) get-number) - number))] - [else - (unless (= number (send (cadr sub-ht/sub-hier-list) get-number)) - (error 'add-language "language ~s; expected number for ~e to be ~e, got ~e" - (send language get-language-name) - position - (send (cadr sub-ht/sub-hier-list) get-number) - number))]) - (add-sub-language (car sub-ht/sub-hier-list) - (cadr sub-ht/sub-hier-list) - (cdr positions) - (cdr numbers) - #f - (if first? number #f)))]))))) + [else + (let* ([position (car positions)] + [number (car numbers)] + [sub-ht/sub-hier-list + (hash-ref + ht + (string->symbol position) + (λ () + (if first? + (let* ([item (send hier-list new-item number-mixin)] + [x (list (make-hasheq) hier-list item)]) + (hash-set! ht (string->symbol position) x) + (send item set-number number) + (send item set-allow-selection #f) + (let* ([editor (send item get-editor)] + [pos (send editor last-position)]) + (send editor insert "\n") + (send editor insert position) + (send editor change-style small-size-delta pos (+ pos 1)) + (send editor change-style section-style-delta + (+ pos 1) (send editor last-position))) + x) + (let* ([new-list (send hier-list new-list + (if second-number + (compose second-number-mixin number-mixin) + number-mixin))] + [x (list (make-hasheq) new-list #f)]) + (send new-list set-number number) + (when second-number + (send new-list set-second-number second-number)) + (send new-list set-allow-selection #t) + (send new-list open) + (send (send new-list get-editor) insert position) + (hash-set! ht (string->symbol position) x) + x))))]) + (cond + [first? + (unless (= number (send (caddr sub-ht/sub-hier-list) get-number)) + (error 'add-language "language ~s; expected number for ~e to be ~e, got ~e" + (send language get-language-name) + position + (send (caddr sub-ht/sub-hier-list) get-number) + number))] + [else + (unless (= number (send (cadr sub-ht/sub-hier-list) get-number)) + (error 'add-language "language ~s; expected number for ~e to be ~e, got ~e" + (send language get-language-name) + position + (send (cadr sub-ht/sub-hier-list) get-number) + number))]) + (add-sub-language (car sub-ht/sub-hier-list) + (cadr sub-ht/sub-hier-list) + (cdr positions) + (cdr numbers) + #f + (if first? number #f)))])))) (define number<%> (interface () @@ -779,35 +858,59 @@ (send item close) (close-children item)] [else (void)])) - (close-children languages-hier-list)) + (close-children other-languages-hier-list) + (close-children teaching-languages-hier-list)) ;; open-current-language : -> void ;; opens the tabs that lead to the current language ;; and selects the current language (define (open-current-language) + + ;; set the initial selection in the hierlists + (let ([hier-default (preferences:get 'drracket:language-dialog:hierlist-default)]) + (when hier-default + (select-a-language-in-hierlist other-languages-hier-list hier-default))) + (let ([hier-default (preferences:get 'drracket:language-dialog:teaching-hierlist-default)]) + (when hier-default + (select-a-language-in-hierlist teaching-languages-hier-list (cdr hier-default)))) + + (send languages-hier-list-panel change-children + (λ (l) + (list ellipsis-spacer-panel ellipsis-message))) + (cond [(not (and language-to-show settings-to-show)) (no-language-selected)] [(is-a? language-to-show drracket:module-language:module-language<%>) - (let ([hier-default (preferences:get 'drracket:language-dialog:hierlist-default)]) - (when hier-default - (select-a-language-in-hierlist hier-default))) ;; the above changes the radio button selections, so do it before calling module-language-selected (module-language-selected)] [else - (send languages-hier-list focus) ;; only focus when the module language isn't selected - (send use-chosen-language-rb set-selection 0) - (send use-language-in-source-rb set-selection #f) - (select-a-language-in-hierlist (send language-to-show get-language-position))])) + (define position (send language-to-show get-language-position)) + (cond + [(and (pair? position) + (equal? (car position) + (string-constant teaching-languages))) + (select-a-language-in-hierlist teaching-languages-hier-list (cdr position)) + (send use-teaching-language-rb set-selection 0) + (send use-chosen-language-rb set-selection #f) + (send teaching-languages-hier-list focus)] + [else + (send languages-hier-list-panel change-children + (λ (l) + (list languages-hier-list-spacer other-languages-hier-list))) + (select-a-language-in-hierlist other-languages-hier-list position) + (send use-teaching-language-rb set-selection #f) + (send use-chosen-language-rb set-selection 0) + (send other-languages-hier-list focus)]) + (send use-language-in-source-rb set-selection #f)])) - (define (select-a-language-in-hierlist language-position) + (define (select-a-language-in-hierlist hier-list language-position) (cond [(null? (cdr language-position)) ;; nothing to open here - (send (car (send languages-hier-list get-items)) select #t) - (void)] + (send (car (send hier-list get-items)) select #t)] [else - (let loop ([hi languages-hier-list] + (let loop ([hi hier-list] ;; skip the first position, since it is flattened into the dialog [first-pos (cadr language-position)] @@ -819,8 +922,6 @@ (send hi get-items))]) (cond [(null? matching-children) - ;; just give up here. probably this means that a bad preference was saved - ;; and we're being called from the module-language case in 'open-current-language' (void)] [else (let ([child (car matching-children)]) @@ -828,8 +929,9 @@ [(null? position) (send child select #t)] [else - (send child open) - (loop child (car position) (cdr position))]))])))])) + (when (is-a? child hierarchical-list-compound-item<%>) ;; test can fail when prefs are bad + (send child open) + (loop child (car position) (cdr position)))]))])))])) ;; docs-callback : -> void (define (docs-callback) @@ -901,46 +1003,47 @@ (send revert-to-defaults-outer-panel stretchable-width #f) (send revert-to-defaults-outer-panel stretchable-height #f) - (send outermost-panel set-alignment 'center 'center) (for-each add-language-to-dialog languages) - (send languages-hier-list sort - (λ (x y) - (cond - [(and (x . is-a? . second-number<%>) - (y . is-a? . second-number<%>)) - (cond - [(= (send x get-second-number) - (send y get-second-number)) - (< (send x get-number) (send y get-number))] - [else - (< (send x get-second-number) - (send y get-second-number))])] - [(and (x . is-a? . number<%>) - (y . is-a? . second-number<%>)) - (cond - [(= (send x get-number) - (send y get-second-number)) - #t] - [else - (< (send x get-number) - (send y get-second-number))])] - [(and (x . is-a? . second-number<%>) - (y . is-a? . number<%>)) - (cond - [(= (send x get-second-number) - (send y get-number)) - #f] - [else (< (send x get-second-number) - (send y get-number))])] - [(and (x . is-a? . number<%>) - (y . is-a? . number<%>)) - (< (send x get-number) (send y get-number))] - [else #f]))) + (define (hier-list-sort-predicate x y) + (cond + [(and (x . is-a? . second-number<%>) + (y . is-a? . second-number<%>)) + (cond + [(= (send x get-second-number) + (send y get-second-number)) + (< (send x get-number) (send y get-number))] + [else + (< (send x get-second-number) + (send y get-second-number))])] + [(and (x . is-a? . number<%>) + (y . is-a? . second-number<%>)) + (cond + [(= (send x get-number) + (send y get-second-number)) + #t] + [else + (< (send x get-number) + (send y get-second-number))])] + [(and (x . is-a? . second-number<%>) + (y . is-a? . number<%>)) + (cond + [(= (send x get-second-number) + (send y get-number)) + #f] + [else (< (send x get-second-number) + (send y get-number))])] + [(and (x . is-a? . number<%>) + (y . is-a? . number<%>)) + (< (send x get-number) (send y get-number))] + [else #f])) + (send other-languages-hier-list sort hier-list-sort-predicate) + (send teaching-languages-hier-list sort hier-list-sort-predicate) ;; remove the newline at the front of the first inlined category (if there) ;; it won't be there if the module language is at the top. - (let ([t (send (car (send languages-hier-list get-items)) get-editor)]) + (for ([hier-list (in-list (list other-languages-hier-list teaching-languages-hier-list))]) + (define t (send (car (send hier-list get-items)) get-editor)) (when (equal? "\n" (send t get-text 0 1)) (send t delete 0 1))) @@ -949,15 +1052,21 @@ (λ (l) (list details-panel))) - (send languages-hier-list stretchable-width #t) - (send languages-hier-list stretchable-height #t) - (send languages-hier-list accept-tab-focus #t) - (send languages-hier-list allow-tab-exit #t) + (define (config-hier-list hier-list) + (send hier-list stretchable-width #t) + (send hier-list stretchable-height #t) + (send hier-list accept-tab-focus #t) + (send hier-list allow-tab-exit #t)) + (config-hier-list other-languages-hier-list) + (config-hier-list teaching-languages-hier-list) (send parent reflow-container) (close-all-languages) (open-current-language) - (send languages-hier-list min-client-width (text-width (send languages-hier-list get-editor))) - (send languages-hier-list min-client-height (text-height (send languages-hier-list get-editor))) + (define (set-min-sizes hier-list) + (send hier-list min-client-width (text-width (send hier-list get-editor))) + (send hier-list min-client-height (text-height (send hier-list get-editor)))) + (set-min-sizes other-languages-hier-list) + (set-min-sizes teaching-languages-hier-list) (when details-shown? (do-construct-details)) (update-show/hide-details) @@ -979,7 +1088,14 @@ (use-language-in-source-rb-callback) #t) #f)] - [(#\c) + [(#\t) + (if (mouse-event-uses-shortcut-prefix? evt) + (begin + (send use-teaching-language-rb set-selection 0) + (use-teaching-language-rb-callback) + #t) + #f)] + [(#\o) (if (mouse-event-uses-shortcut-prefix? evt) (begin (send use-chosen-language-rb set-selection 0) @@ -1178,7 +1294,7 @@ #f #f #t) - (+ 10 ;; upper bound on some platform specific space I don't know how to get. + (+ 16 ;; upper bound on some space I don't know how to get. (floor (inexact->exact (unbox y-box)))))) diff --git a/collects/drracket/private/main.rkt b/collects/drracket/private/main.rkt index 0fd6472ece..1ace972f97 100644 --- a/collects/drracket/private/main.rkt +++ b/collects/drracket/private/main.rkt @@ -72,6 +72,7 @@ (preferences:set-default 'drracket:defs/ints-labels #t boolean?) (drr:set-default 'drracket:language-dialog:hierlist-default #f (λ (x) (or (not x) (and (list? x) (andmap string? x))))) +(preferences:set-default 'drracket:language-dialog:teaching-hierlist-default #f (λ (x) (or (not x) (and (list? x) (andmap string? x))))) (drr:set-default 'drracket:create-executable-gui-type 'stand-alone (λ (x) (memq x '(launcher stand-alone distribution)))) (drr:set-default 'drracket:create-executable-gui-base 'racket (λ (x) (memq x '(racket gracket)))) diff --git a/collects/scribblings/tools/tools.scrbl b/collects/scribblings/tools/tools.scrbl index 3b3fc3011d..ec535c8b24 100644 --- a/collects/scribblings/tools/tools.scrbl +++ b/collects/scribblings/tools/tools.scrbl @@ -10,7 +10,8 @@ (for-label racket/base racket/gui) (for-label framework/framework) (for-label drracket/syncheck-drracket-button - drracket/check-syntax) + drracket/check-syntax + string-constants/string-constant) scribble/eval scribble/extract) @@ -318,6 +319,12 @@ This must be bound to a corresponds to the position of the language in language dialog. Each language position is a list of strings whose length must be at least two. + + If the first string is the same as + @racket[(string-constant teaching-languages)], then + it is put into the ``Teaching Languages'' section + of the dialog. Otherwise, it goes into the ``Other Languages'' + section of the dialog. } @item/cap[drscheme-language-numbers]{ This is optional. If diff --git a/collects/string-constants/private/english-string-constants.rkt b/collects/string-constants/private/english-string-constants.rkt index 95714b2ff6..1488589ad1 100644 --- a/collects/string-constants/private/english-string-constants.rkt +++ b/collects/string-constants/private/english-string-constants.rkt @@ -1153,9 +1153,10 @@ please adhere to these guidelines: (experimental-languages "Experimental Languages") (initial-language-category "Initial language") (no-language-chosen "No language chosen") - + (other-languages "Other Languages") + (module-language-name "Determine language from source") - (module-language-one-line-summary "Reads the #lang line to specify the actual language") + (module-language-one-line-summary "The #lang line specifies the actual language") (module-language-auto-text "Automatic #lang line") ;; shows up in the details section of the module language ;; for the upper portion of the language dialog diff --git a/collects/tests/drracket/private/drracket-test-util.rkt b/collects/tests/drracket/private/drracket-test-util.rkt index b5aa08cc36..0c6482d2e4 100644 --- a/collects/tests/drracket/private/drracket-test-util.rkt +++ b/collects/tests/drracket/private/drracket-test-util.rkt @@ -353,21 +353,25 @@ (not-on-eventspace-handler-thread 'set-language-level!) (let ([drs-frame (fw:test:get-active-top-level-window)]) (fw:test:menu-select "Language" "Choose Language...") - (let* ([language-dialog (wait-for-new-frame drs-frame)] - [language-choice (find-labelled-window #f hierarchical-list% (fw:test:get-active-top-level-window))] - [b1 (box 0)] - [b2 (box 0)] - [click-on-snip - (lambda (snip) - (let* ([editor (send (send snip get-admin) get-editor)] - [between-threshold (send editor get-between-threshold)]) - (send editor get-snip-location snip b1 b2) - (let-values ([(gx gy) (send editor editor-location-to-dc-location - (unbox b1) - (unbox b2))]) - (let ([x (inexact->exact (floor (+ gx between-threshold 1)))] - [y (inexact->exact (floor (+ gy between-threshold 1)))]) - (fw:test:mouse-click 'left x y)))))]) + (define language-dialog (wait-for-new-frame drs-frame)) + (fw:test:set-radio-box-item! #rx"Other Languages") + (define language-choices (find-labelled-windows #f hierarchical-list% (fw:test:get-active-top-level-window))) + (define b1 (box 0)) + (define b2 (box 0)) + (define (click-on-snip snip) + (let* ([editor (send (send snip get-admin) get-editor)] + [between-threshold (send editor get-between-threshold)]) + (send editor get-snip-location snip b1 b2) + (let-values ([(gx gy) (send editor editor-location-to-dc-location + (unbox b1) + (unbox b2))]) + (let ([x (inexact->exact (floor (+ gx between-threshold 1)))] + [y (inexact->exact (floor (+ gy between-threshold 1)))]) + (fw:test:mouse-click 'left x y))))) + + (define found-language? #f) + + (for ([language-choice (in-list language-choices)]) (send language-choice focus) (let loop ([list-item language-choice] [language-spec in-language-spec]) @@ -382,41 +386,43 @@ (and matches child))) (send list-item get-items))]) - (when (null? which) - (error 'set-language-level! "couldn't find language: ~e, no match at ~e, poss: ~s" - in-language-spec name (map (λ (child) (send (send child get-editor) get-text)) - (send list-item get-items)))) - (unless (= 1 (length which)) - (error 'set-language-level! "couldn't find language: ~e, double match ~e" - in-language-spec name)) - (let ([next-item (car which)]) - (cond - [(null? (cdr language-spec)) - (when (is-a? next-item hierarchical-list-compound-item<%>) - (error 'set-language-level! "expected no more languages after ~e, but still are, input ~e" - name in-language-spec)) - (click-on-snip (send next-item get-clickable-snip))] - [else - (unless (is-a? next-item hierarchical-list-compound-item<%>) - (error 'set-language-level! "expected more languages after ~e, but got to end, input ~e" - name in-language-spec)) - (unless (send next-item is-open?) - (click-on-snip (send next-item get-arrow-snip))) - (loop next-item (cdr language-spec))])))) - - (with-handlers ([exn:fail? (lambda (x) (void))]) - (fw:test:button-push "Show Details")) - - (fw:test:button-push "Revert to Language Defaults") - - (when close-dialog? - (fw:test:button-push "OK") - (let ([new-frame (wait-for-new-frame language-dialog)]) - (unless (eq? new-frame drs-frame) - (error 'set-language-level! - "didn't get drracket frame back, got: ~s (drs-frame ~s)\n" - new-frame - drs-frame)))))))) + (unless (null? which) + (unless (= 1 (length which)) + (error 'set-language-level! "couldn't find language: ~e, double match ~e" + in-language-spec name)) + (let ([next-item (car which)]) + (cond + [(null? (cdr language-spec)) + (when (is-a? next-item hierarchical-list-compound-item<%>) + (error 'set-language-level! "expected no more languages after ~e, but still are, input ~e" + name in-language-spec)) + (set! found-language? #t) + (click-on-snip (send next-item get-clickable-snip))] + [else + (unless (is-a? next-item hierarchical-list-compound-item<%>) + (error 'set-language-level! "expected more languages after ~e, but got to end, input ~e" + name in-language-spec)) + (unless (send next-item is-open?) + (click-on-snip (send next-item get-arrow-snip))) + (loop next-item (cdr language-spec))])))))) + + (unless found-language? + (error 'set-language-level! "couldn't find language: ~e" in-language-spec)) + + (with-handlers ([exn:fail? (lambda (x) (void))]) + (fw:test:button-push "Show Details")) + + (fw:test:button-push "Revert to Language Defaults") + + (when close-dialog? + (fw:test:button-push "OK") + (let ([new-frame (wait-for-new-frame language-dialog)]) + (unless (eq? new-frame drs-frame) + (error 'set-language-level! + "didn't get drracket frame back, got: ~s (drs-frame ~s)\n" + new-frame + drs-frame))))))) + (define (set-module-language! [close-dialog? #t]) (not-on-eventspace-handler-thread 'set-module-language!) (let ([drs-frame (fw:test:get-active-top-level-window)]) From 77fb5ec69d56a33c67efe9109bd5efe43838da41 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 24 Oct 2012 07:58:02 -0500 Subject: [PATCH 141/221] working on something to show derivations --- collects/redex/private/show-derivations.rkt | 178 ++++++++++++++++++++ collects/redex/private/size-snip.rkt | 27 ++- collects/redex/private/traces.rkt | 9 - 3 files changed, 204 insertions(+), 10 deletions(-) create mode 100644 collects/redex/private/show-derivations.rkt diff --git a/collects/redex/private/show-derivations.rkt b/collects/redex/private/show-derivations.rkt new file mode 100644 index 0000000000..f50e0a9d28 --- /dev/null +++ b/collects/redex/private/show-derivations.rkt @@ -0,0 +1,178 @@ +#lang racket/base +(require racket/class + racket/gui/base + mrlib/graph + racket/match + racket/pretty + "size-snip.rkt" + "judgment-form.rkt") + +(provide show-derivations) + +(define sub-derivation-horizontal-gap 20) +(define sub-derivation-vertical-gap 10) ;; must be even + +(define (show-derivations derivations + #:pp [pp default-pretty-printer] + #:racket-colors? [racket-colors? #f]) + (define cw (initial-char-width)) + (define f (new frame% [label "PLT Redex Judgment Form Derivations"] [width 400] [height 400])) + (define pb (new derivation-pb%)) + (define ec (new editor-canvas% + [parent f] + [editor pb])) + (send f reflow-container) + (define top-snip (fill-derivation-pb pb (car derivations) pp racket-colors? cw)) + (define controls-panel (new vertical-panel% [parent f] [stretchable-height #f])) + + (define (set-all-cws cw) + (let loop ([snip (send pb find-first-snip)]) + (when snip + (when (is-a? snip graph-editor-snip%) + (send snip set-char-width cw)) + (loop (send snip next))))) + + (define char-width-slider + (and (number? cw) + (new slider% + [parent controls-panel] + [min-value 10] + [max-value 100] + [init-value cw] + [label "Pretty Print Width"] + [callback + (λ (_1 _2) + (send pb begin-edit-sequence) + (set-all-cws (send char-width-slider get-value)) + (send top-snip relayout-derivation pb) + (send pb end-edit-sequence))]))) + (send f show #t)) + +(define (fill-derivation-pb pb derivation pp racket-colors? cw) + (define top-snip + (let loop ([derivation derivation]) + (define children + (for/fold ([children '()]) ([sub (in-list (derivation-subs derivation))]) + (define child (loop sub)) + (cons child children))) + (define line-snip (new line-snip%)) + (define snip (make-snip (derivation-term derivation) + children + pp + racket-colors? + (get-user-char-width + cw + (derivation-term derivation)) + line-snip)) + (send snip set-derivation-children children) + (send pb insert snip) + (send pb insert line-snip) + snip)) + (send top-snip relayout-derivation pb) + top-snip) + +(define derivation-pb% + (resizing-pasteboard-mixin + (graph-pasteboard-mixin + pasteboard%))) + +(define (make-snip expr children pp code-colors? cw line-snip) + (let* ([text (new size-text%)] + [es (instantiate graph-editor-snip% () + [char-width cw] + [editor text] + [pp pp] + [expr expr] + [with-border? #f] + [line-snip line-snip])]) + (send text set-autowrap-bitmap #f) + (send text set-max-width 'none) + (send text freeze-colorer) + (unless code-colors? + (send text stop-colorer #t)) + (send es format-expr) + es)) + +(define graph-editor-snip% + (class* (graph-snip-mixin size-editor-snip%) (reflowing-snip<%>) + (define derivation-children '()) + (define/public (set-derivation-children c) (set! derivation-children c)) + (init-field line-snip) + + (define/public (relayout-derivation pb) + (define table (make-hash)) + (resize-derivation pb table) + (layout-derivation table pb 0 0)) + + (define/public (resize-derivation pb table) + (let loop ([derivation derivation]) + (define-values (children-width children-height) + (for/fold ([width 0] + [height 0]) + ([child (in-list derivation-children)]) + (define-values (this-w this-h) (send child resize-derivation pb table)) + (values (+ width this-w) + (max height this-h)))) + (define sub-derivation-width + (if (null? derivation-children) + 0 + (+ children-width (* (- (length derivation-children) + 1) + sub-derivation-horizontal-gap)))) + (define derivation-width + (max sub-derivation-width + (find-snip-width pb this))) + (define derivation-height + (+ children-height + sub-derivation-vertical-gap + (find-snip-height pb this))) + (hash-set! table this (cons derivation-width derivation-height)) + (values derivation-width derivation-height))) + + (define/public (layout-derivation table pb dx dy) + (match-define (cons derivation-width derivation-height) (hash-ref table this)) + (define my-height (find-snip-height pb this)) + (define my-width (find-snip-width pb this)) + (define my-x (+ dx (- (/ derivation-width 2) (/ my-width 2)))) + (define my-y (+ dy derivation-height (- my-height))) + (define children-width + (for/sum ([child (in-list derivation-children)]) + (car (hash-ref table child)))) + (define start-dx (+ dx (/ (- derivation-width children-width) 2))) + (send pb move-to this my-x my-y) + (send pb move-to line-snip dx (- my-y (/ sub-derivation-vertical-gap 2))) + (send line-snip set-width derivation-width) + (for/fold ([dx start-dx]) ([snip (in-list derivation-children)]) + (define that-ones-width (car (hash-ref table snip))) + (define that-ones-height (cdr (hash-ref table snip))) + (send snip layout-derivation table + pb + dx + (+ dy (- derivation-height that-ones-height my-height sub-derivation-vertical-gap))) + (+ dx that-ones-width sub-derivation-horizontal-gap))) + + (super-new))) + +(define line-snip% + (class snip% + (define width 10) + (define/public (set-width w) (set! width w)) + (define/override (draw dc x y left top right bottom dx dy draw-caret) + (send dc draw-line x y (+ x width) y)) + (define/override (get-extent dc x y wb hb db sb lb rb) + (set-box/f wb width) + (set-box/f hb 1) + (set-box/f db 0) + (set-box/f sb 0) + (set-box/f lb 0) + (set-box/f rb 0)) + (inherit set-snipclass) + (super-new) + (set-snipclass line-snipclass))) + +(define (set-box/f b v) (when (box? b) (set-box! b v))) + +(define line-snipclass (new snip-class%)) +(send line-snipclass set-classname "redex:derivation-line") +(send line-snipclass set-version 1) +(send (get-the-snip-class-list) add line-snipclass) diff --git a/collects/redex/private/size-snip.rkt b/collects/redex/private/size-snip.rkt index b4ca8bea7b..e505ba5e93 100644 --- a/collects/redex/private/size-snip.rkt +++ b/collects/redex/private/size-snip.rkt @@ -14,7 +14,9 @@ pretty-print-parameters initial-char-width resizing-pasteboard-mixin - get-user-char-width) + get-user-char-width + find-snip-height + find-snip-width) (define initial-char-width (make-parameter 30)) @@ -91,6 +93,11 @@ (inherit get-admin) (define/public (get-expr) expr) (define/public (get-char-width) char-width) + (define/public (set-char-width cw) + (unless (equal? char-width cw) + (set! char-width cw) + (format-expr) + (on-width-changed char-width))) (define/override (resize w h) (super resize w h) @@ -187,3 +194,21 @@ (editor:standard-style-list-mixin text:basic%)))))))) + + +;; find-snip-height : editor snip -> number +(define (find-snip-height ed snip) + (let ([bt (box 0)] + [bb (box 0)]) + (send ed get-snip-location snip #f bt #f) + (send ed get-snip-location snip #f bb #t) + (- (unbox bb) + (unbox bt)))) + +(define (find-snip-width ed snip) + (let ([br (box 0)] + [bl (box 0)]) + (send ed get-snip-location snip br #f #t) + (send ed get-snip-location snip bl #f #f) + (- (unbox br) + (unbox bl)))) diff --git a/collects/redex/private/traces.rkt b/collects/redex/private/traces.rkt index 35f71de5af..8688345ea8 100644 --- a/collects/redex/private/traces.rkt +++ b/collects/redex/private/traces.rkt @@ -886,15 +886,6 @@ (send ed get-snip-location snip br #f #t) (unbox br))) -;; find-snip-height : editor snip -> number -(define (find-snip-height ed snip) - (let ([bt (box 0)] - [bb (box 0)]) - (send ed get-snip-location snip #f bt #f) - (send ed get-snip-location snip #f bb #t) - (- (unbox bb) - (unbox bt)))) - (provide traces traces/ps term-node? From 4669b6bfedc608fd4fc58e4819f359efd952662b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 3 Nov 2012 15:49:33 -0500 Subject: [PATCH 142/221] adjust tests for the new language dialog (the names of the textbooks are no longer explicit in the hierarchy of the languages so just specify "Beginning Student", for example) --- collects/tests/drracket/hangman.rkt | 2 +- collects/tests/drracket/language-test.rkt | 12 ++++------ .../drracket/sample-solutions-one-window.rkt | 8 +++---- collects/tests/drracket/stepper-test.rkt | 6 ++--- .../tests/drracket/teaching-lang-coverage.rkt | 2 +- .../drracket/teaching-lang-save-file.rkt | 2 +- .../teaching-lang-sharing-modules.rkt | 2 +- collects/tests/drracket/teachpack.rkt | 6 ++--- collects/tests/drracket/test-engine-test.rkt | 24 +++++++++---------- 9 files changed, 30 insertions(+), 34 deletions(-) diff --git a/collects/tests/drracket/hangman.rkt b/collects/tests/drracket/hangman.rkt index 935c8dbe53..15e40a6d3a 100644 --- a/collects/tests/drracket/hangman.rkt +++ b/collects/tests/drracket/hangman.rkt @@ -8,7 +8,7 @@ (define drs (wait-for-drracket-frame)) (define defs (send drs get-definitions-text)) (define rep (send drs get-interactions-text)) - (set-language-level! (list #rx"How to Design Programs" #rx"Beginning Student$")) + (set-language-level! (list #rx"Beginning Student$")) (run-one/sync (lambda () (send defs load-file (collection-file-path "hangman1.rkt" "htdp" "tests")))) diff --git a/collects/tests/drracket/language-test.rkt b/collects/tests/drracket/language-test.rkt index 7bf0be20d1..1031ac4666 100644 --- a/collects/tests/drracket/language-test.rkt +++ b/collects/tests/drracket/language-test.rkt @@ -364,7 +364,7 @@ the settings above should match r5rs ; ;;;;; (define (beginner) - (parameterize ([language (list "How to Design Programs" #rx"Beginning Student(;|$)")]) + (parameterize ([language (list #rx"Beginning Student(;|$)")]) (check-top-of-repl) (generic-settings #t) (generic-output #f #f #f #f) @@ -514,8 +514,7 @@ the settings above should match r5rs (define (beginner/abbrev) - (parameterize ([language (list "How to Design Programs" - #rx"Beginning Student with List Abbreviations(;|$)")]) + (parameterize ([language (list #rx"Beginning Student with List Abbreviations(;|$)")]) (check-top-of-repl) (generic-settings #t) @@ -665,7 +664,7 @@ the settings above should match r5rs (define (intermediate) - (parameterize ([language (list "How to Design Programs" #rx"Intermediate Student(;|$)")]) + (parameterize ([language (list #rx"Intermediate Student(;|$)")]) (check-top-of-repl) (generic-settings #t) @@ -812,8 +811,7 @@ the settings above should match r5rs (define (intermediate/lambda) - (parameterize ([language (list "How to Design Programs" - #rx"Intermediate Student with lambda(;|$)")]) + (parameterize ([language (list #rx"Intermediate Student with lambda(;|$)")]) (check-top-of-repl) (generic-settings #t) @@ -955,7 +953,7 @@ the settings above should match r5rs (define (advanced) - (parameterize ([language (list "How to Design Programs" #rx"Advanced Student(;|$)")]) + (parameterize ([language (list #rx"Advanced Student(;|$)")]) (check-top-of-repl) (generic-settings #t) diff --git a/collects/tests/drracket/sample-solutions-one-window.rkt b/collects/tests/drracket/sample-solutions-one-window.rkt index 0741cf062f..b14ea744ec 100644 --- a/collects/tests/drracket/sample-solutions-one-window.rkt +++ b/collects/tests/drracket/sample-solutions-one-window.rkt @@ -13,10 +13,10 @@ (define (section->language section) (cond - [(section . <= . 12) '("How to Design Programs" "Beginning Student")] - [(section . <= . 19) '("How to Design Programs" "Intermediate Student")] - [(section . <= . 29) '("How to Design Programs" "Intermediate Student with lambda")] - [else '("How to Design Programs" "Advanced Student")])) + [(section . <= . 12) '("Beginning Student")] + [(section . <= . 19) '("Intermediate Student")] + [(section . <= . 29) '("Intermediate Student with lambda")] + [else '("Advanced Student")])) (define default-toc-entry '(#f ())) diff --git a/collects/tests/drracket/stepper-test.rkt b/collects/tests/drracket/stepper-test.rkt index ea23516201..4ebb861f3d 100644 --- a/collects/tests/drracket/stepper-test.rkt +++ b/collects/tests/drracket/stepper-test.rkt @@ -32,7 +32,7 @@ (run-fully-specified-tests) #| - (set-language-level! (list "How to Design Programs" "Beginning Student with List Abbreviations")) + (set-language-level! (list "Beginning Student with List Abbreviations")) (run-string-test "(define (f x) (* x 2))\n(+ 1 (f (+ 1 1)))") (run-string-test "(sqrt 2)") (run-string-test "(car)") @@ -42,12 +42,12 @@ ) (define (run-fully-specified-tests) - (set-language-level! (list "How to Design Programs" "Beginning Student")) + (set-language-level! (list "Beginning Student")) (beginner-tests/no-list) (test-transcript '(cons 1 (cons 2 (list 3 4 5))) '(cons 1 (cons 2 (cons 3 (cons 4 (cons 5 empty)))))) - (set-language-level! (list "How to Design Programs" "Beginning Student with List Abbreviations")) + (set-language-level! (list "Beginning Student with List Abbreviations")) (beginner-tests/no-list) (test-transcript '(cons 1 (cons 2 (list 3 4 5))) '(cons 1 (list 2 3 4 5)) diff --git a/collects/tests/drracket/teaching-lang-coverage.rkt b/collects/tests/drracket/teaching-lang-coverage.rkt index 49fff7743e..19df1430c0 100644 --- a/collects/tests/drracket/teaching-lang-coverage.rkt +++ b/collects/tests/drracket/teaching-lang-coverage.rkt @@ -96,7 +96,7 @@ (object-name this-lang)))]) (unless same-last-time? (set! last-lang this-lang) - (set-language-level! (list #rx"How to Design Programs" this-lang)))) + (set-language-level! (list this-lang)))) (clear-definitions drr-frame) (insert-in-definitions drr-frame (test-program t)) diff --git a/collects/tests/drracket/teaching-lang-save-file.rkt b/collects/tests/drracket/teaching-lang-save-file.rkt index bb182f232d..ca73cc9c13 100644 --- a/collects/tests/drracket/teaching-lang-save-file.rkt +++ b/collects/tests/drracket/teaching-lang-save-file.rkt @@ -16,7 +16,7 @@ (let ([definitions-text (send drr-frame get-definitions-text)] [interactions-text (send drr-frame get-interactions-text)]) - (set-language-level! (list #rx"How to Design Programs" #rx"Beginning Student$")) + (set-language-level! (list #rx"Beginning Student$")) (clear-definitions drr-frame) (queue-callback/res (λ () diff --git a/collects/tests/drracket/teaching-lang-sharing-modules.rkt b/collects/tests/drracket/teaching-lang-sharing-modules.rkt index 5cb312af7c..21e3ee0a77 100644 --- a/collects/tests/drracket/teaching-lang-sharing-modules.rkt +++ b/collects/tests/drracket/teaching-lang-sharing-modules.rkt @@ -36,7 +36,7 @@ Of course, other (similar) things can go wrong, too. (λ () (putenv "PLTDRHTDPNOCOMPILED" "yes") (define drs-frame (wait-for-drracket-frame)) - (set-language-level! '("How to Design Programs" "Beginning Student")) + (set-language-level! '("Beginning Student")) (clear-definitions drs-frame) (for ([exp (in-list things-to-try)]) (insert-in-definitions drs-frame (format "~s\n" exp))) diff --git a/collects/tests/drracket/teachpack.rkt b/collects/tests/drracket/teachpack.rkt index c0a5f44d0e..559104d571 100644 --- a/collects/tests/drracket/teachpack.rkt +++ b/collects/tests/drracket/teachpack.rkt @@ -158,12 +158,12 @@ "3")) (define (good-tests) - (set-language-level! '("How to Design Programs" "Beginning Student")) + (set-language-level! '("Beginning Student")) (do-execute drs-frame) (generic-tests)) (define (bad-tests) - (set-language-level! '("How to Design Programs" "Beginning Student")) + (set-language-level! '("Beginning Student")) (test-bad/execute-teachpack "undefined-id" @@ -218,7 +218,7 @@ (directory-list dir))) paths))] [teachpack-dir (normalize-path (collection-path "teachpack"))]) - (set-language-level! '("How to Design Programs" "Advanced Student")) + (set-language-level! '("Advanced Student")) (do-execute drs-frame) (test-teachpacks (list (build-path teachpack-dir "2htdp") (build-path teachpack-dir "htdp"))))) diff --git a/collects/tests/drracket/test-engine-test.rkt b/collects/tests/drracket/test-engine-test.rkt index 0407f06f2e..20c74cc262 100644 --- a/collects/tests/drracket/test-engine-test.rkt +++ b/collects/tests/drracket/test-engine-test.rkt @@ -105,7 +105,7 @@ ; ;;;;; (define (beginner) - (parameterize ([language (list "How to Design Programs" #rx"Beginning Student(;|$)")]) + (parameterize ([language (list #rx"Beginning Student(;|$)")]) (prepare-for-test-expression) (common-test-engine #f))) @@ -127,8 +127,7 @@ (define (beginner/abbrev) - (parameterize ([language (list "How to Design Programs" - #rx"Beginning Student with List Abbreviations(;|$)")]) + (parameterize ([language (list #rx"Beginning Student with List Abbreviations(;|$)")]) (prepare-for-test-expression) (common-test-engine #f))) @@ -150,7 +149,7 @@ (define (intermediate) - (parameterize ([language (list "How to Design Programs" #rx"Intermediate Student(;|$)")]) + (parameterize ([language (list #rx"Intermediate Student(;|$)")]) (prepare-for-test-expression) (common-test-engine #f))) @@ -172,8 +171,7 @@ (define (intermediate/lambda) - (parameterize ([language (list "How to Design Programs" - #rx"Intermediate Student with lambda(;|$)")]) + (parameterize ([language (list #rx"Intermediate Student with lambda(;|$)")]) (prepare-for-test-expression) (common-test-engine #f))) @@ -196,32 +194,32 @@ (define (advanced) - (parameterize ([language (list "How to Design Programs" #rx"Advanced Student(;|$)")]) + (parameterize ([language (list #rx"Advanced Student(;|$)")]) (prepare-for-test-expression) (common-test-engine #f) (common-signatures-*sl))) (define (DMdA-beginner) - (parameterize ([language (list "DeinProgramm" #rx"Die Macht der Abstraktion - Anfänger(;|$)")]) + (parameterize ([language (list #rx"Die Macht der Abstraktion - Anfänger(;|$)")]) (prepare-for-test-expression) (common-test-engine #t) (common-signatures-DMdA))) (define (DMdA-vanilla) - (parameterize ([language (list "DeinProgramm" #rx"Die Macht der Abstraktion(;|$)")]) + (parameterize ([language (list #rx"Die Macht der Abstraktion(;|$)")]) (prepare-for-test-expression) (common-test-engine #t) (common-signatures-DMdA))) (define (DMdA-assignments) - (parameterize ([language (list "DeinProgramm" #rx"Die Macht der Abstraktion mit Zuweisungen(;|$)")]) + (parameterize ([language (list #rx"Die Macht der Abstraktion mit Zuweisungen(;|$)")]) (prepare-for-test-expression) (common-test-engine #t) (common-signatures-DMdA))) (define (DMdA-advanced) - (parameterize ([language (list "DeinProgramm" #rx"Die Macht der Abstraktion - fortgeschritten(;|$)")]) + (parameterize ([language (list #rx"Die Macht der Abstraktion - fortgeschritten(;|$)")]) (prepare-for-test-expression) (common-test-engine #t) (common-signatures-DMdA))) @@ -487,13 +485,13 @@ (define (test-disabling-tests) (define drs (wait-for-drracket-frame)) - (parameterize ([language (list "How to Design Programs" #rx"Beginning Student(;|$)")]) + (parameterize ([language (list #rx"Beginning Student(;|$)")]) (prepare-for-test-expression) (test:menu-select "Racket" "Disable Tests") (test-expression "(check-expect 1 2)" "Tests disabled.") (test:menu-select "Racket" "Enable Tests")) - (parameterize ([language (list "DeinProgramm" #rx"Die Macht der Abstraktion - Anfänger(;|$)")]) + (parameterize ([language (list #rx"Die Macht der Abstraktion - Anfänger(;|$)")]) (prepare-for-test-expression) (test:menu-select "Racket" "Disable Tests") (test-expression "(check-expect 1 2)" "Tests disabled.") From a6384e7de3d314621140f666a5cc8e85fdaf3dfd Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 3 Nov 2012 15:52:01 -0500 Subject: [PATCH 143/221] Oops, didn't mean to push this one Revert "working on something to show derivations" This reverts commit 77fb5ec69d56a33c67efe9109bd5efe43838da41. --- collects/redex/private/show-derivations.rkt | 178 -------------------- collects/redex/private/size-snip.rkt | 27 +-- collects/redex/private/traces.rkt | 9 + 3 files changed, 10 insertions(+), 204 deletions(-) delete mode 100644 collects/redex/private/show-derivations.rkt diff --git a/collects/redex/private/show-derivations.rkt b/collects/redex/private/show-derivations.rkt deleted file mode 100644 index f50e0a9d28..0000000000 --- a/collects/redex/private/show-derivations.rkt +++ /dev/null @@ -1,178 +0,0 @@ -#lang racket/base -(require racket/class - racket/gui/base - mrlib/graph - racket/match - racket/pretty - "size-snip.rkt" - "judgment-form.rkt") - -(provide show-derivations) - -(define sub-derivation-horizontal-gap 20) -(define sub-derivation-vertical-gap 10) ;; must be even - -(define (show-derivations derivations - #:pp [pp default-pretty-printer] - #:racket-colors? [racket-colors? #f]) - (define cw (initial-char-width)) - (define f (new frame% [label "PLT Redex Judgment Form Derivations"] [width 400] [height 400])) - (define pb (new derivation-pb%)) - (define ec (new editor-canvas% - [parent f] - [editor pb])) - (send f reflow-container) - (define top-snip (fill-derivation-pb pb (car derivations) pp racket-colors? cw)) - (define controls-panel (new vertical-panel% [parent f] [stretchable-height #f])) - - (define (set-all-cws cw) - (let loop ([snip (send pb find-first-snip)]) - (when snip - (when (is-a? snip graph-editor-snip%) - (send snip set-char-width cw)) - (loop (send snip next))))) - - (define char-width-slider - (and (number? cw) - (new slider% - [parent controls-panel] - [min-value 10] - [max-value 100] - [init-value cw] - [label "Pretty Print Width"] - [callback - (λ (_1 _2) - (send pb begin-edit-sequence) - (set-all-cws (send char-width-slider get-value)) - (send top-snip relayout-derivation pb) - (send pb end-edit-sequence))]))) - (send f show #t)) - -(define (fill-derivation-pb pb derivation pp racket-colors? cw) - (define top-snip - (let loop ([derivation derivation]) - (define children - (for/fold ([children '()]) ([sub (in-list (derivation-subs derivation))]) - (define child (loop sub)) - (cons child children))) - (define line-snip (new line-snip%)) - (define snip (make-snip (derivation-term derivation) - children - pp - racket-colors? - (get-user-char-width - cw - (derivation-term derivation)) - line-snip)) - (send snip set-derivation-children children) - (send pb insert snip) - (send pb insert line-snip) - snip)) - (send top-snip relayout-derivation pb) - top-snip) - -(define derivation-pb% - (resizing-pasteboard-mixin - (graph-pasteboard-mixin - pasteboard%))) - -(define (make-snip expr children pp code-colors? cw line-snip) - (let* ([text (new size-text%)] - [es (instantiate graph-editor-snip% () - [char-width cw] - [editor text] - [pp pp] - [expr expr] - [with-border? #f] - [line-snip line-snip])]) - (send text set-autowrap-bitmap #f) - (send text set-max-width 'none) - (send text freeze-colorer) - (unless code-colors? - (send text stop-colorer #t)) - (send es format-expr) - es)) - -(define graph-editor-snip% - (class* (graph-snip-mixin size-editor-snip%) (reflowing-snip<%>) - (define derivation-children '()) - (define/public (set-derivation-children c) (set! derivation-children c)) - (init-field line-snip) - - (define/public (relayout-derivation pb) - (define table (make-hash)) - (resize-derivation pb table) - (layout-derivation table pb 0 0)) - - (define/public (resize-derivation pb table) - (let loop ([derivation derivation]) - (define-values (children-width children-height) - (for/fold ([width 0] - [height 0]) - ([child (in-list derivation-children)]) - (define-values (this-w this-h) (send child resize-derivation pb table)) - (values (+ width this-w) - (max height this-h)))) - (define sub-derivation-width - (if (null? derivation-children) - 0 - (+ children-width (* (- (length derivation-children) - 1) - sub-derivation-horizontal-gap)))) - (define derivation-width - (max sub-derivation-width - (find-snip-width pb this))) - (define derivation-height - (+ children-height - sub-derivation-vertical-gap - (find-snip-height pb this))) - (hash-set! table this (cons derivation-width derivation-height)) - (values derivation-width derivation-height))) - - (define/public (layout-derivation table pb dx dy) - (match-define (cons derivation-width derivation-height) (hash-ref table this)) - (define my-height (find-snip-height pb this)) - (define my-width (find-snip-width pb this)) - (define my-x (+ dx (- (/ derivation-width 2) (/ my-width 2)))) - (define my-y (+ dy derivation-height (- my-height))) - (define children-width - (for/sum ([child (in-list derivation-children)]) - (car (hash-ref table child)))) - (define start-dx (+ dx (/ (- derivation-width children-width) 2))) - (send pb move-to this my-x my-y) - (send pb move-to line-snip dx (- my-y (/ sub-derivation-vertical-gap 2))) - (send line-snip set-width derivation-width) - (for/fold ([dx start-dx]) ([snip (in-list derivation-children)]) - (define that-ones-width (car (hash-ref table snip))) - (define that-ones-height (cdr (hash-ref table snip))) - (send snip layout-derivation table - pb - dx - (+ dy (- derivation-height that-ones-height my-height sub-derivation-vertical-gap))) - (+ dx that-ones-width sub-derivation-horizontal-gap))) - - (super-new))) - -(define line-snip% - (class snip% - (define width 10) - (define/public (set-width w) (set! width w)) - (define/override (draw dc x y left top right bottom dx dy draw-caret) - (send dc draw-line x y (+ x width) y)) - (define/override (get-extent dc x y wb hb db sb lb rb) - (set-box/f wb width) - (set-box/f hb 1) - (set-box/f db 0) - (set-box/f sb 0) - (set-box/f lb 0) - (set-box/f rb 0)) - (inherit set-snipclass) - (super-new) - (set-snipclass line-snipclass))) - -(define (set-box/f b v) (when (box? b) (set-box! b v))) - -(define line-snipclass (new snip-class%)) -(send line-snipclass set-classname "redex:derivation-line") -(send line-snipclass set-version 1) -(send (get-the-snip-class-list) add line-snipclass) diff --git a/collects/redex/private/size-snip.rkt b/collects/redex/private/size-snip.rkt index e505ba5e93..b4ca8bea7b 100644 --- a/collects/redex/private/size-snip.rkt +++ b/collects/redex/private/size-snip.rkt @@ -14,9 +14,7 @@ pretty-print-parameters initial-char-width resizing-pasteboard-mixin - get-user-char-width - find-snip-height - find-snip-width) + get-user-char-width) (define initial-char-width (make-parameter 30)) @@ -93,11 +91,6 @@ (inherit get-admin) (define/public (get-expr) expr) (define/public (get-char-width) char-width) - (define/public (set-char-width cw) - (unless (equal? char-width cw) - (set! char-width cw) - (format-expr) - (on-width-changed char-width))) (define/override (resize w h) (super resize w h) @@ -194,21 +187,3 @@ (editor:standard-style-list-mixin text:basic%)))))))) - - -;; find-snip-height : editor snip -> number -(define (find-snip-height ed snip) - (let ([bt (box 0)] - [bb (box 0)]) - (send ed get-snip-location snip #f bt #f) - (send ed get-snip-location snip #f bb #t) - (- (unbox bb) - (unbox bt)))) - -(define (find-snip-width ed snip) - (let ([br (box 0)] - [bl (box 0)]) - (send ed get-snip-location snip br #f #t) - (send ed get-snip-location snip bl #f #f) - (- (unbox br) - (unbox bl)))) diff --git a/collects/redex/private/traces.rkt b/collects/redex/private/traces.rkt index 8688345ea8..35f71de5af 100644 --- a/collects/redex/private/traces.rkt +++ b/collects/redex/private/traces.rkt @@ -886,6 +886,15 @@ (send ed get-snip-location snip br #f #t) (unbox br))) +;; find-snip-height : editor snip -> number +(define (find-snip-height ed snip) + (let ([bt (box 0)] + [bb (box 0)]) + (send ed get-snip-location snip #f bt #f) + (send ed get-snip-location snip #f bb #t) + (- (unbox bb) + (unbox bt)))) + (provide traces traces/ps term-node? From 6ab4085db36e6708ddc3fbcea65ff1b5b875db6f Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Sat, 3 Nov 2012 15:36:11 -0600 Subject: [PATCH 144/221] documentation: adding data/heap examples --- collects/data/scribblings/heap.scrbl | 83 +++++++++++++++++++++++++++- 1 file changed, 82 insertions(+), 1 deletion(-) diff --git a/collects/data/scribblings/heap.scrbl b/collects/data/scribblings/heap.scrbl index 0862ebe591..7bffe723cf 100644 --- a/collects/data/scribblings/heap.scrbl +++ b/collects/data/scribblings/heap.scrbl @@ -19,64 +19,145 @@ Binary heaps are a simple implementation of priority queues. heap?]{ Makes a new empty heap using @racket[<=?] to order elements. + +@examples[#:eval the-eval +(define a-heap-of-strings (make-heap string<=?)) +a-heap-of-strings +@code:comment{With structs:} +(struct node (name val)) +(define (node<=? x y) + (<= (node-val x) (node-val y))) +(define a-heap-of-nodes (make-heap node<=?)) +a-heap-of-nodes] } @defproc[(heap? [x any/c]) boolean?]{ Returns @racket[#t] if @racket[x] is a heap, @racket[#f] otherwise. + +@examples[#:eval the-eval +(heap? (make-heap <=)) +(heap? "I am not a heap")] } @defproc[(heap-count [h heap?]) exact-nonnegative-integer?]{ Returns the number of elements in the heap. +@examples[#:eval the-eval +(define a-heap (make-heap <=)) +(heap-add-all! a-heap '(7 3 9 1 13 21 15 31)) +(heap-count a-heap) +] } @defproc[(heap-add! [h heap?] [v any/c] ...) void?]{ Adds each @racket[v] to the heap. + +@examples[#:eval the-eval +(define a-heap (make-heap <=)) +(heap-add! a-heap 2009 1009)] } + @defproc[(heap-add-all! [h heap?] [v (or/c list? vector? heap?)]) void?]{ Adds each element contained in @racket[v] to the heap, leaving @racket[v] unchanged. + +@examples[#:eval the-eval +(define heap-1 (make-heap <=)) +(define heap-2 (make-heap <=)) +(define heap-12 (make-heap <=)) +(heap-add-all! heap-1 '(3 1 4 1 5 9 2 6)) +(heap-add-all! heap-2 #(2 7 1 8 2 8 1 8)) +(heap-add-all! heap-12 heap-1) +(heap-add-all! heap-12 heap-2) +(heap-count heap-12)] } @defproc[(heap-min [h heap?]) any/c]{ Returns the least element in the heap @racket[h], according to the heap's ordering. If the heap is empty, an exception is raised. + +@examples[#:eval the-eval +(define a-heap (make-heap string<=?)) +(heap-add! a-heap "sneezy" "sleepy" "dopey" "doc" + "happy" "bashful" "grumpy") +(heap-min a-heap) + +@code:comment{Taking the min of the empty heap is an error:} +(heap-min (make-heap <=)) +] } @defproc[(heap-remove-min! [h heap?]) void?]{ Removes the least element in the heap @racket[h]. If the heap is empty, an exception is raised. + +@examples[#:eval the-eval +(define a-heap (make-heap string<=?)) +(heap-add! a-heap "fili" "fili" "oin" "gloin" "thorin" + "dwalin" "balin" "bifur" "bofur" + "bombur" "dori" "nori" "ori") +(heap-min a-heap) +(heap-remove-min! a-heap) +(heap-min a-heap)] } @defproc[(vector->heap [<=? (-> any/c any/c any/c)] [items vector?]) heap?]{ Builds a heap with the elements from @racket[items]. The vector is not modified. +@examples[#:eval the-eval +(struct item (val frequency)) +(define (item<=? x y) + (<= (item-frequency x) (item-frequency y))) +(define some-sample-items + (vector (item #\a 17) (item #\b 12) (item #\c 19))) +(define a-heap (vector->heap item<=? some-sample-items)) +] } @defproc[(heap->vector [h heap?]) vector?]{ Returns a vector containing the elements of heap @racket[h] in the heap's order. The heap is not modified. + +@examples[#:eval the-eval +(define word-heap (make-heap string<=?)) +(heap-add! word-heap "pile" "mound" "agglomerate" "cumulation") +(heap->vector word-heap) +] } @defproc[(heap-copy [h heap?]) heap?]{ Makes a copy of heap @racket[h]. + +(define word-heap (make-heap string<=?)) +(heap-add! word-heap "pile" "mound" "agglomerate" "cumulation") +(define a-copy (heap-copy word-heap)) +(heap-remove-min! a-copy) +(heap-count word-heap) +(heap-count a-copy) +] } @;{--------} -@defproc[(heap-sort! [<=? (-> any/c any/c any/c)] [v vector?]) void?]{ +@defproc[(heap-sort! [<=? (-> any/c any/c any/c)] [v (and/c vector? (not/c immutable?))]) void?]{ Sorts vector @racket[v] using the comparison function @racket[<=?]. + +@examples[#:eval the-eval +(define terms (vector "batch" "deal" "flock" "good deal" "hatful" "lot")) +(heap-sort! string<=? terms) +terms +] } From 4901c6714ee6136aeff451cc2a0bd35e3993a481 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Sat, 3 Nov 2012 15:40:15 -0600 Subject: [PATCH 145/221] documentation: correcting my broken example for heap-copy --- collects/data/scribblings/heap.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/data/scribblings/heap.scrbl b/collects/data/scribblings/heap.scrbl index 7bffe723cf..2013b7ae19 100644 --- a/collects/data/scribblings/heap.scrbl +++ b/collects/data/scribblings/heap.scrbl @@ -136,7 +136,7 @@ heap's order. The heap is not modified. @defproc[(heap-copy [h heap?]) heap?]{ Makes a copy of heap @racket[h]. - +@examples[#:eval the-eval (define word-heap (make-heap string<=?)) (heap-add! word-heap "pile" "mound" "agglomerate" "cumulation") (define a-copy (heap-copy word-heap)) From ad703025c5d2c0d254f708bad9e854ce4894907b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 2 Nov 2012 15:17:16 -0600 Subject: [PATCH 146/221] error message repair --- collects/mred/private/mrmenu.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mred/private/mrmenu.rkt b/collects/mred/private/mrmenu.rkt index 4523958c27..967c7cf73e 100644 --- a/collects/mred/private/mrmenu.rkt +++ b/collects/mred/private/mrmenu.rkt @@ -465,6 +465,6 @@ (define (menu-or-bar-parent who p) (unless (or (is-a? p internal-menu<%>) (is-a? p menu-bar%)) (unless (is-a? p menu-item-container<%>) - (raise-arguments-error (constructor-name who) "(is-a?/c menu-item-container<%>)" p)) + (raise-argument-error (constructor-name who) "(is-a?/c menu-item-container<%>)" p)) (raise-arguments-error (who->name who) "invalid parent;\n given parent is not an instance of a built-in menu item container class" "given parent" p))) From 7a256fbb726237100095823a9c4b65ce144d5b93 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 2 Nov 2012 17:05:07 -0600 Subject: [PATCH 147/221] yet another repair for backtraces Compacting of the old generation breaks backtrace info. We could try to fixup backtrace info, but it's simpler to just disable compaction. --- src/racket/gc2/newgc.c | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/racket/gc2/newgc.c b/src/racket/gc2/newgc.c index f456871d90..6faa63ca29 100644 --- a/src/racket/gc2/newgc.c +++ b/src/racket/gc2/newgc.c @@ -4596,9 +4596,12 @@ static void garbage_collect(NewGC *gc, int force_full, int switching_master, Log TIME_STEP("finalized2"); - if(gc->gc_full) - if (premaster_or_place_gc(gc) || switching_master) - do_heap_compact(gc); +#if MZ_GC_BACKTRACE + if (0) +#endif + if(gc->gc_full) + if (premaster_or_place_gc(gc) || switching_master) + do_heap_compact(gc); TIME_STEP("compacted"); /* do some cleanup structures that either change state based on the From 8079ff6c4f7a1deb0d7b5779cf6b2fd44cebb4d6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 3 Nov 2012 07:10:33 -0600 Subject: [PATCH 148/221] fix problem with prompts, call/cc, and tail-buffer allocation Merge to v5.3.1 --- src/racket/gc2/newgc.c | 21 +++++++++++++++++++++ src/racket/src/eval.c | 2 ++ src/racket/src/fun.c | 13 +++++++++++++ 3 files changed, 36 insertions(+) diff --git a/src/racket/gc2/newgc.c b/src/racket/gc2/newgc.c index 6faa63ca29..cf5667295a 100644 --- a/src/racket/gc2/newgc.c +++ b/src/racket/gc2/newgc.c @@ -1282,6 +1282,21 @@ inline static uintptr_t allocate_slowpath(NewGC *gc, size_t allocate_size, uintp return newptr; } +static void check_allocation_time_invariants() +{ +#if 0 + Scheme_Thread *p = scheme_current_thread; + if (p) { + if (p->values_buffer) { + memset(p->values_buffer, 0, sizeof(Scheme_Object*) * p->values_buffer_size); + } + if (p->tail_buffer && (p->tail_buffer != p->runstack_tmp_keep)) { + memset(p->tail_buffer, 0, sizeof(Scheme_Object*) * p->tail_buffer_size); + } + } +#endif +} + inline static void *allocate(const size_t request_size, const int type) { size_t allocate_size; @@ -1289,6 +1304,8 @@ inline static void *allocate(const size_t request_size, const int type) if(request_size == 0) return (void *) zero_sized; + check_allocation_time_invariants(); + allocate_size = COMPUTE_ALLOC_SIZE_FOR_OBJECT_SIZE(request_size); if(allocate_size > MAX_OBJECT_SIZE) return allocate_big(request_size, type); @@ -1340,6 +1357,8 @@ inline static void *fast_malloc_one_small_tagged(size_t request_size, int dirty) uintptr_t newptr; const size_t allocate_size = COMPUTE_ALLOC_SIZE_FOR_OBJECT_SIZE(request_size); + check_allocation_time_invariants(); + newptr = GC_gen0_alloc_page_ptr + allocate_size; if(OVERFLOWS_GEN0(newptr)) { @@ -1373,6 +1392,8 @@ void *GC_malloc_pair(void *car, void *cdr) void *pair; const size_t allocate_size = PAIR_SIZE_IN_BYTES; + check_allocation_time_invariants(); + newptr = GC_gen0_alloc_page_ptr + allocate_size; if(OVERFLOWS_GEN0(newptr)) { diff --git a/src/racket/src/eval.c b/src/racket/src/eval.c index 74df9a6a68..5bb62fe862 100644 --- a/src/racket/src/eval.c +++ b/src/racket/src/eval.c @@ -1628,6 +1628,8 @@ Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Sc else { GC_CAN_IGNORE Scheme_Object *vals; vals = scheme_values(num_rands, (Scheme_Object **)value); + if (SAME_OBJ(p->ku.multiple.array, p->values_buffer)) + p->values_buffer = NULL; c->value = vals; } diff --git a/src/racket/src/fun.c b/src/racket/src/fun.c index 1bdad50a0b..53df7a96bd 100644 --- a/src/racket/src/fun.c +++ b/src/racket/src/fun.c @@ -6615,6 +6615,11 @@ static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[]) p = scheme_current_thread; + if (v == SCHEME_MULTIPLE_VALUES) { + if (SAME_OBJ(p->ku.multiple.array, p->values_buffer)) + p->values_buffer = NULL; + } + restore_from_prompt(prompt); p->suspend_break = 0; @@ -6639,6 +6644,10 @@ static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[]) if (v) { /* Got a result: */ + if (v == SCHEME_MULTIPLE_VALUES) { + if (SAME_OBJ(p->ku.multiple.array, p->values_buffer)) + p->values_buffer = NULL; + } prompt_unwind_one_dw(prompt_tag); handler = NULL; } else { @@ -6706,6 +6715,10 @@ static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[]) if (SAME_OBJ(handler, scheme_values_func)) { v = scheme_values(argc, argv); + if (v == SCHEME_MULTIPLE_VALUES) { + if (SAME_OBJ(p->ku.multiple.array, p->values_buffer)) + p->values_buffer = NULL; + } handler = NULL; } else if (SCHEME_FALSEP(handler)) { if (argc == 1) { From 4c61dfc2170d10a16391022f47ad824bc542cb56 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 3 Nov 2012 08:23:13 -0600 Subject: [PATCH 149/221] fix test to not depend on network connection --- collects/tests/racket/udp.rktl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/tests/racket/udp.rktl b/collects/tests/racket/udp.rktl index ce4d45331b..6e1107d92f 100644 --- a/collects/tests/racket/udp.rktl +++ b/collects/tests/racket/udp.rktl @@ -184,7 +184,7 @@ (let () (define (q) (define s (udp-open-socket #f #f)) - (udp-bind! s #f 5999) + (udp-bind! s "127.0.0.1" 5999) s) (define s (q)) From 7ee6a814e5390e1138ce68fda35a604746f936c5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 3 Nov 2012 08:59:13 -0600 Subject: [PATCH 150/221] explicitly close evaluator for plot doc Although this shouldn't affect document rendering, since each document is run under a custodian that is shut down, it simplifies using the document individually to check for leaks. --- collects/plot/scribblings/common.rkt | 3 +++ collects/plot/scribblings/plot.scrbl | 2 ++ 2 files changed, 5 insertions(+) diff --git a/collects/plot/scribblings/common.rkt b/collects/plot/scribblings/common.rkt index 7aea29a5b9..dcfce8bd94 100644 --- a/collects/plot/scribblings/common.rkt +++ b/collects/plot/scribblings/common.rkt @@ -38,3 +38,6 @@ [plot3d-bitmap plot3d]) plot/utils))) eval)) + +(define (close-plot-eval) + (close-eval plot-eval)) diff --git a/collects/plot/scribblings/plot.scrbl b/collects/plot/scribblings/plot.scrbl index 355ec21b9c..c6c19dbcae 100644 --- a/collects/plot/scribblings/plot.scrbl +++ b/collects/plot/scribblings/plot.scrbl @@ -46,3 +46,5 @@ If you have code written for PLoT 5.1.3 or earlier, please see @secref["porting" @include-section["porting.scrbl"] @include-section["compat.scrbl"] + +@close-plot-eval[] From eaf1fd1fe5ee215fffab2ce3a423cf3e11d79dc2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 3 Nov 2012 10:26:19 -0600 Subject: [PATCH 151/221] more consistently clear the tail-call and multiple-values buffers More consistent clearing avoids a kind of space unsafety. There's just one buffer per thread, so it's difficult to turn non-clearing into a detectable leak (I wasn't abel to construct an example), but it might be possible. More practically, failing to clear the buffer can make it difficult to debug memory use. --- 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/eval.c | 34 +++++++++---- src/racket/src/fun.c | 18 +++++-- src/racket/src/jit.c | 32 +++++++----- src/racket/src/jit.h | 22 +++++--- src/racket/src/jitarith.c | 2 +- src/racket/src/jitcall.c | 90 +++++++++++++++++++++++++-------- src/racket/src/jitcommon.c | 6 +-- src/racket/src/jitinline.c | 18 +++---- src/racket/src/module.c | 6 ++- src/racket/src/schemef.h | 2 + src/racket/src/schemex.h | 1 + src/racket/src/schemex.inc | 1 + src/racket/src/schemexm.h | 1 + 17 files changed, 166 insertions(+), 71 deletions(-) diff --git a/src/racket/include/mzwin.def b/src/racket/include/mzwin.def index d38b385319..c2ca31989d 100644 --- a/src/racket/include/mzwin.def +++ b/src/racket/include/mzwin.def @@ -180,6 +180,7 @@ EXPORTS scheme_set_tail_buffer_size scheme_force_value scheme_force_one_value + scheme_ignore_result scheme_set_cont_mark scheme_push_continuation_frame scheme_pop_continuation_frame diff --git a/src/racket/include/mzwin3m.def b/src/racket/include/mzwin3m.def index 2f1e18cdfb..14d32513ce 100644 --- a/src/racket/include/mzwin3m.def +++ b/src/racket/include/mzwin3m.def @@ -180,6 +180,7 @@ EXPORTS scheme_set_tail_buffer_size scheme_force_value scheme_force_one_value + scheme_ignore_result scheme_set_cont_mark scheme_push_continuation_frame scheme_pop_continuation_frame diff --git a/src/racket/include/racket.exp b/src/racket/include/racket.exp index 551b863a13..96a6ec3778 100644 --- a/src/racket/include/racket.exp +++ b/src/racket/include/racket.exp @@ -188,6 +188,7 @@ scheme_tail_eval_expr scheme_set_tail_buffer_size scheme_force_value scheme_force_one_value +scheme_ignore_result scheme_set_cont_mark scheme_push_continuation_frame scheme_pop_continuation_frame diff --git a/src/racket/include/racket3m.exp b/src/racket/include/racket3m.exp index 5dccc8a59d..b45f182381 100644 --- a/src/racket/include/racket3m.exp +++ b/src/racket/include/racket3m.exp @@ -188,6 +188,7 @@ scheme_tail_eval_expr scheme_set_tail_buffer_size scheme_force_value scheme_force_one_value +scheme_ignore_result scheme_set_cont_mark scheme_push_continuation_frame scheme_pop_continuation_frame diff --git a/src/racket/src/eval.c b/src/racket/src/eval.c index 5bb62fe862..11161de02c 100644 --- a/src/racket/src/eval.c +++ b/src/racket/src/eval.c @@ -371,6 +371,18 @@ void scheme_init_eval_places() #endif } +XFORM_NONGCING static void ignore_result(Scheme_Object *v) +{ + if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES)) { + scheme_current_thread->ku.multiple.array = NULL; + } +} + +void scheme_ignore_result(Scheme_Object *v) +{ + ignore_result(v); +} + /*========================================================================*/ /* C stack and Scheme stack handling */ /*========================================================================*/ @@ -1903,9 +1915,9 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro, int is_st; values = scheme_current_thread->ku.multiple.array; - scheme_current_thread->ku.multiple.array = NULL; if (SAME_OBJ(values, scheme_current_thread->values_buffer)) scheme_current_thread->values_buffer = NULL; + scheme_current_thread->ku.multiple.array = NULL; if (dm_env) is_st = 0; @@ -1946,10 +1958,10 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro, scheme_pop_prefix(save_runstack); return scheme_void; + } else { + if (SAME_OBJ(scheme_current_thread->ku.multiple.array, scheme_current_thread->values_buffer)) + scheme_current_thread->values_buffer = NULL; } - - if (SAME_OBJ(scheme_current_thread->ku.multiple.array, scheme_current_thread->values_buffer)) - scheme_current_thread->values_buffer = NULL; } else if (SCHEME_VEC_SIZE(vec) == delta + 1) { /* => single var */ var = SCHEME_VEC_ELS(vec)[delta]; if (dm_env) { @@ -2096,6 +2108,7 @@ static Scheme_Object *apply_values_execute(Scheme_Object *data) v = _scheme_eval_linked_expr_multi(SCHEME_PTR2_VAL(data)); if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES)) { Scheme_Thread *p = scheme_current_thread; + Scheme_Object **rands; int num_rands = p->ku.multiple.count; if (num_rands > p->tail_buffer_size) { @@ -2103,7 +2116,9 @@ static Scheme_Object *apply_values_execute(Scheme_Object *data) if (SAME_OBJ(p->ku.multiple.array, p->values_buffer)) p->values_buffer = NULL; } - return scheme_tail_apply(f, num_rands, p->ku.multiple.array); + rands = p->ku.multiple.array; + p->ku.multiple.array = NULL; + return scheme_tail_apply(f, num_rands, rands); } else { Scheme_Object *a[1]; a[0] = v; @@ -2223,7 +2238,7 @@ static Scheme_Object *begin0_execute(Scheme_Object *obj) apos = 1; while (i--) { - (void)_scheme_eval_linked_expr_multi(((Scheme_Sequence *)obj)->array[apos++]); + ignore_result(_scheme_eval_linked_expr_multi(((Scheme_Sequence *)obj)->array[apos++])); } if (mv) { @@ -2247,7 +2262,7 @@ static Scheme_Object *splice_execute(Scheme_Object *data) int i, cnt = seq->count - 1; for (i = 0; i < cnt; i++) { - (void)_scheme_call_with_prompt_multi(splice_one_expr, seq->array[i]); + ignore_result(_scheme_call_with_prompt_multi(splice_one_expr, seq->array[i])); } return _scheme_eval_linked_expr_multi(seq->array[cnt]); @@ -2327,7 +2342,7 @@ do_define_syntaxes_execute(Scheme_Object *form, Scheme_Env *dm_env) save_runstack = scheme_push_prefix(dm_env->exp_env, rp, NULL, NULL, 1, 1, NULL, scheme_false); while (!SCHEME_NULLP(form)) { - (void)scheme_eval_linked_expr_multi_with_dynamic_state(SCHEME_CAR(form), &dyn_state); + ignore_result(scheme_eval_linked_expr_multi_with_dynamic_state(SCHEME_CAR(form), &dyn_state)); form = SCHEME_CDR(form); } @@ -3407,7 +3422,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, UPDATE_THREAD_RSPTR(); for (i = 0; i < cnt; i++) { - (void)_scheme_eval_linked_expr_multi_wp(((Scheme_Sequence *)obj)->array[i], p); + ignore_result(_scheme_eval_linked_expr_multi_wp(((Scheme_Sequence *)obj)->array[i], p)); } obj = ((Scheme_Sequence *)obj)->array[cnt]; @@ -5192,6 +5207,7 @@ static Scheme_Object *do_eval_string_all(Scheme_Object *port, const char *str, S if (SAME_OBJ(p->ku.multiple.array, p->values_buffer)) p->values_buffer = NULL; a = p->ku.multiple.array; + p->ku.multiple.array = NULL; cnt = p->ku.multiple.count; } else { _a[0] = result; diff --git a/src/racket/src/fun.c b/src/racket/src/fun.c index 53df7a96bd..18ed6524e5 100644 --- a/src/racket/src/fun.c +++ b/src/racket/src/fun.c @@ -3402,7 +3402,8 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread; c = p->ku.multiple.count; argv2 = p->ku.multiple.array; - if (SAME_OBJ(p->ku.multiple.array, p->values_buffer)) { + p->ku.multiple.array = NULL; + if (SAME_OBJ(argv2, p->values_buffer)) { if (c <= MAX_QUICK_CHAP_ARGV) { for (i = 0; i < c; i++) { a2[i] = argv2[i]; @@ -3544,6 +3545,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object p->values_buffer = NULL; c = p->ku.multiple.count; argv = p->ku.multiple.array; + p->ku.multiple.array = NULL; } else { c = 1; a[0] = v; @@ -3575,6 +3577,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object p->values_buffer = NULL; argc = p->ku.multiple.count; argv2 = p->ku.multiple.array; + p->ku.multiple.array = NULL; } else { argc = 1; a2[0] = v; @@ -3713,9 +3716,9 @@ static Scheme_Object *call_with_values(int argc, Scheme_Object *argv[]) Scheme_Object **a; if (SAME_OBJ(p->ku.multiple.array, p->values_buffer)) p->values_buffer = NULL; - /* Beware: the fields overlap! */ n = p->ku.multiple.count; a = p->ku.multiple.array; + p->ku.multiple.array = NULL; p->ku.apply.tail_num_rands = n; p->ku.apply.tail_rands = a; } else { @@ -5110,6 +5113,7 @@ static void restore_continuation(Scheme_Cont *cont, Scheme_Thread *p, int for_pr mc = p->ku.multiple.count; if (SAME_OBJ(mv, p->values_buffer)) p->values_buffer = NULL; + p->ku.multiple.array = NULL; } else { mv = NULL; mc = 0; @@ -6394,6 +6398,7 @@ static Scheme_Object **chaperone_do_control(const char *name, int mode, p->values_buffer = NULL; num_args = p->ku.multiple.count; vals = p->ku.multiple.array; + p->ku.multiple.array = NULL; } else { num_args = 1; vals = MALLOC_N(Scheme_Object *, 1); @@ -6470,6 +6475,7 @@ static Scheme_Object *do_cc_guard(Scheme_Object *v, Scheme_Object *cc_guard, Sch p->values_buffer = NULL; argc = p->ku.multiple.count; argv = p->ku.multiple.array; + p->ku.multiple.array = NULL; } else { a[0] = v; argv = a; @@ -8591,7 +8597,7 @@ static void pre_post_dyn_wind(Scheme_Object *prepost) scheme_push_break_enable(&cframe, 0, 0); /* Here's the main call: */ - (void)_scheme_apply_multi(prepost, 0, NULL); + scheme_ignore_result(_scheme_apply_multi(prepost, 0, NULL)); scheme_pop_break_enable(&cframe, 0); @@ -9441,10 +9447,12 @@ static Scheme_Object *time_apply(int argc, Scheme_Object *argv[]) if (v == SCHEME_MULTIPLE_VALUES) { Scheme_Thread *cp = scheme_current_thread; + Scheme_Object **args; if (SAME_OBJ(cp->ku.multiple.array, cp->values_buffer)) cp->values_buffer = NULL; - v = scheme_build_list(cp->ku.multiple.count, - cp->ku.multiple.array); + args = cp->ku.multiple.array; + cp->ku.multiple.array = NULL; + v = scheme_build_list(cp->ku.multiple.count, args); } else v = scheme_make_pair(v, scheme_null); diff --git a/src/racket/src/jit.c b/src/racket/src/jit.c index a2015760b5..d8bf71e3e6 100644 --- a/src/racket/src/jit.c +++ b/src/racket/src/jit.c @@ -2276,9 +2276,13 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w (void)jit_jmpi(refloop); CHECK_LIMIT(); mz_patch_branch(ref3); + /* clear array pointer and re-laod argc: */ (void)mz_tl_ldi_p(JIT_R0, tl_scheme_current_thread); + (void)jit_movi_p(JIT_R1, NULL); + jit_stxi_l(&((Scheme_Thread *)0x0)->ku.multiple.array, JIT_R0, JIT_R1); jit_ldxi_l(JIT_R0, JIT_R0, &((Scheme_Thread *)0x0)->ku.multiple.count); - + CHECK_LIMIT(); + /* Perform call --------------------- */ /* Function is in V1, argc in R0, args on RUNSTACK */ mz_patch_ucbranch(ref2); @@ -2286,16 +2290,18 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w if (is_tail) { if (!sjc.shared_tail_argc_code) { - sjc.shared_tail_argc_code = scheme_generate_shared_call(-1, jitter, 1, 1, 0, 0, 0, 0); + sjc.shared_tail_argc_code = scheme_generate_shared_call(-1, jitter, 1, 0, 1, 0, 0, 0, 0); } mz_set_local_p(JIT_R0, JIT_LOCAL2); (void)jit_jmpi(sjc.shared_tail_argc_code); } else { - int mo = multi_ok ? 1 : 0; + int mo = (multi_ok + ? (result_ignored ? SHARED_RESULT_IGNORED_CASE : SHARED_MULTI_OK_CASE) + : SHARED_SINGLE_VALUE_CASE); void *code; if (!sjc.shared_non_tail_argc_code[mo]) { - scheme_ensure_retry_available(jitter, multi_ok); - code = scheme_generate_shared_call(-2, jitter, multi_ok, 0, 0, 0, 0, 0); + scheme_ensure_retry_available(jitter, multi_ok, result_ignored); + code = scheme_generate_shared_call(-2, jitter, multi_ok, result_ignored, 0, 0, 0, 0, 0); sjc.shared_non_tail_argc_code[mo] = code; } code = sjc.shared_non_tail_argc_code[mo]; @@ -2438,7 +2444,7 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w return r; } - r = scheme_generate_app(app, NULL, app->num_args, jitter, is_tail, multi_ok, 0); + r = scheme_generate_app(app, NULL, app->num_args, jitter, is_tail, multi_ok, result_ignored, 0); CHECK_LIMIT(); if (target != JIT_R0) @@ -2468,7 +2474,7 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w args[0] = app->rator; args[1] = app->rand; - r = scheme_generate_app(NULL, args, 1, jitter, is_tail, multi_ok, 0); + r = scheme_generate_app(NULL, args, 1, jitter, is_tail, multi_ok, result_ignored, 0); CHECK_LIMIT(); if (target != JIT_R0) @@ -2499,7 +2505,7 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w args[1] = app->rand1; args[2] = app->rand2; - r = scheme_generate_app(NULL, args, 2, jitter, is_tail, multi_ok, 0); + r = scheme_generate_app(NULL, args, 2, jitter, is_tail, multi_ok, result_ignored, 0); CHECK_LIMIT(); if (target != JIT_R0) @@ -2601,9 +2607,9 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w /* Did we get multiple results? If not, go to error: */ ref = jit_bnei_p(jit_forward(), JIT_R0, SCHEME_MULTIPLE_VALUES); /* Load count and result array: */ - mz_tl_ldi_p(JIT_R2, tl_scheme_current_thread); - jit_ldxi_l(JIT_R1, JIT_R2, &((Scheme_Thread *)0x0)->ku.multiple.count); - jit_ldxi_p(JIT_R2, JIT_R2, &((Scheme_Thread *)0x0)->ku.multiple.array); + mz_tl_ldi_p(JIT_V1, tl_scheme_current_thread); + jit_ldxi_p(JIT_R2, JIT_V1, &((Scheme_Thread *)0x0)->ku.multiple.array); + jit_ldxi_l(JIT_R1, JIT_V1, &((Scheme_Thread *)0x0)->ku.multiple.count); CHECK_LIMIT(); /* If we got the expected count, jump to installing values: */ ref2 = jit_beqi_i(jit_forward(), JIT_R1, lv->count); @@ -2630,9 +2636,11 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w (void)mz_finish_lwe(ts_lexical_binding_wrong_return_arity, ref); CHECK_LIMIT(); - /* Continue with expected values; R2 has value array: */ + /* Continue with expected values; R2 has values and V1 has thread pointer: */ mz_patch_branch(ref2); __END_SHORT_JUMPS__(1); + (void)jit_movi_p(JIT_R0, NULL); + jit_stxi_p(&((Scheme_Thread *)0x0)->ku.multiple.array, JIT_V1, JIT_R0); for (i = 0; i < lv->count; i++) { jit_ldxi_p(JIT_R1, JIT_R2, WORDS_TO_BYTES(i)); if (ab) { diff --git a/src/racket/src/jit.h b/src/racket/src/jit.h index 73d9459fb5..0bd01ae12b 100644 --- a/src/racket/src/jit.h +++ b/src/racket/src/jit.h @@ -210,9 +210,13 @@ struct scheme_jit_common_record { #define MAX_SHARED_CALL_RANDS 25 void *shared_tail_code[4][MAX_SHARED_CALL_RANDS]; - void *shared_non_tail_code[5][MAX_SHARED_CALL_RANDS][2]; - void *shared_non_tail_retry_code[2]; - void *shared_non_tail_argc_code[2]; +# define SHARED_SINGLE_VALUE_CASE 0 +# define SHARED_MULTI_OK_CASE 1 +# define SHARED_RESULT_IGNORED_CASE 2 +# define SHARED_NUM_NONTAIL_CASES 3 + void *shared_non_tail_code[5][MAX_SHARED_CALL_RANDS][SHARED_NUM_NONTAIL_CASES]; + void *shared_non_tail_retry_code[SHARED_NUM_NONTAIL_CASES]; + void *shared_non_tail_argc_code[SHARED_NUM_NONTAIL_CASES]; void *shared_tail_argc_code; #define MAX_SHARED_ARITY_CHECK 25 @@ -1228,15 +1232,17 @@ int scheme_generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj typedef struct jit_direct_arg jit_direct_arg; -void *scheme_generate_shared_call(int num_rands, mz_jit_state *old_jitter, int multi_ok, int is_tail, - int direct_prim, int direct_native, int nontail_self, int unboxed_args); -void scheme_ensure_retry_available(mz_jit_state *jitter, int multi_ok); +void *scheme_generate_shared_call(int num_rands, mz_jit_state *old_jitter, int multi_ok, int result_ignored, + int is_tail, int direct_prim, int direct_native, int nontail_self, int unboxed_args); +void scheme_ensure_retry_available(mz_jit_state *jitter, int multi_ok, int result_ignored); int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_rands, - mz_jit_state *jitter, int is_tail, int multi_ok, int no_call); + mz_jit_state *jitter, int is_tail, int multi_ok, int ignored_result, + int no_call); int scheme_generate_tail_call(mz_jit_state *jitter, int num_rands, int direct_native, int need_set_rs, int is_inline, Scheme_Native_Closure *direct_to_code, jit_direct_arg *direct_arg); int scheme_generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direct_native, int need_set_rs, - int multi_ok, int nontail_self, int pop_and_jump, int is_inlined, int unboxed_args); + int multi_ok, int result_ignored, int nontail_self, int pop_and_jump, + int is_inlined, int unboxed_args); int scheme_generate_finish_tail_call(mz_jit_state *jitter, int direct_native); int scheme_generate_finish_apply(mz_jit_state *jitter); int scheme_generate_finish_multi_apply(mz_jit_state *jitter); diff --git a/src/racket/src/jitarith.c b/src/racket/src/jitarith.c index 8d6d2e7486..9cf7ce4994 100644 --- a/src/racket/src/jitarith.c +++ b/src/racket/src/jitarith.c @@ -1920,7 +1920,7 @@ int scheme_generate_nary_arith(mz_jit_state *jitter, Scheme_App_Rec *app, } if (stack_c) - scheme_generate_app(app, alt_args, stack_c, jitter, 0, 0, 2); + scheme_generate_app(app, alt_args, stack_c, jitter, 0, 0, 0, 2); CHECK_LIMIT(); mz_rs_sync(); diff --git a/src/racket/src/jitcall.c b/src/racket/src/jitcall.c index bfbda3673a..a9200b65fa 100644 --- a/src/racket/src/jitcall.c +++ b/src/racket/src/jitcall.c @@ -604,7 +604,8 @@ static int generate_direct_prim_non_tail_call(mz_jit_state *jitter, int num_rand return 1; } -static int generate_retry_call(mz_jit_state *jitter, int num_rands, int multi_ok, GC_CAN_IGNORE jit_insn *reftop) +static int generate_retry_call(mz_jit_state *jitter, int num_rands, int multi_ok, int result_ignored, + GC_CAN_IGNORE jit_insn *reftop) /* If num_rands < 0, original argc is in V1, and we should pop argc arguments off runstack before pushing more. This function is called with short jumps enabled. */ @@ -612,7 +613,10 @@ static int generate_retry_call(mz_jit_state *jitter, int num_rands, int multi_ok GC_CAN_IGNORE jit_insn *ref, *ref2, *refloop; if (!reftop) { - reftop = sjc.shared_non_tail_retry_code[multi_ok ? 1 : 0]; + int mo = (multi_ok + ? (result_ignored ? SHARED_RESULT_IGNORED_CASE : SHARED_MULTI_OK_CASE) + : SHARED_SINGLE_VALUE_CASE); + reftop = sjc.shared_non_tail_retry_code[mo]; } /* Get new argc: */ @@ -637,7 +641,7 @@ static int generate_retry_call(mz_jit_state *jitter, int num_rands, int multi_ok /* Copy arguments to runstack, then jump to reftop. */ jit_ldxi_l(JIT_R2, JIT_R1, &((Scheme_Thread *)0x0)->ku.apply.tail_num_rands); - jit_ldxi_l(JIT_V1, JIT_R1, &((Scheme_Thread *)0x0)->ku.apply.tail_rands); + jit_ldxi_p(JIT_V1, JIT_R1, &((Scheme_Thread *)0x0)->ku.apply.tail_rands); jit_lshi_l(JIT_R2, JIT_R2, JIT_LOG_WORD_SIZE); CHECK_LIMIT(); refloop = _jit.x.pc; @@ -648,10 +652,15 @@ static int generate_retry_call(mz_jit_state *jitter, int num_rands, int multi_ok (void)jit_jmpi(refloop); CHECK_LIMIT(); + /* Clear tail-call arguments pointer: */ + (void)jit_movi_p(JIT_V1, NULL); + jit_stxi_p(&((Scheme_Thread *)0x0)->ku.apply.tail_rands, JIT_R1, JIT_V1); + CHECK_LIMIT(); + /* R1 is still the thread. Put procedure and argc in place, then jump to apply: */ mz_patch_branch(ref2); - jit_ldxi_l(JIT_V1, JIT_R1, &((Scheme_Thread *)0x0)->ku.apply.tail_rator); + jit_ldxi_p(JIT_V1, JIT_R1, &((Scheme_Thread *)0x0)->ku.apply.tail_rator); jit_ldxi_l(JIT_R0, JIT_R1, &((Scheme_Thread *)0x0)->ku.apply.tail_num_rands); __END_SHORT_JUMPS__(1); (void)jit_jmpi(reftop); @@ -690,9 +699,28 @@ static int generate_clear_slow_previous_args(mz_jit_state *jitter) return 1; } +static int generate_ignored_result_check(mz_jit_state *jitter) +{ + /* if multiple results, need to clear ignored result in thread */ + GC_CAN_IGNORE jit_insn *refm; + + __START_INNER_TINY__(1); + + refm = jit_bnei_p(jit_forward(), JIT_R0, SCHEME_MULTIPLE_VALUES); + mz_tl_ldi_p(JIT_R1, tl_scheme_current_thread); + (void)jit_movi_p(JIT_R0, NULL); + jit_stxi_p(&((Scheme_Thread *)0x0)->ku.multiple.array, JIT_R1, JIT_R0); + (void)jit_movi_p(JIT_R0, scheme_void); + mz_patch_branch(refm); + + __END_INNER_TINY__(1); + + return 1; +} + int scheme_generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direct_native, int need_set_rs, - int multi_ok, int nontail_self, int pop_and_jump, int is_inlined, - int unboxed_args) + int multi_ok, int result_ignored, int nontail_self, int pop_and_jump, + int is_inlined, int unboxed_args) { /* Non-tail call. Proc is in V1, args are at RUNSTACK. @@ -876,7 +904,7 @@ int scheme_generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc CHECK_LIMIT(); if (pop_and_jump) { /* Expects argc in V1 if num_rands < 0: */ - generate_retry_call(jitter, num_rands, multi_ok, reftop); + generate_retry_call(jitter, num_rands, multi_ok, result_ignored, reftop); } CHECK_LIMIT(); if (need_set_rs) { @@ -939,7 +967,7 @@ int scheme_generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc CHECK_LIMIT(); if (pop_and_jump) { /* Expects argc in V1 if num_rands < 0: */ - generate_retry_call(jitter, num_rands, multi_ok, reftop); + generate_retry_call(jitter, num_rands, multi_ok, result_ignored, reftop); } CHECK_LIMIT(); if (num_rands < 0) { @@ -1023,6 +1051,10 @@ int scheme_generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc mz_patch_branch(ref6); if (!direct_native) { mz_patch_branch(ref10); + if (result_ignored) { + generate_ignored_result_check(jitter); + CHECK_LIMIT(); + } } /* Note: same return code is above for faster common-case return */ if (num_rands < 0) { @@ -1237,6 +1269,7 @@ typedef struct { int num_rands; mz_jit_state *old_jitter; int multi_ok; + int result_ignored; int is_tail; int direct_prim, direct_native, nontail_self, unboxed_args; } Generate_Call_Data; @@ -1295,7 +1328,8 @@ static int do_generate_shared_call(mz_jit_state *jitter, void *_data) ok = generate_direct_prim_non_tail_call(jitter, data->num_rands, data->multi_ok, 1); else ok = scheme_generate_non_tail_call(jitter, data->num_rands, data->direct_native, 1, - data->multi_ok, data->nontail_self, 1, 0, data->unboxed_args); + data->multi_ok, data->result_ignored, data->nontail_self, + 1, 0, data->unboxed_args); scheme_jit_register_sub_func(jitter, code, scheme_false); @@ -1303,14 +1337,16 @@ static int do_generate_shared_call(mz_jit_state *jitter, void *_data) } } -void *scheme_generate_shared_call(int num_rands, mz_jit_state *old_jitter, int multi_ok, int is_tail, - int direct_prim, int direct_native, int nontail_self, int unboxed_args) +void *scheme_generate_shared_call(int num_rands, mz_jit_state *old_jitter, int multi_ok, int result_ignored, + int is_tail, int direct_prim, int direct_native, int nontail_self, + int unboxed_args) { Generate_Call_Data data; data.num_rands = num_rands; data.old_jitter = old_jitter; data.multi_ok = multi_ok; + data.result_ignored = result_ignored; data.is_tail = is_tail; data.direct_prim = direct_prim; data.direct_native = direct_native; @@ -1320,12 +1356,14 @@ void *scheme_generate_shared_call(int num_rands, mz_jit_state *old_jitter, int m return scheme_generate_one(old_jitter, do_generate_shared_call, &data, 0, NULL, NULL); } -void scheme_ensure_retry_available(mz_jit_state *jitter, int multi_ok) +void scheme_ensure_retry_available(mz_jit_state *jitter, int multi_ok, int result_ignored) { - int mo = multi_ok ? 1 : 0; + int mo = (multi_ok + ? (result_ignored ? SHARED_RESULT_IGNORED_CASE : SHARED_MULTI_OK_CASE) + : SHARED_SINGLE_VALUE_CASE); if (!sjc.shared_non_tail_retry_code[mo]) { void *code; - code = scheme_generate_shared_call(-1, jitter, multi_ok, 0, 0, 0, 0, 0); + code = scheme_generate_shared_call(-1, jitter, multi_ok, result_ignored, 0, 0, 0, 0, 0); sjc.shared_non_tail_retry_code[mo] = code; } } @@ -1586,7 +1624,8 @@ static int generate_call_path_with_unboxes(mz_jit_state *jitter, int direct_flos #endif int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_rands, - mz_jit_state *jitter, int is_tail, int multi_ok, int no_call) + mz_jit_state *jitter, int is_tail, int multi_ok, int result_ignored, + int no_call) /* de-sync'd ok If no_call is 2, then rator is not necssarily evaluated. If no_call is 1, then rator is left in V1 and arguments are on runstack. */ @@ -1624,6 +1663,8 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ if ((num_rands >= 2) && SAME_OBJ(rator, scheme_apply_proc)) apply_to_list = 1; } + if (!(((Scheme_Primitive_Proc *)rator)->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)) + result_ignored = 0; /* don't need to check for multiple values to ignore */ } else { Scheme_Type t; t = SCHEME_TYPE(rator); @@ -1970,7 +2011,7 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ generate_nontail_self_setup(jitter); } scheme_generate_non_tail_call(jitter, num_rands, direct_native, jitter->need_set_rs, - multi_ok, nontail_self, 0, 1, 0); + multi_ok, result_ignored, nontail_self, 0, 1, 0); } } } else { @@ -1981,7 +2022,8 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ if (is_tail) { if (!sjc.shared_tail_code[dp][num_rands]) { - code = scheme_generate_shared_call(num_rands, jitter, multi_ok, is_tail, direct_prim, direct_native, 0, 0); + code = scheme_generate_shared_call(num_rands, jitter, multi_ok, result_ignored, is_tail, + direct_prim, direct_native, 0, 0); sjc.shared_tail_code[dp][num_rands] = code; } code = sjc.shared_tail_code[dp][num_rands]; @@ -2024,7 +2066,9 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ } } } else { - int mo = (multi_ok ? 1 : 0); + int mo = (multi_ok + ? (result_ignored ? SHARED_RESULT_IGNORED_CASE : SHARED_MULTI_OK_CASE) + : SHARED_SINGLE_VALUE_CASE); #ifdef USE_FLONUM_UNBOXING void *unboxed_code; #endif @@ -2035,8 +2079,9 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ #ifdef USE_FLONUM_UNBOXING if (unboxed_non_tail_args) { if (!sjc.shared_non_tail_code[4][num_rands][mo]) { - scheme_ensure_retry_available(jitter, multi_ok); - code = scheme_generate_shared_call(num_rands, jitter, multi_ok, is_tail, direct_prim, direct_native, nontail_self, 1); + scheme_ensure_retry_available(jitter, multi_ok, result_ignored); + code = scheme_generate_shared_call(num_rands, jitter, multi_ok, result_ignored, is_tail, + direct_prim, direct_native, nontail_self, 1); sjc.shared_non_tail_code[4][num_rands][mo] = code; } unboxed_code = sjc.shared_non_tail_code[4][num_rands][mo]; @@ -2045,8 +2090,9 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ #endif if (!sjc.shared_non_tail_code[dp][num_rands][mo]) { - scheme_ensure_retry_available(jitter, multi_ok); - code = scheme_generate_shared_call(num_rands, jitter, multi_ok, is_tail, direct_prim, direct_native, nontail_self, 0); + scheme_ensure_retry_available(jitter, multi_ok, result_ignored); + code = scheme_generate_shared_call(num_rands, jitter, multi_ok, result_ignored, is_tail, + direct_prim, direct_native, nontail_self, 0); sjc.shared_non_tail_code[dp][num_rands][mo] = code; } LOG_IT(("<-non-tail %d %d %d\n", dp, num_rands, mo)); diff --git a/src/racket/src/jitcommon.c b/src/racket/src/jitcommon.c index c338efc6be..5d7f9e0e00 100644 --- a/src/racket/src/jitcommon.c +++ b/src/racket/src/jitcommon.c @@ -979,7 +979,7 @@ static int generate_apply_proxy(mz_jit_state *jitter, int setter) CHECK_LIMIT(); JIT_UPDATE_THREAD_RSPTR(); __END_SHORT_JUMPS__(1); - scheme_generate_non_tail_call(jitter, 3, 0, 0, 0, 0, 0, 1, 0); + scheme_generate_non_tail_call(jitter, 3, 0, 0, 0, 0, 0, 0, 1, 0); __START_SHORT_JUMPS__(1); CHECK_LIMIT(); if (setter) { @@ -3041,7 +3041,7 @@ static int more_common0(mz_jit_state *jitter, void *_data) mz_rs_sync(); __END_SHORT_JUMPS__(1); - scheme_generate_non_tail_call(jitter, 2, 0, 1, 0, 0, 0, 0, 0); + scheme_generate_non_tail_call(jitter, 2, 0, 1, 0, 0, 0, 0, 0, 0); CHECK_LIMIT(); __START_SHORT_JUMPS__(1); @@ -3476,7 +3476,7 @@ static int more_common1(mz_jit_state *jitter, void *_data) __END_SHORT_JUMPS__(1); - scheme_generate_non_tail_call(jitter, -1, 0, 1, multi_ok, 0, 1, 0, 0); + scheme_generate_non_tail_call(jitter, -1, 0, 1, multi_ok, 0, 0, 1, 0, 0); scheme_jit_register_sub_func(jitter, code, scheme_false); } diff --git a/src/racket/src/jitinline.c b/src/racket/src/jitinline.c index a601bf54a0..8f9cbab4cc 100644 --- a/src/racket/src/jitinline.c +++ b/src/racket/src/jitinline.c @@ -383,7 +383,7 @@ static int generate_inlined_struct_op(int kind, mz_jit_state *jitter, args[0] = rator; args[1] = rand; args[2] = rand2; - scheme_generate_app(NULL, args, 2, jitter, 0, 0, 1); /* sync'd below */ + scheme_generate_app(NULL, args, 2, jitter, 0, 0, 0, 1); /* sync'd below */ CHECK_LIMIT(); jit_movr_p(JIT_R0, JIT_V1); mz_rs_ldr(JIT_R1); @@ -600,7 +600,7 @@ static int generate_inlined_nary_struct_op(int kind, mz_jit_state *jitter, /* de-sync'd ok; for branch, sync'd before */ { /* generate code to evaluate the arguments */ - scheme_generate_app(app, NULL, app->num_args, jitter, 0, 0, 1); + scheme_generate_app(app, NULL, app->num_args, jitter, 0, 0, 0, 1); CHECK_LIMIT(); mz_rs_sync(); @@ -3165,7 +3165,7 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i args[1] = app->rand1; args[2] = app->rand2; - scheme_generate_app(NULL, args, 2, jitter, 0, 0, 2); + scheme_generate_app(NULL, args, 2, jitter, 0, 0, 0, 2); CHECK_LIMIT(); mz_rs_sync(); @@ -3271,7 +3271,7 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int } /* generate code to evaluate the arguments */ - scheme_generate_app(app, NULL, 3, jitter, 0, 0, 2); + scheme_generate_app(app, NULL, 3, jitter, 0, 0, 0, 2); CHECK_LIMIT(); mz_rs_sync(); @@ -3680,7 +3680,7 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int } else { got_two = 1; mz_runstack_skipped(jitter, 1); - scheme_generate_app(app, NULL, 2, jitter, 0, 0, 2); + scheme_generate_app(app, NULL, 2, jitter, 0, 0, 0, 2); } if (scheme_can_unbox_inline(app->args[3], 5, JIT_FPR_NUM-1, 1)) @@ -3737,7 +3737,7 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int star = IS_NAMED_PRIM(rator, "list*"); if (c) - scheme_generate_app(app, NULL, c, jitter, 0, 0, 2); + scheme_generate_app(app, NULL, c, jitter, 0, 0, 0, 2); CHECK_LIMIT(); mz_rs_sync(); @@ -3775,7 +3775,7 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int if (!multi_ok) return 0; if (c) { - scheme_generate_app(app, NULL, c, jitter, 0, 0, 2); + scheme_generate_app(app, NULL, c, jitter, 0, 0, 0, 2); CHECK_LIMIT(); mz_rs_sync(); @@ -3812,7 +3812,7 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int } else if (IS_NAMED_PRIM(rator, "max")) { return scheme_generate_nary_arith(jitter, app, ARITH_MAX, 0, NULL, 1); } else if (IS_NAMED_PRIM(rator, "checked-procedure-check-and-extract")) { - scheme_generate_app(app, NULL, 5, jitter, 0, 0, 2); /* sync'd below */ + scheme_generate_app(app, NULL, 5, jitter, 0, 0, 0, 2); /* sync'd below */ CHECK_LIMIT(); mz_rs_sync(); @@ -3893,7 +3893,7 @@ static int generate_vector_alloc(mz_jit_state *jitter, Scheme_Object *rator, } else { c = app->num_args; if (c) - scheme_generate_app(app, NULL, c, jitter, 0, 0, 2); /* sync'd below */ + scheme_generate_app(app, NULL, c, jitter, 0, 0, 0, 2); /* sync'd below */ } CHECK_LIMIT(); diff --git a/src/racket/src/module.c b/src/racket/src/module.c index 0b8223c5fc..b9bebb5c5d 100644 --- a/src/racket/src/module.c +++ b/src/racket/src/module.c @@ -5536,7 +5536,9 @@ static Scheme_Object *body_one_expr(void *prefix_plus_expr, int argc, Scheme_Obj v = _scheme_eval_linked_expr_multi(SCHEME_CDR((Scheme_Object *)prefix_plus_expr)); scheme_suspend_prefix(saved_runstack); - return v; + scheme_ignore_result(v); + + return scheme_void; } static int needs_prompt(Scheme_Object *e) @@ -5632,7 +5634,7 @@ void *scheme_module_run_finish(Scheme_Env *menv, Scheme_Env *env) scheme_make_raw_pair(save_prefix, body)); scheme_resume_prefix(save_prefix); } else - (void)_scheme_eval_linked_expr_multi(body); + scheme_ignore_result(_scheme_eval_linked_expr_multi(body)); } if (scheme_module_demand_hook) { diff --git a/src/racket/src/schemef.h b/src/racket/src/schemef.h index 09d7e14d9c..beddc17b97 100644 --- a/src/racket/src/schemef.h +++ b/src/racket/src/schemef.h @@ -361,6 +361,8 @@ MZ_EXTERN void scheme_set_tail_buffer_size(int s); MZ_EXTERN Scheme_Object *scheme_force_value(Scheme_Object *); MZ_EXTERN Scheme_Object *scheme_force_one_value(Scheme_Object *); +XFORM_NONGCING MZ_EXTERN void scheme_ignore_result(Scheme_Object *); + MZ_EXTERN MZ_MARK_STACK_TYPE scheme_set_cont_mark(Scheme_Object *key, Scheme_Object *val); MZ_EXTERN void scheme_push_continuation_frame(Scheme_Cont_Frame_Data *); MZ_EXTERN void scheme_pop_continuation_frame(Scheme_Cont_Frame_Data *); diff --git a/src/racket/src/schemex.h b/src/racket/src/schemex.h index b6ad149f57..10e32c36ea 100644 --- a/src/racket/src/schemex.h +++ b/src/racket/src/schemex.h @@ -278,6 +278,7 @@ Scheme_Object *(*scheme_tail_eval_expr)(Scheme_Object *obj); void (*scheme_set_tail_buffer_size)(int s); Scheme_Object *(*scheme_force_value)(Scheme_Object *); Scheme_Object *(*scheme_force_one_value)(Scheme_Object *); +void (*scheme_ignore_result)(Scheme_Object *); MZ_MARK_STACK_TYPE (*scheme_set_cont_mark)(Scheme_Object *key, Scheme_Object *val); void (*scheme_push_continuation_frame)(Scheme_Cont_Frame_Data *); void (*scheme_pop_continuation_frame)(Scheme_Cont_Frame_Data *); diff --git a/src/racket/src/schemex.inc b/src/racket/src/schemex.inc index f5fd7186c0..3e3e6f2cec 100644 --- a/src/racket/src/schemex.inc +++ b/src/racket/src/schemex.inc @@ -196,6 +196,7 @@ scheme_extension_table->scheme_set_tail_buffer_size = scheme_set_tail_buffer_size; scheme_extension_table->scheme_force_value = scheme_force_value; scheme_extension_table->scheme_force_one_value = scheme_force_one_value; + scheme_extension_table->scheme_ignore_result = scheme_ignore_result; scheme_extension_table->scheme_set_cont_mark = scheme_set_cont_mark; scheme_extension_table->scheme_push_continuation_frame = scheme_push_continuation_frame; scheme_extension_table->scheme_pop_continuation_frame = scheme_pop_continuation_frame; diff --git a/src/racket/src/schemexm.h b/src/racket/src/schemexm.h index 962b73ffd5..a3ef033eb5 100644 --- a/src/racket/src/schemexm.h +++ b/src/racket/src/schemexm.h @@ -196,6 +196,7 @@ #define scheme_set_tail_buffer_size (scheme_extension_table->scheme_set_tail_buffer_size) #define scheme_force_value (scheme_extension_table->scheme_force_value) #define scheme_force_one_value (scheme_extension_table->scheme_force_one_value) +#define scheme_ignore_result (scheme_extension_table->scheme_ignore_result) #define scheme_set_cont_mark (scheme_extension_table->scheme_set_cont_mark) #define scheme_push_continuation_frame (scheme_extension_table->scheme_push_continuation_frame) #define scheme_pop_continuation_frame (scheme_extension_table->scheme_pop_continuation_frame) From c6fc92915d3de5b585eb01ddddf8c60f60664008 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 4 Nov 2012 06:38:30 -0700 Subject: [PATCH 152/221] make figure target rendering configurable from Kevin Tew --- collects/scriblib/figure.rkt | 5 +++-- collects/scriblib/figure.tex | 2 ++ 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/collects/scriblib/figure.rkt b/collects/scriblib/figure.rkt index 014034c95f..d9bbad80fe 100644 --- a/collects/scriblib/figure.rkt +++ b/collects/scriblib/figure.rkt @@ -29,6 +29,7 @@ (define herefigure-style (make-style "Herefigure" figure-style-extras)) (define figureinside-style (make-style "FigureInside" figure-style-extras)) (define legend-style (make-style "Legend" figure-style-extras)) +(define figure-target-style (make-style "FigureTarget" figure-style-extras)) (define centertext-style (make-style "Centertext" figure-style-extras)) (define figure-style (make-style "Figure" figure-style-extras)) @@ -52,7 +53,7 @@ figure-style (list (make-nested-flow content-style (list (make-nested-flow figureinside-style (decode-flow content)))) - (make-paragraph centertext-style (list (make-element legend-style (list (Figure-target tag) ": " caption))))))) + (make-paragraph centertext-style (list (make-element legend-style (list (make-element figure-target-style (list (Figure-target tag) ": ")) caption))))))) (define (*figure style tag caption content) (make-nested-flow @@ -65,7 +66,7 @@ (list (make-paragraph plain - (list (make-element legend-style (list (Figure-target tag) ": " caption)))))))))) + (list (make-element legend-style (list (make-element figure-target-style (list (Figure-target tag) ": ")) caption)))))))))) (define (figure* tag caption . content) (*figure centerfiguremulti-style tag caption content)) diff --git a/collects/scriblib/figure.tex b/collects/scriblib/figure.tex index b7a586a2c8..9f58e97206 100644 --- a/collects/scriblib/figure.tex +++ b/collects/scriblib/figure.tex @@ -12,6 +12,8 @@ \vspace{4pt} \legend{#1}} +\newcommand{\FigureTarget}[1]{#1} + \newlength{\FigOrigskip} \FigOrigskip=\parskip From 0c82f54912a2a2d3e087ab8c8a533b42008d6080 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 4 Nov 2012 07:36:36 -0700 Subject: [PATCH 153/221] racket/gui: add `delete' to `choice%' and `list-control<%>' Closes PR 13230 --- collects/mred/private/mritem.rkt | 11 +++++------ collects/mred/private/wx/cocoa/choice.rkt | 2 ++ collects/mred/private/wx/gtk/choice.rkt | 8 +++++++- collects/mred/private/wx/win32/choice.rkt | 8 ++++---- collects/mred/private/wx/win32/const.rkt | 1 + collects/mred/private/wxlitem.rkt | 3 ++- collects/scribblings/gui/list-box-class.scrbl | 10 ---------- .../scribblings/gui/list-control-intf.scrbl | 19 +++++++++++++++---- collects/tests/gracket/item.rkt | 12 +++++------- 9 files changed, 41 insertions(+), 33 deletions(-) diff --git a/collects/mred/private/mritem.rkt b/collects/mred/private/mritem.rkt index 78108061d5..76cb3b5762 100644 --- a/collects/mred/private/mritem.rkt +++ b/collects/mred/private/mritem.rkt @@ -600,7 +600,10 @@ [find-string (entry-point (lambda (x) (check-label-string '(method list-control<%> find-string) x) (do-find-string x)))] - + [delete (entry-point (lambda (n) + (check-item 'delete n) + (send this -delete-list-item n) + (send wx delete n)))] [-append-list-string (lambda (i) (set! content (append content (list i))))] [-set-list-string (lambda (i s) @@ -842,11 +845,7 @@ (set! num-columns (add1 num-columns)) (set! column-labels (append column-labels (list label))) (send wx append-column label))))] - - [delete (entry-point (lambda (n) - (check-item 'delete n) - (send this -delete-list-item n) - (send wx delete n)))] + [get-data (entry-point (lambda (n) (check-item 'get-data n) (send wx get-data n)))] [get-label-font (lambda () (send wx get-label-font))] [get-selections (entry-point (lambda () (send wx get-selections)))] diff --git a/collects/mred/private/wx/cocoa/choice.rkt b/collects/mred/private/wx/cocoa/choice.rkt index c174789da2..c15b724fc8 100644 --- a/collects/mred/private/wx/cocoa/choice.rkt +++ b/collects/mred/private/wx/cocoa/choice.rkt @@ -68,6 +68,8 @@ (tellv (get-cocoa) insertItemWithTitle: #:type _NSString lbl atIndex: #:type _NSInteger (number))) + (define/public (delete i) + (tellv (get-cocoa) removeItemAtIndex: #:type _NSInteger i)) (define/override (maybe-register-as-child parent on?) (register-as-child parent on?))) diff --git a/collects/mred/private/wx/gtk/choice.rkt b/collects/mred/private/wx/gtk/choice.rkt index 39802d2c28..b5c9d9efdc 100644 --- a/collects/mred/private/wx/gtk/choice.rkt +++ b/collects/mred/private/wx/gtk/choice.rkt @@ -78,9 +78,12 @@ (set! ignore-clicked? #t) (gtk_combo_box_set_active gtk i) (set! ignore-clicked? #f))) + (define/public (get-selection) (gtk_combo_box_get_active gtk)) + (define/public (number) count) + (define/public (clear) (atomically (set! ignore-clicked? #t) @@ -88,6 +91,7 @@ (gtk_combo_box_remove_text gtk 0)) (set! count 0) (set! ignore-clicked? #f))) + (public [-append append]) (define (-append l) (atomically @@ -96,5 +100,7 @@ (gtk_combo_box_append_text gtk l) (when (= count 1) (set-selection 0)) - (set! ignore-clicked? #f)))) + (set! ignore-clicked? #f))) + (define/public (delete i) + (gtk_combo_box_remove_text gtk i))) diff --git a/collects/mred/private/wx/win32/choice.rkt b/collects/mred/private/wx/win32/choice.rkt index 74a4c9d293..b14ecb9135 100644 --- a/collects/mred/private/wx/win32/choice.rkt +++ b/collects/mred/private/wx/win32/choice.rkt @@ -102,13 +102,13 @@ (SendMessageW hwnd CB_RESETCONTENT 0 0) (set! num-choices 0))) - (public [append* append]) (define (append* str) (atomically (SendMessageW/str hwnd CB_ADDSTRING 0 str) (set! num-choices (add1 num-choices)) - (when (= 1 num-choices) (set-selection 0)))))) - - + (when (= 1 num-choices) (set-selection 0)))) + (define/public (delete i) + (set! num-choices (sub1 num-choices)) + (void (SendMessageW hwnd CB_DELETESTRING i 0))))) diff --git a/collects/mred/private/wx/win32/const.rkt b/collects/mred/private/wx/win32/const.rkt index 7b96f9f6ab..0ace67bffd 100644 --- a/collects/mred/private/wx/win32/const.rkt +++ b/collects/mred/private/wx/win32/const.rkt @@ -617,6 +617,7 @@ (define CB_SETCURSEL #x014E) (define CB_GETCURSEL #x0147) (define CB_ADDSTRING #x0143) +(define CB_DELETESTRING #x0144) (define CB_RESETCONTENT #x014B) (define CBN_SELENDOK 9) diff --git a/collects/mred/private/wxlitem.rkt b/collects/mred/private/wxlitem.rkt index fa55722ded..b85f75f45c 100644 --- a/collects/mred/private/wxlitem.rkt +++ b/collects/mred/private/wxlitem.rkt @@ -113,7 +113,8 @@ (get-selection) (number) (clear) - (append lbl)) + (append lbl) + (delete i)) (stretchable-in-y #f) (stretchable-in-x #f))) diff --git a/collects/scribblings/gui/list-box-class.scrbl b/collects/scribblings/gui/list-box-class.scrbl index 7506d8598e..1c5d438c22 100644 --- a/collects/scribblings/gui/list-box-class.scrbl +++ b/collects/scribblings/gui/list-box-class.scrbl @@ -157,16 +157,6 @@ style. The new column is logically the last column, and it is initially displayed as the last column.} -@defmethod[(delete [n exact-nonnegative-integer?]) - void?]{ - -Deletes the item indexed by @racket[n]. @|lbnumnote| If @racket[n] is equal - to or larger than the number of items in the control, @|MismatchExn|. - -Selected items that are not deleted remain selected, and no other - items are selected.} - - @defmethod[(delete-column [n exact-nonnegative-integer?]) void?]{ diff --git a/collects/scribblings/gui/list-control-intf.scrbl b/collects/scribblings/gui/list-control-intf.scrbl index 3c03527170..4b04a9309c 100644 --- a/collects/scribblings/gui/list-control-intf.scrbl +++ b/collects/scribblings/gui/list-control-intf.scrbl @@ -36,11 +36,22 @@ Removes all user-selectable items from the control. } +@defmethod[(delete [n exact-nonnegative-integer?]) + void?]{ + +Deletes the item indexed by @racket[n] (where items are indexed + from @racket[0]). If @racket[n] is equal + to or larger than the number of items in the control, @|MismatchExn|. + +Selected items that are not deleted remain selected, and no other + items are selected.} + + @defmethod[(find-string [s string?]) (or/c exact-nonnegative-integer? #f)]{ Finds a user-selectable item matching the given string. If no matching choice is found, @racket[#f] is returned, otherwise the index of the - matching choice is returned (items are indexed from @racket[0]). + matching choice is returned (where items are indexed from @racket[0]). } @@ -53,7 +64,7 @@ Returns the number of user-selectable items in the control (which is @defmethod[(get-selection) (or/c exact-nonnegative-integer? #f)]{ -Returns the index of the currently selected item (items are indexed +Returns the index of the currently selected item (where items are indexed from @racket[0]). If the choice item currently contains no choices or no selections, @racket[#f] is returned. If multiple selections are allowed and multiple items are selected, the index of the first @@ -64,7 +75,7 @@ Returns the index of the currently selected item (items are indexed @defmethod[(get-string [n exact-nonnegative-integer?]) (and/c immutable? label-string?)]{ -Returns the item for the given index (items are indexed from +Returns the item for the given index (where items are indexed from @racket[0]). If the provided index is larger than the greatest index in the list control, @|MismatchExn|. @@ -81,7 +92,7 @@ Returns the currently selected item. If the control currently @defmethod[(set-selection [n exact-nonnegative-integer?]) void?]{ -Selects the item specified by the given index (items are indexed from +Selects the item specified by the given index (where items are indexed from @racket[0]). If the given index larger than the greatest index in the list control, @|MismatchExn|. diff --git a/collects/tests/gracket/item.rkt b/collects/tests/gracket/item.rkt index 7c3da06609..8566a95198 100644 --- a/collects/tests/gracket/item.rkt +++ b/collects/tests/gracket/item.rkt @@ -1556,13 +1556,11 @@ (when (<= 0 p (sub1 (length actual-content))) (set! actual-content (gone actual-content p)) (set! actual-user-data (gone actual-user-data p)))) - (define db (if list? - (make-object button% - "Delete" cdp - (lambda (b e) - (let ([p (send c get-selection)]) - (delete p)))) - null)) + (define db (make-object button% + "Delete" cdp + (lambda (b e) + (let ([p (send c get-selection)]) + (delete p))))) (define dab (if list? (make-object button% "Delete Above" cdp From 068240e9fefd7bfe7dbbbc9b3cad98bc191ee78a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 4 Nov 2012 08:26:32 -0700 Subject: [PATCH 154/221] racket/gui: fix problems with control labels and client/global positions Closes PR 13232 --- collects/mred/private/wx/cocoa/window.rkt | 21 +++++- collects/mred/private/wx/gtk/frame.rkt | 2 +- collects/mred/private/wx/gtk/window.rkt | 83 ++++++++++++++--------- collects/mred/private/wx/win32/window.rkt | 22 +++++- collects/mred/private/wxlitem.rkt | 14 +++- collects/mred/private/wxpanel.rkt | 1 + 6 files changed, 106 insertions(+), 37 deletions(-) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index ed1b1dcdd0..ff0a22cdb9 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -604,6 +604,10 @@ (- y (client-y-offset)))))) (define/public (client-y-offset) 0) + (define event-position-wrt-wx #f) + (define/public (set-event-positions-wrt wx) + (set! event-position-wrt-wx wx)) + (define/public (is-view?) #t) (define/public (window-point-to-view pos) (let ([pos (if (is-view?) @@ -611,8 +615,17 @@ convertPoint: #:type _NSPoint pos fromView: #f) pos)]) - (values (NSPoint-x pos) - (flip-client (NSPoint-y pos))))) + (define x (NSPoint-x pos)) + (define y (flip-client (NSPoint-y pos))) + (cond + [event-position-wrt-wx + (define xb (box (->long x))) + (define yb (box (->long y))) + (internal-client-to-screen xb yb) + (send event-position-wrt-wx internal-screen-to-client xb yb) + (values (unbox xb) (unbox yb))] + [else (values x y)]))) + (define/public (get-x) (->long (NSPoint-x (NSRect-origin (get-frame))))) @@ -799,6 +812,8 @@ (define/public (refresh-all-children) (void)) (define/public (screen-to-client xb yb) + (internal-screen-to-client xb yb)) + (define/public (internal-screen-to-client xb yb) (let ([p (tell #:type _NSPoint (get-cocoa-content) convertPoint: #:type _NSPoint (tell #:type _NSPoint (get-cocoa-window) @@ -810,6 +825,8 @@ (set-box! yb (inexact->exact (floor (flip-client (NSPoint-y p))))))) (define/public (client-to-screen xb yb [flip-y? #t]) + (internal-client-to-screen xb yb flip-y?)) + (define/public (internal-client-to-screen xb yb [flip-y? #t]) (let* ([p (tell #:type _NSPoint (get-cocoa-window) convertBaseToScreen: #:type _NSPoint diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index fc041d70d6..d46279c9a5 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -424,7 +424,7 @@ (define/override (call-pre-on-char w e) (pre-on-char w e)) - (define/override (client-to-screen x y) + (define/override (internal-client-to-screen x y) (gtk_window_set_gravity gtk GDK_GRAVITY_STATIC) (let-values ([(dx dy) (gtk_window_get_position gtk)] [(cdx cdy) (get-client-delta)]) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 643f5a13be..216d54612a 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -345,35 +345,39 @@ [(1) 'left-up] [(3) 'right-up] [else 'middle-up])])] - [m (new mouse-event% - [event-type type] - [left-down (case type - [(left-down) #t] - [(left-up) #f] - [else (bit? modifiers GDK_BUTTON1_MASK)])] - [middle-down (case type - [(middle-down) #t] - [(middle-up) #f] - [else (bit? modifiers GDK_BUTTON2_MASK)])] - [right-down (case type - [(right-down) #t] - [(right-up) #f] - [else (bit? modifiers GDK_BUTTON3_MASK)])] - [x (->long ((if motion? - GdkEventMotion-x - (if crossing? GdkEventCrossing-x GdkEventButton-x)) - event))] - [y (->long ((if motion? GdkEventMotion-y - (if crossing? GdkEventCrossing-y GdkEventButton-y)) - event))] - [shift-down (bit? modifiers GDK_SHIFT_MASK)] - [control-down (bit? modifiers GDK_CONTROL_MASK)] - [meta-down (bit? modifiers GDK_META_MASK)] - [alt-down (bit? modifiers GDK_MOD1_MASK)] - [time-stamp ((if motion? GdkEventMotion-time - (if crossing? GdkEventCrossing-time GdkEventButton-time)) - event)] - [caps-down (bit? modifiers GDK_LOCK_MASK)])]) + [m (let-values ([(x y) (send wx + adjust-event-position + (->long ((if motion? + GdkEventMotion-x + (if crossing? GdkEventCrossing-x GdkEventButton-x)) + event)) + (->long ((if motion? GdkEventMotion-y + (if crossing? GdkEventCrossing-y GdkEventButton-y)) + event)))]) + (new mouse-event% + [event-type type] + [left-down (case type + [(left-down) #t] + [(left-up) #f] + [else (bit? modifiers GDK_BUTTON1_MASK)])] + [middle-down (case type + [(middle-down) #t] + [(middle-up) #f] + [else (bit? modifiers GDK_BUTTON2_MASK)])] + [right-down (case type + [(right-down) #t] + [(right-up) #f] + [else (bit? modifiers GDK_BUTTON3_MASK)])] + [x x] + [y y] + [shift-down (bit? modifiers GDK_SHIFT_MASK)] + [control-down (bit? modifiers GDK_CONTROL_MASK)] + [meta-down (bit? modifiers GDK_META_MASK)] + [alt-down (bit? modifiers GDK_MOD1_MASK)] + [time-stamp ((if motion? GdkEventMotion-time + (if crossing? GdkEventCrossing-time GdkEventButton-time)) + event)] + [caps-down (bit? modifiers GDK_LOCK_MASK)]))]) (if (send wx handles-events? gtk) (begin (queue-window-event wx (lambda () @@ -697,17 +701,34 @@ (define/public (refresh-all-children) (void)) (define/public (screen-to-client x y) + (internal-screen-to-client x y)) + (define/public (internal-screen-to-client x y) (let ([xb (box 0)] [yb (box 0)]) - (client-to-screen xb yb) + (internal-client-to-screen xb yb) (set-box! x (- (unbox x) (unbox xb))) (set-box! y (- (unbox y) (unbox yb))))) (define/public (client-to-screen x y) + (internal-client-to-screen x y)) + (define/public (internal-client-to-screen x y) (let-values ([(dx dy) (get-client-delta)]) - (send parent client-to-screen x y) + (send parent internal-client-to-screen x y) (set-box! x (+ (unbox x) save-x dx)) (set-box! y (+ (unbox y) save-y dy)))) + (define event-position-wrt-wx #f) + (define/public (set-event-positions-wrt wx) + (set! event-position-wrt-wx wx)) + + (define/public (adjust-event-position x y) + (if event-position-wrt-wx + (let ([xb (box x)] + [yb (box y)]) + (internal-client-to-screen xb yb) + (send event-position-wrt-wx internal-screen-to-client xb yb) + (values (unbox xb) (unbox yb))) + (values x y))) + (define/public (get-client-delta) (values 0 0)) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 23d0f506c1..6e3979a578 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -412,12 +412,29 @@ (define/public (on-resized) (void)) + (define event-position-wrt-wx #f) + (define/public (set-event-positions-wrt wx) + (set! event-position-wrt-wx wx)) + + (define/private (adjust-event-position x y) + (if event-position-wrt-wx + (let ([xb (box x)] + [yb (box y)]) + (internal-client-to-screen xb yb) + (send event-position-wrt-wx internal-screen-to-client xb yb) + (values (unbox xb) (unbox yb))) + (values x y))) + (define/public (screen-to-client x y) + (internal-screen-to-client x y)) + (define/public (internal-screen-to-client x y) (let ([p (make-POINT (unbox x) (unbox y))]) (ScreenToClient (get-client-hwnd) p) (set-box! x (POINT-x p)) (set-box! y (POINT-y p)))) (define/public (client-to-screen x y) + (internal-client-to-screen x y)) + (define/public (internal-client-to-screen x y) (let ([p (make-POINT (unbox x) (unbox y))]) (ClientToScreen (get-client-hwnd) p) (set-box! x (POINT-x p)) @@ -607,6 +624,7 @@ [bit? (lambda (v b) (not (zero? (bitwise-and v b))))]) (let ([make-e (lambda (type) + (define-values (mx my) (adjust-event-position x y)) (new mouse-event% [event-type type] [left-down (case type @@ -621,8 +639,8 @@ [(right-down) #t] [(right-up) #f] [else (bit? flags MK_RBUTTON)])] - [x x] - [y y] + [x mx] + [y my] [shift-down (bit? flags MK_SHIFT)] [control-down (bit? flags MK_CONTROL)] [meta-down #f] diff --git a/collects/mred/private/wxlitem.rkt b/collects/mred/private/wxlitem.rkt index b85f75f45c..a32d650cde 100644 --- a/collects/mred/private/wxlitem.rkt +++ b/collects/mred/private/wxlitem.rkt @@ -59,7 +59,7 @@ (define wx-label-panel% (class wx-control-horizontal-panel% (init proxy parent label style font halign valign) - (inherit area-parent skip-enter-leave-events) + (inherit area-parent skip-enter-leave-events set-event-positions-wrt) (define c #f) (define/override (enable on?) (if c (send c enable on?) (void))) @@ -77,9 +77,21 @@ (define/public (set-label s) (when l (send l set-label s))) (define/public (get-label) (and l (send l get-label))) + (define/override (client-to-screen x y) + (if c + (send c client-to-screen x y) + (super client-to-screen x y))) + (define/override (screen-to-client x y) + (if c + (send c screen-to-client x y) + (super screen-to-client x y))) + (define/public (get-p) p) (define/public (set-c v sx? sy?) (set! c v) + (set-event-positions-wrt c) + (when l (send l set-event-positions-wrt c)) + (when p (send p set-event-positions-wrt c)) (send c stretchable-in-x sx?) (send c stretchable-in-y sy?) (send c skip-subwindow-events? #t)))) diff --git a/collects/mred/private/wxpanel.rkt b/collects/mred/private/wxpanel.rkt index c7e279cf32..471fe6c906 100644 --- a/collects/mred/private/wxpanel.rkt +++ b/collects/mred/private/wxpanel.rkt @@ -54,6 +54,7 @@ (unless (negative? h) (set! height h)))] [get-x (lambda () pos-x)] [get-y (lambda () pos-y)] + [set-event-positions-wrt (lambda (c) (void))] [get-width (lambda () width)] [get-height (lambda () height)] [adopt-child (lambda (c) (send (get-parent) adopt-child c))]) From f3a060ccc1bf6e1e3530bee50800381feb30a74b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 4 Nov 2012 07:49:12 -0600 Subject: [PATCH 155/221] insert examples directly into drracket instead of simulating typing them in, in the module language test suite this speeds it up; going from 140 to 105 seconds on my (mac) machine. (drdr was taking 240 or so seconds, tho) --- collects/tests/drracket/private/module-lang-test-utils.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/tests/drracket/private/module-lang-test-utils.rkt b/collects/tests/drracket/private/module-lang-test-utils.rkt index 228ad3c896..13814eb476 100644 --- a/collects/tests/drracket/private/module-lang-test-utils.rkt +++ b/collects/tests/drracket/private/module-lang-test-utils.rkt @@ -89,7 +89,7 @@ (or (test-interactions test) 'no-interactions) after-execute-output) (k (void))) - (type-in-interactions drs ints) + (insert-in-interactions drs ints) ;; set to be the paragraph right after the insertion. (set! output-start-paragraph (queue-callback/res From e9e2557356286298d77d74a4ec0459cabfe40624 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 4 Nov 2012 08:28:56 -0600 Subject: [PATCH 156/221] unbreak code that changes drracket's dock icon dynamically (when transition to or from the weekend or valentines day) --- collects/drracket/private/drracket-normal.rkt | 41 ++++++++++--------- 1 file changed, 21 insertions(+), 20 deletions(-) diff --git a/collects/drracket/private/drracket-normal.rkt b/collects/drracket/private/drracket-normal.rkt index 45008d4ff1..ab946ca7e1 100644 --- a/collects/drracket/private/drracket-normal.rkt +++ b/collects/drracket/private/drracket-normal.rkt @@ -15,34 +15,35 @@ (define files-to-open (command-line #:args filenames filenames)) -(define the-date (seconds->date - (let ([ssec (getenv "PLTDREASTERSECONDS")]) - (if ssec - (string->number ssec) - (current-seconds))))) +(define startup-date + (seconds->date + (let ([ssec (getenv "PLTDREASTERSECONDS")]) + (if ssec + (string->number ssec) + (current-seconds))))) ;; updates the command-line-arguments with only the files ;; to open. See also main.rkt. (current-command-line-arguments (apply vector files-to-open)) -(define (currently-the-weekend?) - (define dow (date-week-day the-date)) +(define (weekend-date? date) + (define dow (date-week-day date)) (or (= dow 6) (= dow 0))) -(define (valentines-day?) - (and (= 2 (date-month the-date)) - (= 14 (date-day the-date)))) +(define (valentines-date? date) + (and (= 2 (date-month date)) + (= 14 (date-day date)))) -(define (current-icon-state) +(define (icon-state date) (cond - [(valentines-day?) 'valentines] - [(currently-the-weekend?) 'weekend] + [(valentines-date? date) 'valentines] + [(weekend-date? date) 'weekend] [else 'normal])) (define-values (texas-independence-day? prince-kuhio-day? kamehameha-day? halloween?) - (let* ([month (date-month the-date)] - [day (date-day the-date)] - [dow (date-week-day the-date)]) + (let* ([month (date-month startup-date)] + [day (date-day startup-date)] + [dow (date-week-day startup-date)]) (values (and (= 3 month) (= 2 day)) (and (= 3 month) (= 26 day)) (and (= 6 month) (= 11 day)) @@ -119,7 +120,7 @@ (define the-bitmap-spec (cond - [(valentines-day?) + [(valentines-date? startup-date) valentines-days-spec] [(or prince-kuhio-day? kamehameha-day?) (set-splash-progress-bar?! #f) @@ -131,7 +132,7 @@ (collection-file-path "texas-plt-bw.gif" "icons")] [halloween? (collection-file-path "PLT-pumpkin.png" "icons")] - [(currently-the-weekend?) + [(weekend-date? startup-date) weekend-bitmap-spec] [else normal-bitmap-spec])) @@ -139,7 +140,7 @@ (set-splash-char-observer drracket-splash-char-observer) (when (eq? (system-type) 'macosx) - (define initial-state (current-icon-state)) + (define initial-state (icon-state startup-date)) (define weekend-bitmap (if (equal? the-bitmap-spec weekend-bitmap-spec) the-splash-bitmap #f)) @@ -167,7 +168,7 @@ (λ () (let loop ([last-state initial-state]) (sleep 10) - (define next-state (current-icon-state)) + (define next-state (icon-state (seconds->date (current-seconds)))) (unless (equal? last-state next-state) (set-icon next-state)) (loop next-state)))))) From ef3eb3154aa21d83c100d7664121c92eba174959 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 4 Nov 2012 14:36:48 -0600 Subject: [PATCH 157/221] adjust log following to make it work for the middle of a drracket editing session --- collects/drracket/private/follow-log.rkt | 55 ++++++++++++++++-------- 1 file changed, 38 insertions(+), 17 deletions(-) diff --git a/collects/drracket/private/follow-log.rkt b/collects/drracket/private/follow-log.rkt index d9cd5aa14f..f834e98e3a 100644 --- a/collects/drracket/private/follow-log.rkt +++ b/collects/drracket/private/follow-log.rkt @@ -18,6 +18,7 @@ log message was reported. |# + (define lr (make-log-receiver (current-logger) 'debug 'racket/engine 'debug 'GC @@ -27,31 +28,46 @@ log message was reported. (define top-n-events 50) (define drop-gc? #t) +(define start-right-away? #f) (define done-chan (make-channel)) +(define start-chan (make-channel)) (void (thread (λ () - (let loop ([events '()]) - (sync - (handle-evt - lr - (λ (info) - (loop (cons info events)))) - (handle-evt - done-chan - (λ (resp-chan) - (channel-put resp-chan events)))))))) + (let loop () + (sync start-chan) + (let loop ([events '()]) + (sync + (handle-evt + lr + (λ (info) + (loop (cons info events)))) + (handle-evt + done-chan + (λ (resp-chan) + (channel-put resp-chan events))))) + (loop))))) -(define f (parameterize ([current-eventspace (make-eventspace)]) +(define controller-frame-eventspace (make-eventspace)) +(define f (parameterize ([current-eventspace controller-frame-eventspace]) (new frame% [label ""]))) -(define b (new button% [label "Done"] [parent f] +(define sb (new button% [label "Start"] [parent f] [callback (λ (_1 _2) - (define resp (make-channel)) - (channel-put done-chan resp) - (show-results (channel-get resp)) - (exit))])) + (sb-callback))])) +(define db (new button% [label "Stop && Dump"] [parent f] [enabled #f] + [callback + (λ (_1 _2) + (define resp (make-channel)) + (channel-put done-chan resp) + (show-results (channel-get resp)) + (send db enable #f) + (send sb enable #t))])) +(define (sb-callback) + (send sb enable #f) + (send db enable #t) + (channel-put start-chan #t)) (send f show #t) (struct gui-event (start end name) #:prefab) @@ -117,7 +133,12 @@ log message was reported. [(timeline-info? (vector-ref x 2)) (timeline-info-milliseconds (vector-ref x 2))] [else - (eprintf "unk: ~s\n" x) + (unless (regexp-match #rx"^GC: 0:MST @" (vector-ref x 1)) + (eprintf "unk: ~s\n" x)) 0])) + +(when start-right-away? + (parameterize ([current-eventspace controller-frame-eventspace]) + (queue-callback sb-callback))) (dynamic-require 'drracket #f) From 1126f02ddd51f52904aaa36f9a92b7ab540841bb Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 4 Nov 2012 15:24:19 -0700 Subject: [PATCH 158/221] change JIT inlining of `/' to be fast on a fixnum result --- collects/tests/racket/optimize.rktl | 4 ++ src/racket/src/jitarith.c | 98 +++++++++++++---------------- 2 files changed, 46 insertions(+), 56 deletions(-) diff --git a/collects/tests/racket/optimize.rktl b/collects/tests/racket/optimize.rktl index 971b34345c..ed5a715717 100644 --- a/collects/tests/racket/optimize.rktl +++ b/collects/tests/racket/optimize.rktl @@ -475,6 +475,10 @@ (tri 3 '/ (lambda () 30) 5 2 void) (tri 12 '/ (lambda () 30) 5 1/2 void) (bin-exact (/ 1.1 2.3) 'fl/ 1.1 2.3 #t) + (bin 4/3 '/ 4 3) + (bin -4/3 '/ 4 -3) + (bin -4/3 '/ -4 3) + (bin 4/3 '/ -4 -3) (bin-int 3 'quotient 10 3) (bin-int -3 'quotient 10 -3) diff --git a/src/racket/src/jitarith.c b/src/racket/src/jitarith.c index 9cf7ce4994..02ee34655b 100644 --- a/src/racket/src/jitarith.c +++ b/src/racket/src/jitarith.c @@ -1125,11 +1125,6 @@ int scheme_generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj CHECK_LIMIT(); /* sync'd in three branches below */ - if (arith == ARITH_DIV) { - if (rand2 || (v != 1) || reversed) - has_fixnum_fast = 0; - } - /* rand2 in R0, and rand in R1 unless it's simple */ if (simple_rand || simple_rand2) { @@ -1299,7 +1294,7 @@ int scheme_generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj if (!unsafe_fl) { if (arith) { - if (((arith == ARITH_QUOT) || (arith == ARITH_REM) || (arith == ARITH_MOD)) && !rand2) { + if (((arith == ARITH_DIV) || (arith == ARITH_QUOT) || (arith == ARITH_REM) || (arith == ARITH_MOD)) && !rand2) { (void)jit_movi_p(JIT_R1, scheme_make_integer(v)); rand2 = scheme_true; reversed = !reversed; @@ -1338,54 +1333,58 @@ int scheme_generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj else (void)jit_bomulr_l(refslow, JIT_V1, JIT_R2); jit_ori_ul(JIT_R0, JIT_V1, 0x1); - } else if (arith == ARITH_DIV) { - if (has_fixnum_fast) { - /* No fast path for fixnum division, yet */ - (void)jit_jmpi(refslow); - } - } else if ((arith == ARITH_QUOT) || (arith == ARITH_REM) || (arith == ARITH_MOD)) { - jit_rshi_l(JIT_V1, JIT_R0, 0x1); - jit_rshi_l(JIT_R2, JIT_R1, 0x1); + } else if ((arith == ARITH_DIV) || (arith == ARITH_QUOT) || (arith == ARITH_REM) || (arith == ARITH_MOD)) { if (reversed) { - if (!unsafe_fx || overflow_refslow) - (void)jit_beqi_l(refslow, JIT_R2, 0); - if (arith == ARITH_MOD) { - generate_modulo_setup(jitter, branch_short, JIT_V1, JIT_R2); - CHECK_LIMIT(); - } - if (arith == ARITH_QUOT) - jit_divr_l(JIT_R0, JIT_V1, JIT_R2); - else - jit_modr_l(JIT_R0, JIT_V1, JIT_R2); + jit_rshi_l(JIT_V1, JIT_R0, 0x1); + jit_rshi_l(JIT_R2, JIT_R1, 0x1); } else { - if (!unsafe_fx || overflow_refslow) - (void)jit_beqi_l(refslow, JIT_V1, 0); - if (arith == ARITH_MOD) { - generate_modulo_setup(jitter, branch_short, JIT_R2, JIT_V1); - CHECK_LIMIT(); - } - if (arith == ARITH_QUOT) - jit_divr_l(JIT_R0, JIT_R2, JIT_V1); - else - jit_modr_l(JIT_R0, JIT_R2, JIT_V1); + jit_rshi_l(JIT_R2, JIT_R0, 0x1); + jit_rshi_l(JIT_V1, JIT_R1, 0x1); } + if (!unsafe_fx || overflow_refslow) + (void)jit_beqi_l(refslow, JIT_R2, 0); + if (arith == ARITH_MOD) { + generate_modulo_setup(jitter, branch_short, JIT_V1, JIT_R2); + CHECK_LIMIT(); + } + if ((arith == ARITH_DIV) || (arith == ARITH_QUOT)) + jit_divr_l(JIT_R0, JIT_V1, JIT_R2); + else + jit_modr_l(JIT_R0, JIT_V1, JIT_R2); + + if (arith == ARITH_DIV) { + GC_CAN_IGNORE jit_insn *refx; + if (reversed) + jit_mulr_l(JIT_R2, JIT_R0, JIT_R2); + else + jit_mulr_l(JIT_V1, JIT_R0, JIT_V1); + __START_INNER_TINY__(branch_short); + refx = jit_beqr_l(jit_forward(), JIT_R2, JIT_V1); + __END_INNER_TINY__(branch_short); + /* restore R0 argument: */ + if (reversed) + jit_lshi_l(JIT_R0, JIT_V1, 1); + else + jit_lshi_l(JIT_R0, JIT_R2, 1); + jit_ori_l(JIT_R0, JIT_R0, 0x1); + (void)jit_jmpi(refslow); + __START_INNER_TINY__(branch_short); + mz_patch_branch(refx); + __END_INNER_TINY__(branch_short); + } else if (arith == ARITH_MOD) { GC_CAN_IGNORE jit_insn *refx, *refy; __START_INNER_TINY__(branch_short); refy = jit_beqi_l(jit_forward(), JIT_R0, 0); refx = jit_bmci_l(jit_forward(), JIT_R1, 0x1); - if (reversed) - jit_subr_l(JIT_R0, JIT_R2, JIT_R0); - else - jit_subr_l(JIT_R0, JIT_V1, JIT_R0); + jit_subr_l(JIT_R0, JIT_R2, JIT_R0); mz_patch_branch(refx); refx = jit_bmci_l(jit_forward(), JIT_R1, 0x2); jit_negr_l(JIT_R0, JIT_R0); mz_patch_branch(refx); mz_patch_branch(refy); __END_INNER_TINY__(branch_short); - } - if (arith == ARITH_QUOT) { + } else if (arith == ARITH_QUOT) { /* watch out for negation of most negative fixnum, which is a positive number too big for a fixnum */ if (!unsafe_fx || overflow_refslow) { @@ -1551,16 +1550,6 @@ int scheme_generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj } jit_ori_ul(JIT_R0, JIT_V1, 0x1); } - } else if (arith == ARITH_DIV) { - if ((v == 1) && !reversed) { - /* R0 already is the answer */ - } else { - if (has_fixnum_fast) { - /* No general fast path for fixnum division, yet */ - (void)jit_movi_p(JIT_R1, scheme_make_integer(v)); - (void)jit_jmpi(refslow); - } - } } else { if (arith == ARITH_AND) { /* and */ @@ -1877,12 +1866,9 @@ int scheme_generate_nary_arith(mz_jit_state *jitter, Scheme_App_Rec *app, # define mzSET_USE_FL(x) /* empty */ #endif - if (arith == ARITH_DIV) { - /* can't inline fixnum '/' */ - use_fx = 0; - } else if ((arith == ARITH_AND) - || (arith == ARITH_IOR) - || (arith == ARITH_XOR)) { + if ((arith == ARITH_AND) + || (arith == ARITH_IOR) + || (arith == ARITH_XOR)) { /* bitwise operators are fixnum, only */ mzSET_USE_FL(use_fl = 0); } From 81dc3bae37690e066204051b8b32d7db16ce4a67 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 4 Nov 2012 19:01:24 -0600 Subject: [PATCH 159/221] audit the calls to invalidate-bitmap-cache in the framework and in drracket and try to make them happen less often (or, if there will be multiple ones, try to guarantee that there is an edit sequence) --- collects/drracket/private/module-language.rkt | 17 ++++++++++++----- collects/drracket/private/rep.rkt | 1 - collects/framework/private/text.rkt | 8 ++++++-- 3 files changed, 18 insertions(+), 8 deletions(-) diff --git a/collects/drracket/private/module-language.rkt b/collects/drracket/private/module-language.rkt index b1d7b94128..0d952e0071 100644 --- a/collects/drracket/private/module-language.rkt +++ b/collects/drracket/private/module-language.rkt @@ -1315,7 +1315,8 @@ (inherit last-position find-first-snip get-top-level-window get-filename get-tab get-canvas invalidate-bitmap-cache set-position get-start-position get-end-position - highlight-range dc-location-to-editor-location) + highlight-range dc-location-to-editor-location + begin-edit-sequence end-edit-sequence) (define compilation-out-of-date? #f) @@ -1507,6 +1508,7 @@ (reset-frame-expand-error #f)) (define/private (show-error-in-margin res) + (begin-edit-sequence #f #f) (define tlw (send (get-tab) get-frame)) (send (get-tab) show-bkg-running 'nothing #f) (set! error/status-message-str (vector-ref res 1)) @@ -1521,7 +1523,8 @@ (set-error-ranges-from-online-error-ranges (vector-ref res 2)) (invalidate-online-error-ranges) (set! error/status-message-hidden? #f) - (update-frame-expand-error)) + (update-frame-expand-error) + (end-edit-sequence)) (define/private (show-error-as-highlighted-regions res) (define tlw (send (get-tab) get-frame)) @@ -1556,6 +1559,7 @@ (send (send (get-tab) get-ints) set-error-ranges srclocs)) (define/private (clear-old-error) + (begin-edit-sequence #f #f) (for ([cleanup-thunk (in-list online-highlighted-errors)]) (cleanup-thunk)) (for ([an-error-range (in-list online-error-ranges)]) @@ -1563,7 +1567,8 @@ ((error-range-clear-highlight an-error-range)) (set-error-range-clear-highlight! an-error-range #f))) (invalidate-online-error-ranges) - (set-online-error-ranges '())) + (set-online-error-ranges '()) + (end-edit-sequence)) (define/private (invalidate-online-error-ranges) (when (get-admin) @@ -1814,7 +1819,8 @@ (update-recently-typed #t) (set! fade-amount 0) (send recently-typed-timer stop) - (send recently-typed-timer start 10000 #t)) + (when lang-wants-big-defs/ints-labels? + (send recently-typed-timer start 10000 #t))) (super on-char evt)) (define/private (update-recently-typed nv) @@ -1829,7 +1835,8 @@ [else (preferences:get 'drracket:defs/ints-labels)])) (unless (equal? new-inside? inside?) (set! inside? new-inside?) - (invalidate-bitmap-cache 0 0 'display-end 'display-end)) + (when lang-wants-big-defs/ints-labels? + (invalidate-bitmap-cache 0 0 'display-end 'display-end))) (cond [(and lang-wants-big-defs/ints-labels? (preferences:get 'drracket:defs/ints-labels) diff --git a/collects/drracket/private/rep.rkt b/collects/drracket/private/rep.rkt index 7b9eb28bd9..6d8ed96cb7 100644 --- a/collects/drracket/private/rep.rkt +++ b/collects/drracket/private/rep.rkt @@ -434,7 +434,6 @@ TODO insert insert-before insert-between - invalidate-bitmap-cache is-locked? last-position line-location diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index d66f8579ab..0ed3367508 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -3855,7 +3855,9 @@ designates the character that triggers autocompletion ;; draws line numbers on the left hand side of a text% object (define line-numbers-mixin (mixin ((class->interface text%) editor:standard-style-list<%>) (line-numbers<%>) - (inherit get-visible-line-range + (inherit begin-edit-sequence + end-edit-sequence + get-visible-line-range get-visible-position-range last-line line-location @@ -4194,6 +4196,7 @@ designates the character that triggers autocompletion (when (showing-line-numbers?) (define dc (get-dc)) (when dc + (begin-edit-sequence #f #f) (define bx (box 0)) (define by (box 0)) (define tw (text-width dc (number-space+1))) @@ -4209,7 +4212,8 @@ designates the character that triggers autocompletion tw th) (unless (= line (last-line)) - (loop (+ line 1)))))))) + (loop (+ line 1))))) + (end-edit-sequence)))) (super-new) (setup-padding))) From 0fa78a8ceed20c71b049573f9d1fba26fe9b77b9 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Sun, 4 Nov 2012 18:20:54 -0700 Subject: [PATCH 160/221] documentation: removing the korean characters out of the example. Was breaking the build at LaTeX generation time. --- collects/scribblings/reference/string-input.scrbl | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/collects/scribblings/reference/string-input.scrbl b/collects/scribblings/reference/string-input.scrbl index 3110634024..69c104fc8a 100644 --- a/collects/scribblings/reference/string-input.scrbl +++ b/collects/scribblings/reference/string-input.scrbl @@ -154,10 +154,9 @@ Like @racket[read-string], but reads bytes and produces a byte string.} @examples[#:eval si-eval (let ([ip (open-input-bytes - (bytes 14 + (bytes 6 115 101 99 114 101 - 116 58 32 235 185 - 132 235 176 128))]) + 116))]) (define length (read-byte ip)) (bytes->string/utf-8 (read-bytes length ip))) ] From f22aaec21dffb68a16116cb56aef0a6385e7e6b0 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 4 Nov 2012 19:46:32 -0600 Subject: [PATCH 161/221] the 'audit the invalidate-bitmap-cache' commit (2 commits ago) avoided running the 'redraw the definitions/interactions label' timer when the language didn't ask for those labels; this commit also avoids running the timer when the user has disabled the labels --- collects/drracket/private/module-language.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/drracket/private/module-language.rkt b/collects/drracket/private/module-language.rkt index 0d952e0071..7ce9dbc8ba 100644 --- a/collects/drracket/private/module-language.rkt +++ b/collects/drracket/private/module-language.rkt @@ -1819,7 +1819,8 @@ (update-recently-typed #t) (set! fade-amount 0) (send recently-typed-timer stop) - (when lang-wants-big-defs/ints-labels? + (when (and lang-wants-big-defs/ints-labels? + (preferences:get 'drracket:defs/ints-labels)) (send recently-typed-timer start 10000 #t))) (super on-char evt)) From 885382e12ede0effd1237a3c66bc225244aaa78a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 5 Nov 2012 06:35:18 -0700 Subject: [PATCH 162/221] benchmark tweaks and addition --- .../tests/racket/benchmarks/common/auto.rkt | 6 ++++-- .../racket/benchmarks/common/collatz-q.rkt | 1 + .../racket/benchmarks/common/collatz-q.sch | 15 +++++++++++++++ .../tests/racket/benchmarks/common/collatz.rkt | 1 + .../tests/racket/benchmarks/common/collatz.sch | 18 ++++++++++++++++++ .../tests/racket/benchmarks/common/earley.sch | 2 +- .../tests/racket/benchmarks/common/maze.sch | 2 +- .../racket/benchmarks/common/mk-bigloo.rktl | 2 +- .../racket/benchmarks/common/scheme-c.sch | 14 +++++++------- .../racket/benchmarks/common/scheme-i.sch | 9 +++++---- 10 files changed, 54 insertions(+), 16 deletions(-) create mode 100644 collects/tests/racket/benchmarks/common/collatz-q.rkt create mode 100644 collects/tests/racket/benchmarks/common/collatz-q.sch create mode 100644 collects/tests/racket/benchmarks/common/collatz.rkt create mode 100644 collects/tests/racket/benchmarks/common/collatz.sch diff --git a/collects/tests/racket/benchmarks/common/auto.rkt b/collects/tests/racket/benchmarks/common/auto.rkt index ef12ae072e..f0078280ed 100755 --- a/collects/tests/racket/benchmarks/common/auto.rkt +++ b/collects/tests/racket/benchmarks/common/auto.rkt @@ -463,7 +463,7 @@ exec racket -qu "$0" ${1+"$@"} run-exe extract-bigloo-times clean-up-bin - (append '(cpstak nucleic2 takr2) + (append '(ctak cpstak nucleic2 takr2) racket-specific-progs)) (make-impl 'gambit void @@ -521,7 +521,9 @@ exec racket -qu "$0" ${1+"$@"} (define obsolete-impls '(racket3m racketcgc racket-j racketcgc-j racketcgc-tl mzc mz-old)) (define benchmarks - '(conform + '(collatz + collatz-q + conform cpstak ctak deriv diff --git a/collects/tests/racket/benchmarks/common/collatz-q.rkt b/collects/tests/racket/benchmarks/common/collatz-q.rkt new file mode 100644 index 0000000000..87927e133f --- /dev/null +++ b/collects/tests/racket/benchmarks/common/collatz-q.rkt @@ -0,0 +1 @@ +(module collatz-q "wrap.rkt") diff --git a/collects/tests/racket/benchmarks/common/collatz-q.sch b/collects/tests/racket/benchmarks/common/collatz-q.sch new file mode 100644 index 0000000000..60ab0e5161 --- /dev/null +++ b/collects/tests/racket/benchmarks/common/collatz-q.sch @@ -0,0 +1,15 @@ + +(define (cycle-length n) + (cond + [(= n 1) + 1] + [(odd? n) + (+ 1 (cycle-length (+ 1 (* 3 n))))] + [(even? n) + (+ 1 (cycle-length (quotient n 2)))])) + +(time (let loop ([i 1] [v #f]) + (if (= i 1000000) + v + (loop (+ i 1) (cycle-length i))))) + diff --git a/collects/tests/racket/benchmarks/common/collatz.rkt b/collects/tests/racket/benchmarks/common/collatz.rkt new file mode 100644 index 0000000000..5a5a96fbd7 --- /dev/null +++ b/collects/tests/racket/benchmarks/common/collatz.rkt @@ -0,0 +1 @@ +(module collatz "wrap.rkt") diff --git a/collects/tests/racket/benchmarks/common/collatz.sch b/collects/tests/racket/benchmarks/common/collatz.sch new file mode 100644 index 0000000000..2caf662fa7 --- /dev/null +++ b/collects/tests/racket/benchmarks/common/collatz.sch @@ -0,0 +1,18 @@ + +;; This variant of the benchmark uses `/'. +;; See "collatz-q.sch" for the `quotient' variant. + +(define (cycle-length n) + (cond + [(= n 1) + 1] + [(odd? n) + (+ 1 (cycle-length (+ 1 (* 3 n))))] + [(even? n) + (+ 1 (cycle-length (/ n 2)))])) + +(time (let loop ([i 1] [v #f]) + (if (= i 1000000) + v + (loop (+ i 1) (cycle-length i))))) + diff --git a/collects/tests/racket/benchmarks/common/earley.sch b/collects/tests/racket/benchmarks/common/earley.sch index 649b0c7f3c..6467f435b3 100644 --- a/collects/tests/racket/benchmarks/common/earley.sch +++ b/collects/tests/racket/benchmarks/common/earley.sch @@ -664,4 +664,4 @@ (let ((x (p (vector->list (make-vector k 'a))))) (length (parse->trees x 's 0 k))))) -(time (test 12)) +(time (test 14)) diff --git a/collects/tests/racket/benchmarks/common/maze.sch b/collects/tests/racket/benchmarks/common/maze.sch index 9aa61f249b..7e6a332877 100644 --- a/collects/tests/racket/benchmarks/common/maze.sch +++ b/collects/tests/racket/benchmarks/common/maze.sch @@ -671,7 +671,7 @@ ;------------------------------------------------------------------------------ (let ((input (with-input-from-file "input.txt" read))) - (time (let loop ((n 1000) (v 0)) + (time (let loop ((n 10000) (v 0)) (if (zero? n) v (begin diff --git a/collects/tests/racket/benchmarks/common/mk-bigloo.rktl b/collects/tests/racket/benchmarks/common/mk-bigloo.rktl index 614ebdecfb..59e86f7629 100644 --- a/collects/tests/racket/benchmarks/common/mk-bigloo.rktl +++ b/collects/tests/racket/benchmarks/common/mk-bigloo.rktl @@ -11,7 +11,7 @@ (newline)) #:exists 'truncate/replace) -(when (system (format "bigloo -static-bigloo -w -o ~a -copt -m32 -call/cc -copt -O3 -copt -fomit-frame-pointer -O6 ~a.scm" +(when (system (format "bigloo -static-bigloo -w -o ~a -call/cc -copt -O3 -copt -fomit-frame-pointer -O6 ~a.scm" name name)) (delete-file (format "~a.scm" name)) (delete-file (format "~a.o" name))) diff --git a/collects/tests/racket/benchmarks/common/scheme-c.sch b/collects/tests/racket/benchmarks/common/scheme-c.sch index 06820773d9..c4d92d1c46 100644 --- a/collects/tests/racket/benchmarks/common/scheme-c.sch +++ b/collects/tests/racket/benchmarks/common/scheme-c.sch @@ -361,6 +361,13 @@ (set! *env* (cons *env* (cons x (cons y (cons z def))))) (a))))) +;- -- evaluator --- + +(define (evaluate expr) + ((compile (list 'lambda '() expr)))) + +(define *env* '(dummy)) ; current environment + ;- -- global variable definition --- (define (define-global var val) @@ -380,13 +387,6 @@ ;- -- to evaluate an expression we compile it and then call the result --- -(define (evaluate expr) - ((compile (list 'lambda '() expr)))) - -(define *env* '(dummy)) ; current environment - - - (evaluate '(define 'fib (lambda (x) (if (< x 2) diff --git a/collects/tests/racket/benchmarks/common/scheme-i.sch b/collects/tests/racket/benchmarks/common/scheme-i.sch index 0d77991b94..b876d317bd 100644 --- a/collects/tests/racket/benchmarks/common/scheme-i.sch +++ b/collects/tests/racket/benchmarks/common/scheme-i.sch @@ -109,6 +109,11 @@ (lambda (x y . z) (int a (cons (cons b x) (cons (cons c y) (cons (cons d z) env)))))) +;- -- evaluator --- + +(define (evaluate expr) + (interpret expr)) + ;- -- global variable definition --- (define (define-global var val) @@ -130,10 +135,6 @@ ;- -- to evaluate an expression we call the interpreter --- -(define (evaluate expr) - (interpret expr)) - - (evaluate '(define 'fib (lambda (x) (if (< x 2) From f21280e24dd280b7d8ec70a5227910a788f070a2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 5 Nov 2012 08:20:32 -0700 Subject: [PATCH 163/221] fix problems with non-parallel places The implementation of message passing in thread-simulated places had not kept up with the parallel implementation. --- collects/racket/place/private/th-place.rkt | 71 +++++++++++++++------- collects/tests/racket/place-channel.rkt | 4 ++ 2 files changed, 52 insertions(+), 23 deletions(-) diff --git a/collects/racket/place/private/th-place.rkt b/collects/racket/place/private/th-place.rkt index bf44ad3a9e..55d04d57d4 100644 --- a/collects/racket/place/private/th-place.rkt +++ b/collects/racket/place/private/th-place.rkt @@ -70,38 +70,63 @@ (values pch cch)) (define (deep-copy x) + (define ht (make-hasheq)) + (define (record v new-v) + (hash-set! ht v new-v) + new-v) + (define (with-placeholder o mk) + (define ph (make-placeholder #f)) + (hash-set! ht o ph) + (define new-o (mk)) + (placeholder-set! ph new-o) + new-o) (define (dcw o) (cond [(ormap (lambda (x) (x o)) (list number? char? boolean? null? void? string? symbol? TH-place-channel?)) o] + [(hash-ref ht o #f) + => values] [(cond - [(path? o) (path->bytes o)] - [(bytes? o) (if (pl-place-shared? o) o (bytes-copy o))] - [(fxvector? o) (if (pl-place-shared? o) o (fxvector-copy o))] - [(flvector? o) (if (pl-place-shared? o) o (flvector-copy o))] + [(path-for-some-system? o) o] + [(bytes? o) (if (pl-place-shared? o) o (record o (bytes-copy o)))] + [(fxvector? o) (if (pl-place-shared? o) o (record o (fxvector-copy o)))] + [(flvector? o) (if (pl-place-shared? o) o (record o (flvector-copy o)))] [else #f]) => values] [(TH-place? o) (dcw (TH-place-ch o))] - [(pair? o) (cons (dcw (car o)) (dcw (cdr o)))] - [(vector? o) (vector-map! dcw (vector-copy o))] - [(hash-equal? o) - (for/fold ([nh (hash)]) ([p (in-hash-pairs o)]) - (hash-set nh (dcw (car p)) (dcw (cdr p))))] - [(hash-eq? o) - (for/fold ([nh (hasheq)]) ([p (in-hash-pairs o)]) - (hash-set nh (dcw (car p)) (dcw (cdr p))))] - [(hash-eqv? o) - (for/fold ([nh (hasheqv)]) ([p (in-hash-pairs o)]) - (hash-set nh (dcw (car p)) (dcw (cdr p))))] - [(struct? o) - (define key (prefab-struct-key o)) - (when (not key) - (error "Must be a prefab struct")) - (apply make-prefab-struct - key - (map dcw (cdr (vector->list (struct->vector o)))))] + [(pair? o) + (with-placeholder + o + (lambda () + (cons (dcw (car o)) (dcw (cdr o)))))] + [(vector? o) + (vector-map! dcw (record o (vector-copy o)))] + [(hash? o) + (with-placeholder + o + (lambda () + (cond + [(hash-equal? o) + (for/fold ([nh (hash)]) ([p (in-hash-pairs o)]) + (hash-set nh (dcw (car p)) (dcw (cdr p))))] + [(hash-eq? o) + (for/fold ([nh (hasheq)]) ([p (in-hash-pairs o)]) + (hash-set nh (dcw (car p)) (dcw (cdr p))))] + [else ; (hash-eqv? o) + (for/fold ([nh (hasheqv)]) ([p (in-hash-pairs o)]) + (hash-set nh (dcw (car p)) (dcw (cdr p))))])))] + [(and (struct? o) + (prefab-struct-key o)) + => + (lambda (key) + (with-placeholder + o + (lambda () + (apply make-prefab-struct + key + (map dcw (cdr (vector->list (struct->vector o))))))))] [else (raise-mismatch-error 'place-channel-put "cannot transmit a message containing value: " o)])) - (dcw x)) + (make-reader-graph (dcw x))) (define (th-place-channel-put pl msg) diff --git a/collects/tests/racket/place-channel.rkt b/collects/tests/racket/place-channel.rkt index 677f4a5b68..6ce2a7edb2 100644 --- a/collects/tests/racket/place-channel.rkt +++ b/collects/tests/racket/place-channel.rkt @@ -89,6 +89,8 @@ (make-immutable-hash l1) (make-immutable-hasheq l2) (make-immutable-hasheqv l3) + (bytes->path x 'unix) + (bytes->path x 'windows) ))) (define (channel-test-basic-types-master sender ch) @@ -115,6 +117,8 @@ ((make-hash l1) (make-immutable-hash l1)) ((make-hasheq l2) (make-immutable-hasheq l2)) ((make-hasheqv l3) (make-immutable-hasheqv l3)) + (#"/tmp/unix" (bytes->path #"/tmp/unix" 'unix)) + (#"C:\\Windows" (bytes->path #"C:\\Windows" 'windows)) )) (define-place (place-worker ch) From bd0e6ae941fde7193f8cf5098537e669057fddd5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 5 Nov 2012 10:48:19 -0700 Subject: [PATCH 164/221] fix problems with chaperones, printing, and cycles --- collects/tests/racket/chaperone.rktl | 15 +++++++++++++++ src/racket/src/print.c | 26 +++++++++++++++++++------- 2 files changed, 34 insertions(+), 7 deletions(-) diff --git a/collects/tests/racket/chaperone.rktl b/collects/tests/racket/chaperone.rktl index 00d5649315..8c13773e6b 100644 --- a/collects/tests/racket/chaperone.rktl +++ b/collects/tests/racket/chaperone.rktl @@ -1299,6 +1299,21 @@ (test #f values set-proc) (test #f values remove-proc))) +;; ---------------------------------------- +;; Check interaciton of chaperones and cycle checks + +(let () + (struct a ([x #:mutable]) #:transparent) + + (define an-a (a #f)) + (set-a-x! an-a an-a) + (let ([o (open-output-bytes)]) + (print + (chaperone-struct an-a + a-x (lambda (s v) v)) + o) + (test #"(a #0=(a #0#))" get-output-bytes o))) + ;; ---------------------------------------- (report-errs) diff --git a/src/racket/src/print.c b/src/racket/src/print.c index 6a4af29571..d6410bb4d1 100644 --- a/src/racket/src/print.c +++ b/src/racket/src/print.c @@ -510,8 +510,7 @@ static int check_cycles(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht || SCHEME_MUTABLE_PAIRP(obj) || (pp->print_box && SCHEME_CHAPERONE_BOXP(obj)) || SCHEME_CHAPERONE_VECTORP(obj) - || ((SAME_TYPE(t, scheme_structure_type) - || SAME_TYPE(t, scheme_proc_struct_type)) + || (SCHEME_CHAPERONE_STRUCTP(obj) && ((pp->print_struct && PRINTABLE_STRUCT(obj, pp)) || scheme_is_writable_struct(obj))) @@ -566,8 +565,7 @@ static int check_cycles(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht if ((for_write < 3) && res) return res; } - } else if (SAME_TYPE(t, scheme_structure_type) - || SAME_TYPE(t, scheme_proc_struct_type)) { + } else if (SCHEME_CHAPERONE_STRUCTP(obj)) { if (scheme_is_writable_struct(obj)) { if (pp->print_unreadable) { res = check_cycles(writable_struct_subs(obj, for_write, pp), for_write, ht, pp); @@ -589,7 +587,12 @@ static int check_cycles(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht res = 0; } else { /* got here => printable */ - int i = SCHEME_STRUCT_NUM_SLOTS(obj); + int i; + + if (SCHEME_CHAPERONEP(obj)) + i = SCHEME_STRUCT_NUM_SLOTS(SCHEME_CHAPERONE_VAL(obj)); + else + i = SCHEME_STRUCT_NUM_SLOTS(obj); if ((for_write >= 3) && !SCHEME_PREFABP(obj)) res = 0x1; @@ -597,7 +600,11 @@ static int check_cycles(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht res = 0; while (i--) { if (scheme_inspector_sees_part(obj, pp->inspector, i)) { - res2 = check_cycles(((Scheme_Structure *)obj)->slots[i], for_write, ht, pp); + if (SCHEME_CHAPERONEP(obj)) + val = scheme_struct_ref(obj, i); + else + val = ((Scheme_Structure *)obj)->slots[i]; + res2 = check_cycles(val, for_write, ht, pp); res |= res2; if ((for_write < 3) && res) return res; @@ -867,7 +874,12 @@ static void setup_graph_table(Scheme_Object *obj, int for_write, Scheme_Hash_Tab setup_graph_table(obj, for_write, ht, counter, pp); } } else { - int i = SCHEME_STRUCT_NUM_SLOTS(obj); + int i; + + if (SCHEME_CHAPERONEP(obj)) + i = SCHEME_STRUCT_NUM_SLOTS(SCHEME_CHAPERONE_VAL(obj)); + else + i = SCHEME_STRUCT_NUM_SLOTS(obj); while (i--) { if (scheme_inspector_sees_part(obj, pp->inspector, i)) From 321cd1b4aee78f8c88b028601d63dbfa59ff70fd Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 5 Nov 2012 17:25:20 -0500 Subject: [PATCH 165/221] macro-stepper: fix for lifted provides closes PR 13236 --- collects/macro-debugger/model/reductions.rkt | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/collects/macro-debugger/model/reductions.rkt b/collects/macro-debugger/model/reductions.rkt index f4e17c0fd3..3b1c43d8fe 100644 --- a/collects/macro-debugger/model/reductions.rkt +++ b/collects/macro-debugger/model/reductions.rkt @@ -721,12 +721,14 @@ [#:set-syntax (append stxs old-forms)] [ModulePass ?forms rest]])] [(cons (Wrap mod:lift-end (stxs)) rest) - (R [#:pattern ?forms] - [#:when (pair? stxs) - [#:left-foot null] - [#:set-syntax (append stxs #'?forms)] - [#:step 'splice-module-lifts stxs]] - [ModulePass ?forms rest])] + ;; In pass2, stxs contains a mixture of terms and kind-tagged terms (pairs) + (let ([stxs (map (lambda (e) (if (pair? e) (car e) e)) stxs)]) + (R [#:pattern ?forms] + [#:when (pair? stxs) + [#:left-foot null] + [#:set-syntax (append stxs #'?forms)] + [#:step 'splice-module-lifts stxs]] + [ModulePass ?forms rest]))] [(cons (Wrap mod:skip ()) rest) (R [#:pattern (?firstS . ?rest)] [ModulePass ?rest rest])] From 68dd17bf0880646ac997dbc68861ba9f915f3803 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Mon, 5 Nov 2012 17:25:30 -0500 Subject: [PATCH 166/221] Make control contracts play nice with has-contract? --- collects/racket/contract/private/misc.rkt | 6 ++++-- collects/tests/racket/contract-test.rktl | 19 +++++++++++++++++++ 2 files changed, 23 insertions(+), 2 deletions(-) diff --git a/collects/racket/contract/private/misc.rkt b/collects/racket/contract/private/misc.rkt index 64c3d93692..eaead9fc4a 100644 --- a/collects/racket/contract/private/misc.rkt +++ b/collects/racket/contract/private/misc.rkt @@ -1014,7 +1014,8 @@ '(expected: "~s" given: "~e") (contract-name ctc) val)) - (proxy val proj1 proj2 call/cc-guard call/cc-proxy)))) + (proxy val proj1 proj2 call/cc-guard call/cc-proxy + impersonator-prop:contracted ctc)))) (define ((prompt-tag/c-first-order ctc) v) (continuation-prompt-tag? v)) @@ -1074,7 +1075,8 @@ '(expected: "~s" given: "~e") (contract-name ctc) val)) - (proxy val proj1 proj2)))) + (proxy val proj1 proj2 + impersonator-prop:contracted ctc)))) (define ((continuation-mark-key/c-first-order ctc) v) (continuation-mark-key? v)) diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 0286c604f5..b5d7573dca 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -4218,6 +4218,15 @@ pt)]) (do-test))) + (test/spec-passed/result + 'prompt-tag/c-has-contract + '(let ([pt (contract (prompt-tag/c string? number?) + (make-continuation-prompt-tag) + 'pos + 'neg)]) + (has-contract? pt)) + #t) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; continuation-mark-key/c @@ -4369,6 +4378,16 @@ 'neg)]) (continuation-mark-set-first #f ctc-mark))) + (test/spec-passed/result + 'continuation-mark-key/c-has-contract + '(let* ([mark (make-continuation-mark-key)] + [ctc-mark (contract (continuation-mark-key/c number?) + mark + 'pos + 'neg)]) + (has-contract? ctc-mark)) + #t) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; make-contract From 25f142299b59c6fd3cf4375a5a8651d529d6d884 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 5 Nov 2012 16:14:47 -0700 Subject: [PATCH 167/221] fix propagation of "multiple result" flag when optimizing `begin0' --- collects/tests/racket/optimize.rktl | 11 +++++++++++ src/racket/src/optimize.c | 7 +++++-- 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/collects/tests/racket/optimize.rktl b/collects/tests/racket/optimize.rktl index ed5a715717..a28af619e6 100644 --- a/collects/tests/racket/optimize.rktl +++ b/collects/tests/racket/optimize.rktl @@ -2450,6 +2450,17 @@ [read-accept-compiled #t]) (eval (read (open-input-bytes (get-output-bytes o2))))) exn:fail:read?)) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; make sure `begin0' propertly propagates "multiple results" flags + +(test '(1 2 3) (lambda () + (call-with-values + (lambda () (begin0 + (values 1 2 3) + (newline))) + list))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/src/racket/src/optimize.c b/src/racket/src/optimize.c index 133c99ea1d..bfa1eee813 100644 --- a/src/racket/src/optimize.c +++ b/src/racket/src/optimize.c @@ -3318,7 +3318,7 @@ case_lambda_shift(Scheme_Object *data, int delta, int after_depth) static Scheme_Object * begin0_optimize(Scheme_Object *obj, Optimize_Info *info, int context) { - int i, count, drop = 0, prev_size; + int i, count, drop = 0, prev_size, single_result = 0; Scheme_Sequence *s = (Scheme_Sequence *)obj; Scheme_Object *le; @@ -3333,6 +3333,9 @@ begin0_optimize(Scheme_Object *obj, Optimize_Info *info, int context) ? scheme_optimize_result_context(context) : 0)); + if (!i) + single_result = info->single_result; + /* Inlining and constant propagation can expose omittable expressions. */ if (i && scheme_omittable_expr(le, -1, -1, 0, info, NULL, -1, 0)) { @@ -3367,8 +3370,8 @@ begin0_optimize(Scheme_Object *obj, Optimize_Info *info, int context) obj = (Scheme_Object *)s2; } - /* Optimization of expression 0 has already set single_result */ info->preserves_marks = 1; + info->single_result = single_result; info->size += 1; From 7acfc80d79eb851bc0137678428078c7085ea8f9 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 5 Nov 2012 18:54:57 -0500 Subject: [PATCH 168/221] Fix bogus method name in interface contract errors. Closes PR 13238 --- collects/racket/private/class-internal.rkt | 10 +++++----- collects/tests/racket/contract-test.rktl | 13 +++++++++++++ 2 files changed, 18 insertions(+), 5 deletions(-) diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index 1348cfd379..5eaf2a0e27 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -2991,7 +2991,7 @@ An example ;; value server) is taking responsibility for any interface-contracted ;; methods) (define info (replace-ictc-blame (cadr entry) #f (blame-positive blame))) - (vector-set! methods i (concretize-ictc-method (car entry) info))))) + (vector-set! methods i (concretize-ictc-method m (car entry) info))))) ;; Now apply projections (for ([m (in-list ctc-methods)] [c (in-list (class/c-method-contracts ctc))]) @@ -3975,21 +3975,21 @@ An example (define entry (vector-ref meths index)) (define meth (car entry)) (define ictc-infos (replace-ictc-blame (cadr entry) #f blame)) - (define wrapped-meth (concretize-ictc-method meth ictc-infos)) + (define wrapped-meth (concretize-ictc-method m meth ictc-infos)) (vector-set! meths index wrapped-meth))) (hash-set! (class-ictc-classes cls) blame c) c)])) -;; method info -> method +;; name method info -> method ;; appropriately wraps the method with interface contracts -(define (concretize-ictc-method meth info) +(define (concretize-ictc-method m meth info) (for/fold ([meth meth]) ([info (in-list info)]) (define ctc (car info)) (define pos-blame (caddr info)) (define neg-blame (cadddr info)) - (contract ctc meth pos-blame neg-blame))) + (contract ctc meth pos-blame neg-blame m #f))) (define (do-make-object blame class by-pos-args named-args) (unless (class? class) diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index b5d7573dca..b07f2353f7 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -9013,6 +9013,19 @@ (with-contract region #:result integer? (send (new c2%) m 3)))) + + (contract-error-test + 'interface-method-name-1 + #'(begin + (eval '(module imn-bug scheme/base + (require scheme/class) + (define i<%> (interface () [m (->m integer? integer?)])) + (define c% (class* object% (i<%>) (super-new) (define/public (m x) x))) + (send (new c%) m "foo"))) + (eval '(require 'imn-bug))) + (λ (x) + (and (exn:fail:contract:blame? x) + (regexp-match #rx"m: contract violation" (exn-message x))))) ; ; From 777efd4a58f4b63ce7b9e118695550bc6ba1157b Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Sun, 4 Nov 2012 07:39:00 -0700 Subject: [PATCH 169/221] starting gui tests early and enabling more parallelism --- collects/meta/drdr/job-queue.rkt | 100 +++++++++++++++++++++++++++++++ collects/meta/drdr/plt-build.rkt | 67 +++++++++++---------- 2 files changed, 135 insertions(+), 32 deletions(-) create mode 100644 collects/meta/drdr/job-queue.rkt diff --git a/collects/meta/drdr/job-queue.rkt b/collects/meta/drdr/job-queue.rkt new file mode 100644 index 0000000000..c48dbbd568 --- /dev/null +++ b/collects/meta/drdr/job-queue.rkt @@ -0,0 +1,100 @@ +#lang racket/base +(require racket/list + racket/match + racket/local + racket/contract + racket/async-channel) + +(define current-worker (make-parameter #f)) + +(define-struct job-queue (async-channel)) +(define-struct job (paramz thunk)) +(define-struct done ()) + +(define (make-queue how-many) + (define jobs-ch (make-async-channel)) + (define work-ch (make-async-channel)) + (define done-ch (make-async-channel)) + (define (working-manager spaces accept-new? jobs continues) + (if (and (not accept-new?) + (empty? jobs) + (empty? continues)) + (killing-manager how-many) + (apply + sync + (if (and accept-new? + (not (zero? spaces))) + (handle-evt + jobs-ch + (match-lambda + [(? job? the-job) + (working-manager (sub1 spaces) accept-new? (list* the-job jobs) continues)] + [(? done?) + (working-manager spaces #f jobs continues)])) + never-evt) + (handle-evt + done-ch + (lambda (reply-ch) + (working-manager spaces accept-new? jobs (list* reply-ch continues)))) + (if (empty? jobs) + never-evt + (handle-evt + (async-channel-put-evt work-ch (first jobs)) + (lambda (_) + (working-manager spaces accept-new? (rest jobs) continues)))) + (map + (lambda (reply-ch) + (handle-evt + (async-channel-put-evt reply-ch 'continue) + (lambda (_) + (working-manager (add1 spaces) accept-new? jobs (remq reply-ch continues))))) + continues)))) + (define (killing-manager left) + (unless (zero? left) + (sync + (handle-evt + done-ch + (lambda (reply-ch) + (async-channel-put reply-ch 'stop) + (killing-manager (sub1 left))))))) + (define (worker i) + (match (async-channel-get work-ch) + [(struct job (paramz thunk)) + (call-with-parameterization + paramz + (lambda () + (parameterize ([current-worker i]) + (thunk)))) + (local [(define reply-ch (make-async-channel))] + (async-channel-put done-ch reply-ch) + (local [(define reply-v (async-channel-get reply-ch))] + (case reply-v + [(continue) (worker i)] + [(stop) (void)] + [else + (error 'worker "Unknown reply command")])))])) + (define the-workers + (for/list ([i (in-range 0 how-many)]) + (thread (lambda () + (worker i))))) + (define the-manager + (thread (lambda () (working-manager how-many #t empty empty)))) + (make-job-queue jobs-ch)) + +(define (submit-job! jobq thunk) + (async-channel-put + (job-queue-async-channel jobq) + (make-job (current-parameterization) + thunk))) + +(define (stop-job-queue! jobq) + (async-channel-put + (job-queue-async-channel jobq) + (make-done))) + +(provide/contract + [current-worker (parameter/c (or/c false/c exact-nonnegative-integer?))] + [job-queue? (any/c . -> . boolean?)] + [rename make-queue make-job-queue (exact-nonnegative-integer? . -> . job-queue?)] + [submit-job! (job-queue? (-> any) . -> . void)] + [stop-job-queue! (job-queue? . -> . void)]) diff --git a/collects/meta/drdr/plt-build.rkt b/collects/meta/drdr/plt-build.rkt index d1d3d10feb..4e2c6be73d 100644 --- a/collects/meta/drdr/plt-build.rkt +++ b/collects/meta/drdr/plt-build.rkt @@ -1,7 +1,7 @@ #lang racket (require racket/file racket/runtime-path - (planet jaymccarthy/job-queue) + "job-queue.rkt" "metadata.rkt" "run-collect.rkt" "cache.rkt" @@ -165,8 +165,8 @@ thunk (λ () ;; Close the output ports - #;(close-input-port stdout) - #;(close-input-port stderr) + ;;(close-input-port stdout) + ;;(close-input-port stderr) ;; Kill the guard (kill-thread waiter) @@ -200,8 +200,7 @@ (path->string (build-path trunk-dir "bin" "gracket"))) (define collects-pth (build-path trunk-dir "collects")) - ;; XXX Use a single GUI thread so that other non-GUI apps can run in parallel - (define gui-lock (make-semaphore 1)) + (define gui-workers (make-job-queue 1)) (define test-workers (make-job-queue (number-of-cpus))) (define (test-directory dir-pth upper-sema) (define dir-log (build-path (trunk->log dir-pth) ".index.test")) @@ -224,6 +223,7 @@ (define directory? (directory-exists? pth)) (cond [directory? + ;; XXX do this in parallel? (test-directory pth dir-sema)] [else (define log-pth (trunk->log pth)) @@ -236,40 +236,46 @@ (current-subprocess-timeout-seconds))) (define pth-cmd/general (path-command-line pth)) - (define pth-cmd + (define-values + (pth-cmd the-queue) (match pth-cmd/general [#f - #f] + (values #f #f)] [(list-rest (or 'mzscheme 'racket) rst) - (lambda (k) - (k (list* racket-path rst)))] + (values + (lambda (k) + (k (list* racket-path rst))) + test-workers)] [(list-rest 'mzc rst) - (lambda (k) (k (list* mzc-path rst)))] + (values + (lambda (k) (k (list* mzc-path rst))) + test-workers)] [(list-rest 'raco rst) - (lambda (k) (k (list* raco-path rst)))] + (values + (lambda (k) (k (list* raco-path rst))) + test-workers)] [(list-rest (or 'mred 'mred-text 'gracket 'gracket-text) rst) - (if (on-unix?) - (lambda (k) - (call-with-semaphore - gui-lock - (λ () - (k - (list* gracket-path - "-display" - (format - ":~a" - (cpu->child - (current-worker))) - rst))))) - #f)] + (values + (if (on-unix?) + (lambda (k) + (k + (list* gracket-path + "-display" + (format + ":~a" + (cpu->child + (current-worker))) + rst))) + #f) + gui-workers)] [_ - #f])) + (values #f #f)])) (cond [pth-cmd (submit-job! - test-workers + the-queue (lambda () (dynamic-wind void @@ -331,7 +337,8 @@ (notify! "All testing scheduled... waiting for completion") (semaphore-wait top-sema)) (notify! "Stopping testing") - (stop-job-queue! test-workers)) + (stop-job-queue! test-workers) + (stop-job-queue! gui-workers)) (define (recur-many i r f) (if (zero? i) @@ -409,10 +416,6 @@ (list "-d" (format ":~a" i) "--sm-disable" "--no-composite") - #;empty - #;(list "-display" - (format ":~a" i) - "-rc" "/home/pltdrdr/.fluxbox/init") inner))))) (start-x-server From bf6adf0c4a2d9c46d8bce8ffd3ccf4adf62d1de3 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 5 Nov 2012 22:28:47 -0700 Subject: [PATCH 170/221] Adding the xorg config --- collects/meta/drdr/xorg.conf | 89 ++++++++++++++++++++++++++++++++++++ 1 file changed, 89 insertions(+) create mode 100644 collects/meta/drdr/xorg.conf diff --git a/collects/meta/drdr/xorg.conf b/collects/meta/drdr/xorg.conf new file mode 100644 index 0000000000..001b35cc98 --- /dev/null +++ b/collects/meta/drdr/xorg.conf @@ -0,0 +1,89 @@ +Section "ServerFlags" + option "AllowMouseOpenFail" +EndSection + +Section "ServerLayout" + Identifier "X.org Configured" + Screen 0 "Screen0" 0 0 + InputDevice "Mouse0" "CorePointer" + InputDevice "Keyboard0" "CoreKeyboard" +EndSection + +Section "Files" + ModulePath "/usr/lib/xorg/modules" + FontPath "/usr/share/fonts/X11/misc" + FontPath "/usr/share/fonts/X11/cyrillic" + FontPath "/usr/share/fonts/X11/100dpi/:unscaled" + FontPath "/usr/share/fonts/X11/75dpi/:unscaled" + FontPath "/usr/share/fonts/X11/Type1" + FontPath "/usr/share/fonts/X11/100dpi" + FontPath "/usr/share/fonts/X11/75dpi" + FontPath "/var/lib/defoma/x-ttcidfont-conf.d/dirs/TrueType" + FontPath "built-ins" +EndSection + +Section "Module" + Load "dbe" + Load "dri" + Load "glx" + Load "record" + Load "extmod" + Load "dri2" +EndSection + +Section "InputDevice" + Identifier "Keyboard0" + Driver "void" +EndSection + +Section "InputDevice" + Identifier "Mouse0" + Driver "void" +EndSection + +Section "Monitor" + Identifier "Monitor0" + VendorName "AVO" + ModelName "Smart Cable" + HorizSync 24.0 - 61.0 + VertRefresh 56.0 - 75.0 +EndSection + +Section "Device" + Identifier "Card0" + Driver "mga" + VendorName "Matrox Graphics, Inc." + BoardName "MGA G200e [Pilot] ServerEngines (SEP1)" + BusID "PCI:30:0:0" +EndSection + +Section "Screen" + Identifier "Screen0" + Device "Card0" + Monitor "Monitor0" + SubSection "Display" + Viewport 0 0 + Depth 1 + EndSubSection + SubSection "Display" + Viewport 0 0 + Depth 4 + EndSubSection + SubSection "Display" + Viewport 0 0 + Depth 8 + EndSubSection + SubSection "Display" + Viewport 0 0 + Depth 15 + EndSubSection + SubSection "Display" + Viewport 0 0 + Depth 16 + EndSubSection + SubSection "Display" + Viewport 0 0 + Depth 24 + EndSubSection +EndSection + From f311676096bbcb216c0a601ba0191c3391defb8b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 5 Nov 2012 09:17:18 -0600 Subject: [PATCH 171/221] clarify the way the undoable? flag in begin-edit-sequence works --- collects/scribblings/gui/editor-intf.scrbl | 53 +++++++++++++++++++++- 1 file changed, 51 insertions(+), 2 deletions(-) diff --git a/collects/scribblings/gui/editor-intf.scrbl b/collects/scribblings/gui/editor-intf.scrbl index 4555fda0fd..7f16be314f 100644 --- a/collects/scribblings/gui/editor-intf.scrbl +++ b/collects/scribblings/gui/editor-intf.scrbl @@ -1,5 +1,9 @@ #lang scribble/doc -@(require "common.rkt") +@(require "common.rkt" + scribble/eval) + +@(define editor-eval (make-base-eval)) +@(editor-eval '(require racket/class)) @definterface/title[editor<%> ()]{ @@ -206,7 +210,52 @@ See also @method[editor<%> refresh-delayed?] and @method[editor<%> If the @racket[undoable?] flag is @racket[#f], then the changes made in the sequence cannot be reversed through the @method[editor<%> - undo] method. This flag is only effective for the outermost + undo] method. To accomplish this, the editor just does not add + entries to the undo log when in an edit sequence where the + @racket[undoable?] flag is @racket[#f]. So, for example, if an + @litchar{a} is inserted into the editor and then a @litchar{b} + is inserted, and then an un-undoable edit-sequence begins, + and the @litchar{a} is colored red, and then the edit-sequence ends, + then an undo will remove the @litchar{b}, leaving the @litchar{a} + colored red. + + This behavior also means that editors can get confused. Consider + this program: + @examples[#:eval + editor-eval + (eval:alts (define t (new text%)) + ;; this is a pretty horrible hack, but + ;; the sequence of calls below behaves + ;; the way they are predicted to as of + ;; the moment of this commit + (define t + (new (class object% + (define/public (set-max-undo-history x) (void)) + (define/public (insert . args) (void)) + (define/public (begin-edit-sequence a b) (void)) + (define/public (end-edit-sequence) (void)) + (define/public (undo) (void)) + (define first? #t) + (define/public (get-text) + (cond + [first? + (set! first? #f) + "cab"] + [else "cb"])) + (super-new))))) + (send t set-max-undo-history 'forever) + (send t insert "a") + (send t insert "b") + (send t begin-edit-sequence #f #f) + (send t insert "c" 0 0) + (send t end-edit-sequence) + (send t get-text) + (send t undo) + (send t get-text)] + You might hope that the undo would remove the @litchar{b}, but it removes + the @litchar{a}. + + The @racket[undoable?] flag is only effective for the outermost @method[editor<%> begin-edit-sequence] when nested sequences are used. Note that, for a @racket[text%] object, the character-inserting version of @method[text% insert] interferes with sequence-based undo From 3e8cd0277fb148d1868b6d0a09f040f96d192041 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 6 Nov 2012 06:48:29 -0600 Subject: [PATCH 172/221] increase snips test timeout --- collects/meta/props | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/meta/props b/collects/meta/props index 71eaafb24a..f42d06ca46 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1029,7 +1029,7 @@ path/s is either such a string or a list of them. "collects/tests/drracket/repl-test-misc.rkt" drdr:command-line (gracket *) "collects/tests/drracket/repl-test-raw.rkt" drdr:command-line (gracket *) drdr:timeout 300 "collects/tests/drracket/snip/collapsed.rkt" drdr:command-line (racket "-l" "racket/gui/base" "-t" *) -"collects/tests/drracket/snip/run-all.rkt" drdr:timeout 400 +"collects/tests/drracket/snip/run-all.rkt" drdr:timeout 500 "collects/tests/drracket/snips.rkt" drdr:command-line (gracket *) "collects/tests/drracket/syncheck-test.rkt" drdr:command-line (gracket *) drdr:timeout 200 "collects/tests/drracket/teaching-lang-coverage.rkt" responsible (robby matthias) drdr:command-line (gracket *) From 3bbf6035d156005f5d66297169d2b5a26abfc40a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 5 Nov 2012 16:29:17 -0600 Subject: [PATCH 173/221] adjust the language dialog based on feedback from dev@ --- .../private/language-configuration.rkt | 127 +++++++++++------- .../private/english-string-constants.rkt | 9 +- 2 files changed, 86 insertions(+), 50 deletions(-) diff --git a/collects/drracket/private/language-configuration.rkt b/collects/drracket/private/language-configuration.rkt index 1ef2dceb7f..b0abd765c3 100644 --- a/collects/drracket/private/language-configuration.rkt +++ b/collects/drracket/private/language-configuration.rkt @@ -1,5 +1,5 @@ #lang racket/base - (require (prefix-in : mred/mred) ;; ensure that this module is always loaded since it is shared below for pretty big +(require (prefix-in : mred/mred) ;; ensure that this module is always loaded since it is shared below for pretty big racket/unit mrlib/hierlist racket/class @@ -11,7 +11,11 @@ string-constants framework setup/getinfo + setup/xref + scribble/xref + net/url syntax/toplevel + browser/external (only-in mzlib/struct make-->vector)) (define original-output (current-output-port)) @@ -38,16 +42,14 @@ [(shift) (send evt get-shiftdown)] [(option) (send evt get-alt-down)])) shortcut-prefix)) - (values (string-append (string-constant use-language-in-source) - (format " (~aU)" menukey-string)) + (values (string-append (string-constant the-racket-language) + (format " (~aR)" menukey-string)) (string-append (string-constant teaching-languages) (format " (~aT)" menukey-string)) (string-append (string-constant other-languages) (format " (~aO)" menukey-string)) mouse-event-uses-shortcut-prefix?))) - (define sc-lang-in-source-discussion (string-constant lang-in-source-discussion)) - (provide language-configuration@) (define-unit language-configuration@ @@ -1105,55 +1107,86 @@ [else #f]))))) (define (add-discussion p) - (let* ([t (new text:standard-style-list%)] - [c (new editor-canvas% + (define t (new (text:hide-caret/selection-mixin text:standard-style-list%))) + (define c (new editor-canvas% [stretchable-width #t] [horizontal-inset 0] [vertical-inset 0] [parent p] [style '(no-border no-vscroll no-hscroll transparent)] - [editor t])]) - (send t set-styles-sticky #f) - (send t set-autowrap-bitmap #f) - (let* ([size-sd (make-object style-delta% 'change-size (send normal-control-font get-point-size))] - [do-insert - (λ (str tt-style?) - (let ([before (send t last-position)]) - (send t insert str before before) - (cond - [tt-style? - (send t change-style - (send (send t get-style-list) find-named-style "Standard") - before (send t last-position))] - [else - (send t change-style - (send (send t get-style-list) basic-style) - before (send t last-position))]) - (send t change-style size-sd before (send t last-position))))]) - (when (send normal-control-font get-size-in-pixels) - (send size-sd set-size-in-pixels-on #t)) - (let loop ([strs (regexp-split #rx"#lang" sc-lang-in-source-discussion)]) - (do-insert (car strs) #f) - (unless (null? (cdr strs)) - (do-insert "#lang" #t) - (loop (cdr strs))))) - (send t hide-caret #t) - - (send t auto-wrap #t) - (send t lock #t) - (send c accept-tab-focus #f) - (send c allow-tab-exit #t) - c)) + [editor t])) + (send t set-styles-sticky #f) + (send t set-autowrap-bitmap #f) + (define size-sd (make-object style-delta% 'change-size (send normal-control-font get-point-size))) + (define (do-insert str tt-style?) + (define before (send t last-position)) + (send t insert str before before) + (cond + [tt-style? + (send t change-style + (send (send t get-style-list) find-named-style "Standard") + before (send t last-position))] + [else + (send t change-style + (send (send t get-style-list) basic-style) + before (send t last-position))]) + (send t change-style size-sd before (send t last-position))) + (when (send normal-control-font get-size-in-pixels) + (send size-sd set-size-in-pixels-on #t)) + (let loop ([strs (regexp-split #rx"#lang" (string-constant racket-language-discussion))]) + (do-insert (car strs) #f) + (unless (null? (cdr strs)) + (do-insert "#lang" #t) + (loop (cdr strs)))) + + (define xref-chan (make-channel)) + (thread + (λ () + (define xref (load-collections-xref)) + (let loop () + (channel-put xref-chan xref) + (loop)))) + + (for ([lang (in-list '(racket typed/racket scribble/base))]) + (do-insert (format " #lang ~a" lang) #t) + (do-insert " [" #f) + (define before (send t last-position)) + (do-insert "docs" #f) + (define after (send t last-position)) + (do-insert "]\n" #f) + (send t set-clickback before after + (λ (t start end) + (define-values (path tag) (xref-tag->path+anchor (channel-get xref-chan) `(mod-path ,(symbol->string lang)))) + (define url (path->url path)) + (define url2 (if tag + (make-url (url-scheme url) + (url-user url) + (url-host url) + (url-port url) + (url-path-absolute? url) + (url-path url) + (url-query url) + tag) + url)) + (send-url (url->string url2))))) + + (define kmp (send t set-keymap (keymap:get-editor))) + + (send t hide-caret #t) + (send t auto-wrap #t) + (send t lock #t) + (send c accept-tab-focus #f) + (send c allow-tab-exit #t) + c) (define (size-discussion-canvas canvas) - (let ([t (send canvas get-editor)]) - - (let ([by (box 0)]) - (send t position-location - (send t line-end-position (send t last-line)) - #f - by) - (send canvas min-height (+ (ceiling (inexact->exact (unbox by))) 24))))) + (define t (send canvas get-editor)) + (define by (box 0)) + (send t position-location + (send t line-end-position (send t last-line)) + #f + by) + (send canvas min-height (+ (ceiling (inexact->exact (unbox by))) 24))) (define section-style-delta (make-object style-delta% 'change-bold)) (send section-style-delta set-delta-foreground "medium blue") diff --git a/collects/string-constants/private/english-string-constants.rkt b/collects/string-constants/private/english-string-constants.rkt index 1488589ad1..4978c8d7f8 100644 --- a/collects/string-constants/private/english-string-constants.rkt +++ b/collects/string-constants/private/english-string-constants.rkt @@ -1160,10 +1160,13 @@ please adhere to these guidelines: (module-language-auto-text "Automatic #lang line") ;; shows up in the details section of the module language ;; for the upper portion of the language dialog - (use-language-in-source "Use the language declared in the source") + (the-racket-language "The Racket Language") (choose-a-language "Choose a language") - (lang-in-source-discussion - "The #lang line at the start of a program declares its language. This is the default and preferred mode for DrRacket.") + (racket-language-discussion + "Start your program with #lang to specify the desired dialect. For example:\n\n") + + ;; for the 'new drracket user' dialog + (use-language-in-source "Use the language declared in the source") ;;; from the `not a language language' used initially in drscheme. (must-choose-language "DrRacket cannot process programs until you choose a programming language.") From 95ff9637c06525f3f60fd30a11b1eed32617d6d3 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 6 Nov 2012 12:11:42 -0600 Subject: [PATCH 174/221] make ellipsis clickable --- .../private/language-configuration.rkt | 29 +++++++++++++++---- 1 file changed, 24 insertions(+), 5 deletions(-) diff --git a/collects/drracket/private/language-configuration.rkt b/collects/drracket/private/language-configuration.rkt index b0abd765c3..12d0db5b86 100644 --- a/collects/drracket/private/language-configuration.rkt +++ b/collects/drracket/private/language-configuration.rkt @@ -475,10 +475,7 @@ (λ (this-rb evt) (use-chosen-language-rb-callback))])) (define (use-chosen-language-rb-callback) - (when (member ellipsis-spacer-panel (send languages-hier-list-panel get-children)) - (send languages-hier-list-panel change-children - (λ (l) - (list languages-hier-list-spacer other-languages-hier-list)))) + (show-other-languages) (when most-recent-languages-hier-list-selection (select-a-language-in-hierlist other-languages-hier-list most-recent-languages-hier-list-selection)) @@ -486,6 +483,11 @@ (send use-teaching-language-rb set-selection #f) (send teaching-languages-hier-list select #f) (send other-languages-hier-list focus)) + (define (show-other-languages) + (when (member ellipsis-spacer-panel (send languages-hier-list-panel get-children)) + (send languages-hier-list-panel change-children + (λ (l) + (list languages-hier-list-spacer other-languages-hier-list))))) (define languages-hier-list-panel (new horizontal-panel% [parent languages-choice-panel] @@ -494,7 +496,24 @@ [parent languages-hier-list-panel] [stretchable-width #f] [min-width 32])) - (define ellipsis-message (new message% [label "..."] [parent languages-hier-list-panel])) + (define ellipsis-message (new (class canvas% + (define/override (on-paint) + (define dc (get-dc)) + (send dc set-font normal-control-font) + (send dc draw-text "..." 0 0)) + (define/override (on-event evt) + (when (send evt button-up?) + (show-other-languages))) + (inherit get-dc min-width min-height) + (super-new [style '(transparent)] + [parent languages-hier-list-panel] + [stretchable-width #f] + [stretchable-height #t]) + (let () + (define dc (get-dc)) + (define-values (w h _1 _2) (send dc get-text-extent "..." normal-control-font)) + (min-width (inexact->exact (ceiling w))) + (min-height (inexact->exact (ceiling h))))))) (define languages-hier-list-spacer (new horizontal-panel% [parent languages-hier-list-panel] From d49aeecd8a09654cc0986361b1c2412ea55df526 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 6 Nov 2012 12:35:04 -0500 Subject: [PATCH 175/221] Switch the teachpack wrappers to `racket/base'. (I think that the change to `teachpack/htdp/dir' is fine too, looks like the previous code is dealing with the old restriction of not requiring a binding that conflicts with the language bindings.) --- collects/teachpack/htdp/arrow-gui.ss | 6 +++--- collects/teachpack/htdp/arrow.ss | 6 +++--- collects/teachpack/htdp/convert.ss | 5 ++--- collects/teachpack/htdp/dir.ss | 8 +++----- collects/teachpack/htdp/docs.ss | 6 +++--- collects/teachpack/htdp/draw.ss | 6 +++--- collects/teachpack/htdp/elevator.ss | 6 +++--- collects/teachpack/htdp/graphing.ss | 6 +++--- collects/teachpack/htdp/guess-gui.ss | 6 +++--- collects/teachpack/htdp/guess.ss | 6 +++--- collects/teachpack/htdp/gui.ss | 6 +++--- collects/teachpack/htdp/hangman.ss | 6 +++--- collects/teachpack/htdp/image.ss | 7 +++---- collects/teachpack/htdp/lkup-gui.ss | 6 +++--- collects/teachpack/htdp/master.ss | 6 +++--- collects/teachpack/htdp/matrix.ss | 6 +++--- collects/teachpack/htdp/servlet.ss | 6 +++--- collects/teachpack/htdp/servlet2.ss | 6 +++--- collects/teachpack/htdp/show-queen.ss | 6 +++--- collects/teachpack/htdp/testing.ss | 2 +- collects/teachpack/htdp/world.ss | 6 +++--- 21 files changed, 60 insertions(+), 64 deletions(-) diff --git a/collects/teachpack/htdp/arrow-gui.ss b/collects/teachpack/htdp/arrow-gui.ss index 1c40e37965..09de6dab6a 100644 --- a/collects/teachpack/htdp/arrow-gui.ss +++ b/collects/teachpack/htdp/arrow-gui.ss @@ -1,3 +1,3 @@ -#cs(module arrow-gui mzscheme - (require htdp/arrow-gui) - (provide (all-from htdp/arrow-gui))) +#lang racket/base +(require htdp/arrow-gui) +(provide (all-from-out htdp/arrow-gui)) diff --git a/collects/teachpack/htdp/arrow.ss b/collects/teachpack/htdp/arrow.ss index 1eab296882..e51265ad39 100644 --- a/collects/teachpack/htdp/arrow.ss +++ b/collects/teachpack/htdp/arrow.ss @@ -1,3 +1,3 @@ -#cs(module arrow mzscheme - (require htdp/arrow) - (provide (all-from htdp/arrow))) +#lang racket/base +(require htdp/arrow) +(provide (all-from-out htdp/arrow)) diff --git a/collects/teachpack/htdp/convert.ss b/collects/teachpack/htdp/convert.ss index 823aa27faa..f33b1fa1b0 100644 --- a/collects/teachpack/htdp/convert.ss +++ b/collects/teachpack/htdp/convert.ss @@ -1,4 +1,3 @@ -#lang mzscheme - +#lang racket/base (require htdp/convert) -(provide (all-from htdp/convert)) +(provide (all-from-out htdp/convert)) diff --git a/collects/teachpack/htdp/dir.ss b/collects/teachpack/htdp/dir.ss index 2dd01be54c..b1692a054a 100644 --- a/collects/teachpack/htdp/dir.ss +++ b/collects/teachpack/htdp/dir.ss @@ -1,5 +1,3 @@ -#cs(module dir mzscheme - (require (all-except htdp/dir file-size) - (rename htdp/dir file--size file-size)) - (provide (rename file--size file-size) - (all-from-except htdp/dir file--size))) +#lang racket/base +(require htdp/dir) +(provide (all-from-out htdp/dir)) diff --git a/collects/teachpack/htdp/docs.ss b/collects/teachpack/htdp/docs.ss index 90d337f7b4..1cf2d59c00 100644 --- a/collects/teachpack/htdp/docs.ss +++ b/collects/teachpack/htdp/docs.ss @@ -1,3 +1,3 @@ -#cs(module docs mzscheme - (require htdp/docs) - (provide (all-from htdp/docs))) +#lang racket/base +(require htdp/docs) +(provide (all-from-out htdp/docs)) diff --git a/collects/teachpack/htdp/draw.ss b/collects/teachpack/htdp/draw.ss index 332516c0cf..119e2b196c 100644 --- a/collects/teachpack/htdp/draw.ss +++ b/collects/teachpack/htdp/draw.ss @@ -1,3 +1,3 @@ -#cs(module draw mzscheme - (require htdp/draw) - (provide (all-from htdp/draw))) +#lang racket/base +(require htdp/draw) +(provide (all-from-out htdp/draw)) diff --git a/collects/teachpack/htdp/elevator.ss b/collects/teachpack/htdp/elevator.ss index cfa84005c8..2612f8edaf 100644 --- a/collects/teachpack/htdp/elevator.ss +++ b/collects/teachpack/htdp/elevator.ss @@ -1,3 +1,3 @@ -#cs(module elevator mzscheme - (require htdp/elevator) - (provide (all-from htdp/elevator))) +#lang racket/base +(require htdp/elevator) +(provide (all-from-out htdp/elevator)) diff --git a/collects/teachpack/htdp/graphing.ss b/collects/teachpack/htdp/graphing.ss index a089e85fea..cab3946130 100644 --- a/collects/teachpack/htdp/graphing.ss +++ b/collects/teachpack/htdp/graphing.ss @@ -1,3 +1,3 @@ -#cs(module graphing mzscheme - (require htdp/graphing) - (provide (all-from htdp/graphing))) +#lang racket/base +(require htdp/graphing) +(provide (all-from-out htdp/graphing)) diff --git a/collects/teachpack/htdp/guess-gui.ss b/collects/teachpack/htdp/guess-gui.ss index f640a330bf..57381b3ec8 100644 --- a/collects/teachpack/htdp/guess-gui.ss +++ b/collects/teachpack/htdp/guess-gui.ss @@ -1,3 +1,3 @@ -#cs(module guess-gui mzscheme - (require htdp/guess-gui) - (provide (all-from htdp/guess-gui))) +#lang racket/base +(require htdp/guess-gui) +(provide (all-from-out htdp/guess-gui)) diff --git a/collects/teachpack/htdp/guess.ss b/collects/teachpack/htdp/guess.ss index f9e7eeab09..044036bb0b 100644 --- a/collects/teachpack/htdp/guess.ss +++ b/collects/teachpack/htdp/guess.ss @@ -1,3 +1,3 @@ -#cs(module guess mzscheme - (require htdp/guess) - (provide (all-from htdp/guess))) +#lang racket/base +(require htdp/guess) +(provide (all-from-out htdp/guess)) diff --git a/collects/teachpack/htdp/gui.ss b/collects/teachpack/htdp/gui.ss index 4243105307..9dd92acf47 100644 --- a/collects/teachpack/htdp/gui.ss +++ b/collects/teachpack/htdp/gui.ss @@ -1,3 +1,3 @@ -#cs(module gui mzscheme - (require htdp/gui) - (provide (all-from htdp/gui))) +#lang racket/base +(require htdp/gui) +(provide (all-from-out htdp/gui)) diff --git a/collects/teachpack/htdp/hangman.ss b/collects/teachpack/htdp/hangman.ss index 5c7a1152e8..4778215296 100644 --- a/collects/teachpack/htdp/hangman.ss +++ b/collects/teachpack/htdp/hangman.ss @@ -1,3 +1,3 @@ -#cs(module hangman mzscheme - (provide (all-from htdp/hangman)) - (require htdp/hangman)) +#lang racket/base +(require htdp/hangman) +(provide (all-from-out htdp/hangman)) diff --git a/collects/teachpack/htdp/image.ss b/collects/teachpack/htdp/image.ss index 693d8fb533..953bb5176f 100644 --- a/collects/teachpack/htdp/image.ss +++ b/collects/teachpack/htdp/image.ss @@ -1,4 +1,3 @@ -(module image mzscheme - (require htdp/image lang/prim) - (provide (all-from htdp/image)) -) +#lang racket/base +(require htdp/image lang/prim) +(provide (all-from-out htdp/image)) diff --git a/collects/teachpack/htdp/lkup-gui.ss b/collects/teachpack/htdp/lkup-gui.ss index 8750cb48b8..253057829d 100644 --- a/collects/teachpack/htdp/lkup-gui.ss +++ b/collects/teachpack/htdp/lkup-gui.ss @@ -1,3 +1,3 @@ -#cs(module lkup-gui mzscheme - (require htdp/lkup-gui) - (provide (all-from htdp/lkup-gui))) +#lang racket/base +(require htdp/lkup-gui) +(provide (all-from-out htdp/lkup-gui)) diff --git a/collects/teachpack/htdp/master.ss b/collects/teachpack/htdp/master.ss index 94a3794737..1ea865bc88 100644 --- a/collects/teachpack/htdp/master.ss +++ b/collects/teachpack/htdp/master.ss @@ -1,3 +1,3 @@ -#cs(module master mzscheme - (require htdp/master) - (provide (all-from htdp/master))) +#lang racket/base +(require htdp/master) +(provide (all-from-out htdp/master)) diff --git a/collects/teachpack/htdp/matrix.ss b/collects/teachpack/htdp/matrix.ss index 16f7a3fe35..d42b89c16c 100644 --- a/collects/teachpack/htdp/matrix.ss +++ b/collects/teachpack/htdp/matrix.ss @@ -1,3 +1,3 @@ -(module matrix mzscheme - (provide (all-from htdp/matrix)) - (require htdp/matrix)) +#lang racket/base +(require htdp/matrix) +(provide (all-from-out htdp/matrix)) diff --git a/collects/teachpack/htdp/servlet.ss b/collects/teachpack/htdp/servlet.ss index cafb93e107..6188e54a9c 100644 --- a/collects/teachpack/htdp/servlet.ss +++ b/collects/teachpack/htdp/servlet.ss @@ -1,3 +1,3 @@ -#cs(module servlet mzscheme - (require htdp/servlet) - (provide (all-from htdp/servlet))) +#lang racket/base +(require htdp/servlet) +(provide (all-from-out htdp/servlet)) diff --git a/collects/teachpack/htdp/servlet2.ss b/collects/teachpack/htdp/servlet2.ss index a2b52f62f9..6eac6a0dc3 100644 --- a/collects/teachpack/htdp/servlet2.ss +++ b/collects/teachpack/htdp/servlet2.ss @@ -1,3 +1,3 @@ -#cs(module servlet2 mzscheme - (require htdp/servlet2) - (provide (all-from htdp/servlet2))) +#lang racket/base +(require htdp/servlet2) +(provide (all-from-out htdp/servlet2)) diff --git a/collects/teachpack/htdp/show-queen.ss b/collects/teachpack/htdp/show-queen.ss index b0c4f8396a..418d2f03ec 100644 --- a/collects/teachpack/htdp/show-queen.ss +++ b/collects/teachpack/htdp/show-queen.ss @@ -1,3 +1,3 @@ -(module show-queen mzscheme - (require htdp/show-queen) - (provide (all-from htdp/show-queen))) +#lang racket/base +(require htdp/show-queen) +(provide (all-from-out htdp/show-queen)) diff --git a/collects/teachpack/htdp/testing.ss b/collects/teachpack/htdp/testing.ss index 3739d03b18..458ce81eee 100644 --- a/collects/teachpack/htdp/testing.ss +++ b/collects/teachpack/htdp/testing.ss @@ -1,3 +1,3 @@ -#lang racket +#lang racket/base (require htdp/testing) (provide (all-from-out htdp/testing)) diff --git a/collects/teachpack/htdp/world.ss b/collects/teachpack/htdp/world.ss index 72004ab270..e465521f08 100644 --- a/collects/teachpack/htdp/world.ss +++ b/collects/teachpack/htdp/world.ss @@ -1,3 +1,3 @@ -(module world mzscheme - (provide (all-from htdp/world)) - (require htdp/world)) +#lang racket/base +(require htdp/world) +(provide (all-from-out htdp/world)) From 1c8001d174db69c57bfb0ee42e0ce75c2371e72e Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 6 Nov 2012 12:39:56 -0500 Subject: [PATCH 176/221] Some "obvious" switching from `racket' to `racket/base'. --- collects/eopl/eopl.rkt | 6 ++++-- collects/htdp/convert.rkt | 2 +- collects/schemeunit/gui.rkt | 2 +- collects/schemeunit/main.rkt | 2 +- collects/schemeunit/text-ui.rkt | 2 +- collects/typed/rackunit.rkt | 2 +- src/mac/install-libs.rkt | 4 ++-- 7 files changed, 11 insertions(+), 9 deletions(-) diff --git a/collects/eopl/eopl.rkt b/collects/eopl/eopl.rkt index 9fe60fb335..b466444649 100644 --- a/collects/eopl/eopl.rkt +++ b/collects/eopl/eopl.rkt @@ -1,10 +1,12 @@ -#lang racket +#lang racket/base (require "datatype.rkt" "private/sllgen.rkt" + racket/promise mzlib/trace mzlib/pretty) -(require (for-syntax "private/slldef.rkt")) +(require (for-syntax racket/base + "private/slldef.rkt")) (provide define-datatype cases) diff --git a/collects/htdp/convert.rkt b/collects/htdp/convert.rkt index 1d3515a463..660f884866 100644 --- a/collects/htdp/convert.rkt +++ b/collects/htdp/convert.rkt @@ -1,4 +1,4 @@ -#lang racket +#lang racket/base (require racket/gui) diff --git a/collects/schemeunit/gui.rkt b/collects/schemeunit/gui.rkt index c0352c651e..49c63ef440 100644 --- a/collects/schemeunit/gui.rkt +++ b/collects/schemeunit/gui.rkt @@ -1,3 +1,3 @@ -#lang racket +#lang racket/base (require rackunit/gui) (provide (all-from-out rackunit/gui)) diff --git a/collects/schemeunit/main.rkt b/collects/schemeunit/main.rkt index cf3685c786..41d8df5ecb 100644 --- a/collects/schemeunit/main.rkt +++ b/collects/schemeunit/main.rkt @@ -1,3 +1,3 @@ -#lang racket +#lang racket/base (require rackunit) (provide (all-from-out rackunit)) diff --git a/collects/schemeunit/text-ui.rkt b/collects/schemeunit/text-ui.rkt index d99ee6fffd..a5743e6c0c 100644 --- a/collects/schemeunit/text-ui.rkt +++ b/collects/schemeunit/text-ui.rkt @@ -1,3 +1,3 @@ -#lang racket +#lang racket/base (require rackunit/text-ui) (provide (all-from-out rackunit/text-ui)) diff --git a/collects/typed/rackunit.rkt b/collects/typed/rackunit.rkt index 54e18f1f3b..6b9d16d170 100644 --- a/collects/typed/rackunit.rkt +++ b/collects/typed/rackunit.rkt @@ -1,3 +1,3 @@ -#lang racket +#lang racket/base (require typed/rackunit/main) (provide (all-from-out typed/rackunit/main)) diff --git a/src/mac/install-libs.rkt b/src/mac/install-libs.rkt index 3f5ff4fb3c..ee151107a1 100644 --- a/src/mac/install-libs.rkt +++ b/src/mac/install-libs.rkt @@ -1,5 +1,5 @@ -#lang racket -(require racket/system) +#lang racket/base +(require racket/path racket/system) (define from (vector-ref (current-command-line-arguments) 0)) (define to From 5aca765989075b5acec228edbe6922f7c619613a Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 6 Nov 2012 13:01:01 -0500 Subject: [PATCH 177/221] `racket' -> `racket/base' switches in `htdp' and `2htdp'. All of these look safe. Also, see comment in `2htdp/batch-io' about the splitting thing (which should probably be revised with the extensions to `racket/string'). --- collects/2htdp/batch-io.rkt | 18 +++++++++++++----- collects/2htdp/private/check-aux.rkt | 8 ++++++-- .../2htdp/private/clauses-spec-and-process.rkt | 13 +++++++++---- collects/2htdp/private/define-keywords.rkt | 5 +++-- collects/2htdp/private/launch-many-worlds.rkt | 5 +++-- collects/2htdp/private/utilities.rkt | 4 +++- collects/htdp/dir.rkt | 2 +- 7 files changed, 38 insertions(+), 17 deletions(-) diff --git a/collects/2htdp/batch-io.rkt b/collects/2htdp/batch-io.rkt index e55a9f59d4..0d0f9d922f 100644 --- a/collects/2htdp/batch-io.rkt +++ b/collects/2htdp/batch-io.rkt @@ -1,7 +1,12 @@ -#lang racket +#lang racket/base -(require (for-syntax syntax/parse) - srfi/13 htdp/error +(require racket/function + racket/file + racket/string + racket/local + (for-syntax racket/base + syntax/parse) + htdp/error (rename-in lang/prim (first-order->higher-order f2h)) "private/csv/csv.rkt") @@ -163,10 +168,13 @@ ;; split : String [Regexp] -> [Listof String] ;; splits a string into a list of substrings using the given delimiter ;; (white space by default) +;;ELI: This shouldn't be needed now, it can use `string-split' as is +;; (also, the trimming doesn't make sense if the pattern is not a +;; space--?) (define (split str [ptn #rx"[ ]+"]) - (regexp-split ptn (string-trim-both str))) + (regexp-split ptn (string-trim str))) ;; split-lines : String -> Listof[String] ;; splits a string with newlines into a list of lines (define (split-lines str) - (map string-trim-both (split str "\r*\n"))) + (map string-trim (split str "\r*\n"))) diff --git a/collects/2htdp/private/check-aux.rkt b/collects/2htdp/private/check-aux.rkt index 851b125799..c65e2e6818 100644 --- a/collects/2htdp/private/check-aux.rkt +++ b/collects/2htdp/private/check-aux.rkt @@ -1,6 +1,10 @@ -#lang racket +#lang racket/base -(require htdp/error) +(require racket/class + racket/list + racket/bool + racket/match + htdp/error) (provide (all-defined-out)) diff --git a/collects/2htdp/private/clauses-spec-and-process.rkt b/collects/2htdp/private/clauses-spec-and-process.rkt index a031791162..0b87a767f9 100644 --- a/collects/2htdp/private/clauses-spec-and-process.rkt +++ b/collects/2htdp/private/clauses-spec-and-process.rkt @@ -1,4 +1,4 @@ -#lang racket +#lang racket/base ;; --------------------------------------------------------------------------------------------------- ;; provides functions for specifying the shape of big-bang and universe clauses: @@ -12,9 +12,14 @@ ->args contains-clause?) -(require - (for-syntax syntax/parse) - (for-template "clauses-spec-aux.rkt" racket (rename-in lang/prim (first-order->higher-order f2h)))) +(require racket/function + racket/list + racket/bool + (only-in racket/unit except) ; used only as a keyword...? + (for-syntax racket/base syntax/parse) + (for-template "clauses-spec-aux.rkt" + racket + (rename-in lang/prim (first-order->higher-order f2h)))) ;; --------------------------------------------------------------------------------------------------- ;; specifying the shape of clauses diff --git a/collects/2htdp/private/define-keywords.rkt b/collects/2htdp/private/define-keywords.rkt index 7a59aa2da8..c0cdd4fa36 100644 --- a/collects/2htdp/private/define-keywords.rkt +++ b/collects/2htdp/private/define-keywords.rkt @@ -1,4 +1,4 @@ -#lang racket +#lang racket/base ;; --------------------------------------------------------------------------------------------------- ;; provide a mechanism for defining the shape of big-bang and universe clauses @@ -6,7 +6,8 @@ (provide define-keywords DEFAULT) -(require (for-syntax syntax/parse)) +(require racket/class + (for-syntax racket/base syntax/parse)) (define-syntax (DEFAULT stx) (raise-syntax-error 'DEFAULT "used out of context" stx)) diff --git a/collects/2htdp/private/launch-many-worlds.rkt b/collects/2htdp/private/launch-many-worlds.rkt index 1ecbb1d032..88da624f20 100644 --- a/collects/2htdp/private/launch-many-worlds.rkt +++ b/collects/2htdp/private/launch-many-worlds.rkt @@ -1,6 +1,7 @@ -#lang racket +#lang racket/base -(require mred/mred mzlib/etc htdp/error) +(require racket/list racket/function racket/gui + mzlib/etc htdp/error) (provide ;; (launch-many-worlds e1 ... e2) diff --git a/collects/2htdp/private/utilities.rkt b/collects/2htdp/private/utilities.rkt index 5d03ab6e22..2c2f04b1fc 100644 --- a/collects/2htdp/private/utilities.rkt +++ b/collects/2htdp/private/utilities.rkt @@ -1,4 +1,6 @@ -#lang racket +#lang racket/base + +(require racket/contract) (provide/contract ;; like the unix debugging facility diff --git a/collects/htdp/dir.rkt b/collects/htdp/dir.rkt index 155cfa23d4..9f248c1151 100644 --- a/collects/htdp/dir.rkt +++ b/collects/htdp/dir.rkt @@ -1,4 +1,4 @@ -#lang racket +#lang racket/base (provide ;; map the directory tree at the given path into a data representation according to model 3 of From 95679bdab59d1d82c21e8c4872c68add4031c3d3 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 6 Nov 2012 13:28:27 -0500 Subject: [PATCH 178/221] Switch from `except' (from `racket/unit') to `#:except' in `2htdp/private'. This is used by the `function-with-arity' macro, and the use of `except' looks like something that is better done with a keyword. I think that this change should be fine since it's a private function. --- .../private/clauses-spec-and-process.rkt | 9 ++++---- collects/2htdp/universe.rkt | 22 +++++++++---------- 2 files changed, 15 insertions(+), 16 deletions(-) diff --git a/collects/2htdp/private/clauses-spec-and-process.rkt b/collects/2htdp/private/clauses-spec-and-process.rkt index 0b87a767f9..1f130d718a 100644 --- a/collects/2htdp/private/clauses-spec-and-process.rkt +++ b/collects/2htdp/private/clauses-spec-and-process.rkt @@ -3,7 +3,7 @@ ;; --------------------------------------------------------------------------------------------------- ;; provides functions for specifying the shape of big-bang and universe clauses: -(provide function-with-arity expr-with-check except err) +(provide function-with-arity expr-with-check err) ;; ... and for checking and processing them @@ -15,7 +15,6 @@ (require racket/function racket/list racket/bool - (only-in racket/unit except) ; used only as a keyword...? (for-syntax racket/base syntax/parse) (for-template "clauses-spec-aux.rkt" racket @@ -33,15 +32,15 @@ [(_ x) #`(check> #,tag x)] [_ (err tag p msg)])))])) -(define-syntax function-with-arity - (syntax-rules (except) +(define-syntax function-with-arity + (syntax-rules () [(_ arity) (lambda (tag) (lambda (p) (syntax-case p () [(_ x) #`(proc> #,tag (f2h x) arity)] [_ (err tag p)])))] - [(_ arity except extra ...) + [(_ arity #:except extra ...) (lambda (tag) (lambda (p) (syntax-case p () diff --git a/collects/2htdp/universe.rkt b/collects/2htdp/universe.rkt index da91b81a1b..52d64dfbb8 100644 --- a/collects/2htdp/universe.rkt +++ b/collects/2htdp/universe.rkt @@ -56,15 +56,15 @@ ;; it may specify a clock-tick rate [on-tick DEFAULT #'#f (function-with-arity - 1 - except - [(_ f rate) - #'(list + 1 + #:except + [(_ f rate) + #'(list (proc> 'on-tick (f2h f) 1) (num> 'on-tick rate (lambda (x) (and (real? x) (positive? x))) "positive number" "rate"))] [(_ f rate limit) - #'(list + #'(list (proc> 'on-tick (f2h f) 1) (num> 'on-tick rate (lambda (x) (and (real? x) (positive? x))) "positive number" "rate") @@ -82,11 +82,11 @@ ;; on-draw must specify a rendering function; ;; it may specify dimensions [on-draw to-draw DEFAULT #'#f - (function-with-arity - 1 - except + (function-with-arity + 1 + #:except [(_ f width height) - #'(list (proc> 'to-draw (f2h f) 1) + #'(list (proc> 'to-draw (f2h f) 1) (nat> 'to-draw width "width") (nat> 'to-draw height "height"))])] ;; World Nat Nat MouseEvent -> World @@ -107,9 +107,9 @@ ;; World -> Boolean ;; -- stop-when must specify a predicate; it may specify a rendering function [stop-when DEFAULT #'False - (function-with-arity + (function-with-arity 1 - except + #:except [(_ stop? last-picture) #'(list (proc> 'stop-when (f2h stop?) 1) (proc> 'stop-when (f2h last-picture) 1))])] From 14d8c8b5a5b665d03c14748e5416ec2f1753d4fb Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 6 Nov 2012 14:07:15 -0500 Subject: [PATCH 179/221] Newlines at EOFs. --- collects/data/scribblings/gvector.scrbl | 2 +- collects/data/scribblings/heap.scrbl | 121 +++++++++--------- collects/data/scribblings/integer-set.scrbl | 2 +- collects/data/scribblings/interval-map.scrbl | 3 +- collects/data/scribblings/queue.scrbl | 3 +- collects/data/scribblings/skip-list.scrbl | 2 +- collects/data/scribblings/splay-tree.scrbl | 2 +- .../drracket/private/local-member-names.rkt | 8 +- collects/file/scribblings/md5.scrbl | 3 +- collects/file/scribblings/sha1.scrbl | 2 +- collects/images/scribblings/icons.scrbl | 2 +- collects/images/scribblings/logos.scrbl | 3 +- collects/macro-debugger/macro-debugger.scrbl | 3 +- collects/mzlib/scribblings/compat.scrbl | 3 +- collects/mzlib/scribblings/etc.scrbl | 3 +- collects/mzlib/scribblings/kw.scrbl | 5 +- collects/mzlib/scribblings/struct.scrbl | 4 +- collects/net/scribblings/cookie.scrbl | 3 +- collects/net/scribblings/head.scrbl | 3 +- collects/racklog/racklog.scrbl | 3 +- collects/redex/scribblings/ref.scrbl | 5 +- collects/redex/scribblings/tut.scrbl | 3 +- collects/scribblings/draw/guide.scrbl | 2 +- collects/scribblings/foreign/objc.scrbl | 4 +- collects/scribblings/guide/futures.scrbl | 3 +- collects/scribblings/reference/booleans.scrbl | 5 +- collects/scribblings/reference/fixnums.scrbl | 4 +- collects/scribblings/reference/trace.scrbl | 20 ++- collects/syntax/scribblings/keyword.scrbl | 3 +- collects/syntax/scribblings/modcollapse.scrbl | 4 +- collects/tests/data/heap.rkt | 1 - .../scribblings/guide/begin.scrbl | 5 +- .../automata/scribblings/automata.scrbl | 17 ++- .../unstable/automata/scribblings/re.scrbl | 3 +- .../unstable/scribblings/custom-write.scrbl | 3 +- .../unstable/scribblings/gui/notify.scrbl | 3 +- collects/unstable/scribblings/logging.scrbl | 9 +- .../unstable/scribblings/open-place.scrbl | 3 +- .../scribblings/parameter-group.scrbl | 3 +- 39 files changed, 122 insertions(+), 158 deletions(-) diff --git a/collects/data/scribblings/gvector.scrbl b/collects/data/scribblings/gvector.scrbl index 81cb92be60..70f6d18a3d 100644 --- a/collects/data/scribblings/gvector.scrbl +++ b/collects/data/scribblings/gvector.scrbl @@ -125,4 +125,4 @@ order, on each iteration. } -@close-eval[the-eval] \ No newline at end of file +@close-eval[the-eval] diff --git a/collects/data/scribblings/heap.scrbl b/collects/data/scribblings/heap.scrbl index 2013b7ae19..9f10378e1c 100644 --- a/collects/data/scribblings/heap.scrbl +++ b/collects/data/scribblings/heap.scrbl @@ -21,14 +21,14 @@ Binary heaps are a simple implementation of priority queues. Makes a new empty heap using @racket[<=?] to order elements. @examples[#:eval the-eval -(define a-heap-of-strings (make-heap string<=?)) -a-heap-of-strings -@code:comment{With structs:} -(struct node (name val)) -(define (node<=? x y) - (<= (node-val x) (node-val y))) -(define a-heap-of-nodes (make-heap node<=?)) -a-heap-of-nodes] + (define a-heap-of-strings (make-heap string<=?)) + a-heap-of-strings + @code:comment{With structs:} + (struct node (name val)) + (define (node<=? x y) + (<= (node-val x) (node-val y))) + (define a-heap-of-nodes (make-heap node<=?)) + a-heap-of-nodes] } @defproc[(heap? [x any/c]) boolean?]{ @@ -36,17 +36,17 @@ a-heap-of-nodes] Returns @racket[#t] if @racket[x] is a heap, @racket[#f] otherwise. @examples[#:eval the-eval -(heap? (make-heap <=)) -(heap? "I am not a heap")] + (heap? (make-heap <=)) + (heap? "I am not a heap")] } @defproc[(heap-count [h heap?]) exact-nonnegative-integer?]{ Returns the number of elements in the heap. @examples[#:eval the-eval -(define a-heap (make-heap <=)) -(heap-add-all! a-heap '(7 3 9 1 13 21 15 31)) -(heap-count a-heap) + (define a-heap (make-heap <=)) + (heap-add-all! a-heap '(7 3 9 1 13 21 15 31)) + (heap-count a-heap) ] } @@ -55,8 +55,8 @@ Returns the number of elements in the heap. Adds each @racket[v] to the heap. @examples[#:eval the-eval -(define a-heap (make-heap <=)) -(heap-add! a-heap 2009 1009)] + (define a-heap (make-heap <=)) + (heap-add! a-heap 2009 1009)] } @@ -66,14 +66,14 @@ Adds each element contained in @racket[v] to the heap, leaving @racket[v] unchanged. @examples[#:eval the-eval -(define heap-1 (make-heap <=)) -(define heap-2 (make-heap <=)) -(define heap-12 (make-heap <=)) -(heap-add-all! heap-1 '(3 1 4 1 5 9 2 6)) -(heap-add-all! heap-2 #(2 7 1 8 2 8 1 8)) -(heap-add-all! heap-12 heap-1) -(heap-add-all! heap-12 heap-2) -(heap-count heap-12)] + (define heap-1 (make-heap <=)) + (define heap-2 (make-heap <=)) + (define heap-12 (make-heap <=)) + (heap-add-all! heap-1 '(3 1 4 1 5 9 2 6)) + (heap-add-all! heap-2 #(2 7 1 8 2 8 1 8)) + (heap-add-all! heap-12 heap-1) + (heap-add-all! heap-12 heap-2) + (heap-count heap-12)] } @defproc[(heap-min [h heap?]) any/c]{ @@ -82,13 +82,13 @@ Returns the least element in the heap @racket[h], according to the heap's ordering. If the heap is empty, an exception is raised. @examples[#:eval the-eval -(define a-heap (make-heap string<=?)) -(heap-add! a-heap "sneezy" "sleepy" "dopey" "doc" - "happy" "bashful" "grumpy") -(heap-min a-heap) + (define a-heap (make-heap string<=?)) + (heap-add! a-heap "sneezy" "sleepy" "dopey" "doc" + "happy" "bashful" "grumpy") + (heap-min a-heap) -@code:comment{Taking the min of the empty heap is an error:} -(heap-min (make-heap <=)) + @code:comment{Taking the min of the empty heap is an error:} + (heap-min (make-heap <=)) ] } @@ -98,13 +98,13 @@ Removes the least element in the heap @racket[h]. If the heap is empty, an exception is raised. @examples[#:eval the-eval -(define a-heap (make-heap string<=?)) -(heap-add! a-heap "fili" "fili" "oin" "gloin" "thorin" - "dwalin" "balin" "bifur" "bofur" - "bombur" "dori" "nori" "ori") -(heap-min a-heap) -(heap-remove-min! a-heap) -(heap-min a-heap)] + (define a-heap (make-heap string<=?)) + (heap-add! a-heap "fili" "fili" "oin" "gloin" "thorin" + "dwalin" "balin" "bifur" "bofur" + "bombur" "dori" "nori" "ori") + (heap-min a-heap) + (heap-remove-min! a-heap) + (heap-min a-heap)] } @defproc[(vector->heap [<=? (-> any/c any/c any/c)] [items vector?]) heap?]{ @@ -112,12 +112,12 @@ empty, an exception is raised. Builds a heap with the elements from @racket[items]. The vector is not modified. @examples[#:eval the-eval -(struct item (val frequency)) -(define (item<=? x y) - (<= (item-frequency x) (item-frequency y))) -(define some-sample-items - (vector (item #\a 17) (item #\b 12) (item #\c 19))) -(define a-heap (vector->heap item<=? some-sample-items)) + (struct item (val frequency)) + (define (item<=? x y) + (<= (item-frequency x) (item-frequency y))) + (define some-sample-items + (vector (item #\a 17) (item #\b 12) (item #\c 19))) + (define a-heap (vector->heap item<=? some-sample-items)) ] } @@ -127,9 +127,9 @@ Returns a vector containing the elements of heap @racket[h] in the heap's order. The heap is not modified. @examples[#:eval the-eval -(define word-heap (make-heap string<=?)) -(heap-add! word-heap "pile" "mound" "agglomerate" "cumulation") -(heap->vector word-heap) + (define word-heap (make-heap string<=?)) + (heap-add! word-heap "pile" "mound" "agglomerate" "cumulation") + (heap->vector word-heap) ] } @@ -137,12 +137,12 @@ heap's order. The heap is not modified. Makes a copy of heap @racket[h]. @examples[#:eval the-eval -(define word-heap (make-heap string<=?)) -(heap-add! word-heap "pile" "mound" "agglomerate" "cumulation") -(define a-copy (heap-copy word-heap)) -(heap-remove-min! a-copy) -(heap-count word-heap) -(heap-count a-copy) + (define word-heap (make-heap string<=?)) + (heap-add! word-heap "pile" "mound" "agglomerate" "cumulation") + (define a-copy (heap-copy word-heap)) + (heap-remove-min! a-copy) + (heap-count word-heap) + (heap-count a-copy) ] } @@ -154,14 +154,13 @@ Makes a copy of heap @racket[h]. Sorts vector @racket[v] using the comparison function @racket[<=?]. @examples[#:eval the-eval -(define terms (vector "batch" "deal" "flock" "good deal" "hatful" "lot")) -(heap-sort! string<=? terms) -terms + (define terms (vector "batch" "deal" "flock" "good deal" "hatful" "lot")) + (heap-sort! string<=? terms) + terms ] } - @defproc[(in-heap/consume! [heap heap?]) sequence?]{ Returns a sequence equivalent to @racket[heap], maintaining the heap's ordering. The heap is consumed in the process. Equivalent to repeated calling @@ -170,12 +169,13 @@ The heap is consumed in the process. Equivalent to repeated calling @examples[#:eval the-eval (define h (make-heap <=)) (heap-add-all! h '(50 40 10 20 30)) - + (for ([x (in-heap/consume! h)]) (displayln x)) - + (heap-count h)] } + @defproc[(in-heap [heap heap?]) sequence?]{ Returns a sequence equivalent to @racket[heap], maintaining the heap's ordering. Equivalent to @racket[in-heap/consume!] except the heap is copied first. @@ -183,11 +183,12 @@ Equivalent to @racket[in-heap/consume!] except the heap is copied first. @examples[#:eval the-eval (define h (make-heap <=)) (heap-add-all! h '(50 40 10 20 30)) - + (for ([x (in-heap h)]) (displayln x)) - + (heap-count h)] } -@close-eval[the-eval] \ No newline at end of file + +@close-eval[the-eval] diff --git a/collects/data/scribblings/integer-set.scrbl b/collects/data/scribblings/integer-set.scrbl index 26ac7aaa6f..c618397bbe 100644 --- a/collects/data/scribblings/integer-set.scrbl +++ b/collects/data/scribblings/integer-set.scrbl @@ -153,4 +153,4 @@ Returns true if every integer in @racket[x] is also in @racket[y], otherwise @racket[#f].} -@close-eval[the-eval] \ No newline at end of file +@close-eval[the-eval] diff --git a/collects/data/scribblings/interval-map.scrbl b/collects/data/scribblings/interval-map.scrbl index e7a52de7a9..c220d6e753 100644 --- a/collects/data/scribblings/interval-map.scrbl +++ b/collects/data/scribblings/interval-map.scrbl @@ -168,4 +168,5 @@ Returns @racket[#t] if @racket[v] represents a position in an interval-map, @racket[#f] otherwise. } -@close-eval[the-eval] \ No newline at end of file + +@close-eval[the-eval] diff --git a/collects/data/scribblings/queue.scrbl b/collects/data/scribblings/queue.scrbl index fa3dd4ec63..65e5a7572e 100644 --- a/collects/data/scribblings/queue.scrbl +++ b/collects/data/scribblings/queue.scrbl @@ -96,5 +96,4 @@ Returns a sequence whose elements are the elements of } - -@close-eval[qeval] \ No newline at end of file +@close-eval[qeval] diff --git a/collects/data/scribblings/skip-list.scrbl b/collects/data/scribblings/skip-list.scrbl index 2f0cf075a5..ae65895ac2 100644 --- a/collects/data/scribblings/skip-list.scrbl +++ b/collects/data/scribblings/skip-list.scrbl @@ -173,4 +173,4 @@ Returns an association list with the keys and values of } -@close-eval[the-eval] \ No newline at end of file +@close-eval[the-eval] diff --git a/collects/data/scribblings/splay-tree.scrbl b/collects/data/scribblings/splay-tree.scrbl index b237f7481b..20dacf5570 100644 --- a/collects/data/scribblings/splay-tree.scrbl +++ b/collects/data/scribblings/splay-tree.scrbl @@ -176,4 +176,4 @@ order. } -@close-eval[the-eval] \ No newline at end of file +@close-eval[the-eval] diff --git a/collects/drracket/private/local-member-names.rkt b/collects/drracket/private/local-member-names.rkt index 411eab9d60..e9c883ad9e 100644 --- a/collects/drracket/private/local-member-names.rkt +++ b/collects/drracket/private/local-member-names.rkt @@ -11,11 +11,11 @@ insert-auto-text) ;; from module-language-tools.rkt -(define-local-member-name +(define-local-member-name when-initialized - ;move-to-new-language + ;move-to-new-language get-in-module-language?) - + ;; for keybindings (otherwise private) (define-local-member-name jump-to-previous-error-loc @@ -28,4 +28,4 @@ ;; used by the test suite to tell when the ;; online check syntax has finished (define-local-member-name - get-online-expansion-colors) \ No newline at end of file + get-online-expansion-colors) diff --git a/collects/file/scribblings/md5.scrbl b/collects/file/scribblings/md5.scrbl index f9b0a241dc..c4e470ca82 100644 --- a/collects/file/scribblings/md5.scrbl +++ b/collects/file/scribblings/md5.scrbl @@ -22,5 +22,4 @@ that is the MD5 hash of the given input stream or byte string. ]} - -@close-eval[md5-eval] \ No newline at end of file +@close-eval[md5-eval] diff --git a/collects/file/scribblings/sha1.scrbl b/collects/file/scribblings/sha1.scrbl index 215abd6c33..6863d57f48 100644 --- a/collects/file/scribblings/sha1.scrbl +++ b/collects/file/scribblings/sha1.scrbl @@ -42,4 +42,4 @@ byte in @racket[bstr] is converted to its two-digit hexadecimal representation in the resulting string.} -@close-eval[sha1-eval] \ No newline at end of file +@close-eval[sha1-eval] diff --git a/collects/images/scribblings/icons.scrbl b/collects/images/scribblings/icons.scrbl index c1ef2cb47d..b402a1ad3c 100644 --- a/collects/images/scribblings/icons.scrbl +++ b/collects/images/scribblings/icons.scrbl @@ -477,4 +477,4 @@ Constants used within @racketmodname[images/icons/tool]. } -@close-eval[icons-eval] \ No newline at end of file +@close-eval[icons-eval] diff --git a/collects/images/scribblings/logos.scrbl b/collects/images/scribblings/logos.scrbl index 1231bcc2b0..32b9df2379 100644 --- a/collects/images/scribblings/logos.scrbl +++ b/collects/images/scribblings/logos.scrbl @@ -40,5 +40,4 @@ Returns the macro stepper logo. } - -@close-eval[logos-eval] \ No newline at end of file +@close-eval[logos-eval] diff --git a/collects/macro-debugger/macro-debugger.scrbl b/collects/macro-debugger/macro-debugger.scrbl index 91adf78df6..03a9827764 100644 --- a/collects/macro-debugger/macro-debugger.scrbl +++ b/collects/macro-debugger/macro-debugger.scrbl @@ -569,5 +569,4 @@ module path and the module paths of its immediate dependents. } - -@close-eval[the-eval] \ No newline at end of file +@close-eval[the-eval] diff --git a/collects/mzlib/scribblings/compat.scrbl b/collects/mzlib/scribblings/compat.scrbl index 85b6f2a3b8..2514dfc0b6 100644 --- a/collects/mzlib/scribblings/compat.scrbl +++ b/collects/mzlib/scribblings/compat.scrbl @@ -95,5 +95,4 @@ running @racket[read-eval-print]. In addition, @racket[current-exit] is set to escape from the call to @racket[new-cafe].} - -@close-eval[compat-eval] \ No newline at end of file +@close-eval[compat-eval] diff --git a/collects/mzlib/scribblings/etc.scrbl b/collects/mzlib/scribblings/etc.scrbl index 1138875a09..704eb7f82c 100644 --- a/collects/mzlib/scribblings/etc.scrbl +++ b/collects/mzlib/scribblings/etc.scrbl @@ -271,5 +271,4 @@ Creates a new hash-table providing the quoted flags (if any) to corresponding values.} - -@close-eval[etc-eval] \ No newline at end of file +@close-eval[etc-eval] diff --git a/collects/mzlib/scribblings/kw.scrbl b/collects/mzlib/scribblings/kw.scrbl index 4bc7907308..f72cf73805 100644 --- a/collects/mzlib/scribblings/kw.scrbl +++ b/collects/mzlib/scribblings/kw.scrbl @@ -449,7 +449,4 @@ if the @racket[args] list is imbalanced, and the search stops at a non-keyword value.)} - - - -@close-eval[kw-eval] \ No newline at end of file +@close-eval[kw-eval] diff --git a/collects/mzlib/scribblings/struct.scrbl b/collects/mzlib/scribblings/struct.scrbl index 51516f0830..98a96f7802 100644 --- a/collects/mzlib/scribblings/struct.scrbl +++ b/collects/mzlib/scribblings/struct.scrbl @@ -67,6 +67,4 @@ Builds a function that accepts a structure type instance (matching structure type instance.} - - -@close-eval[struct-eval] \ No newline at end of file +@close-eval[struct-eval] diff --git a/collects/net/scribblings/cookie.scrbl b/collects/net/scribblings/cookie.scrbl index dfbe81fcd6..59ee053eee 100644 --- a/collects/net/scribblings/cookie.scrbl +++ b/collects/net/scribblings/cookie.scrbl @@ -189,5 +189,4 @@ Imports nothing, exports @racket[cookie^].} Includes everything exported by the @racketmodname[net/cookie] module. - -@close-eval[cookie-eval] \ No newline at end of file +@close-eval[cookie-eval] diff --git a/collects/net/scribblings/head.scrbl b/collects/net/scribblings/head.scrbl index f46e79eff5..2d7a073ba1 100644 --- a/collects/net/scribblings/head.scrbl +++ b/collects/net/scribblings/head.scrbl @@ -243,5 +243,4 @@ Imports nothing, exports @racket[head^].} Includes everything exported by the @racketmodname[net/head] module. - -@close-eval[head-eval] \ No newline at end of file +@close-eval[head-eval] diff --git a/collects/racklog/racklog.scrbl b/collects/racklog/racklog.scrbl index fb1135bd28..61197416c7 100644 --- a/collects/racklog/racklog.scrbl +++ b/collects/racklog/racklog.scrbl @@ -1459,5 +1459,4 @@ frozen structure in @racket[F].} ] - -@close-eval[racklog-eval] \ No newline at end of file +@close-eval[racklog-eval] diff --git a/collects/redex/scribblings/ref.scrbl b/collects/redex/scribblings/ref.scrbl index eda7ec61c1..0359a123fe 100644 --- a/collects/redex/scribblings/ref.scrbl +++ b/collects/redex/scribblings/ref.scrbl @@ -3100,7 +3100,4 @@ column-span of the new lw is always zero. } - - - -@close-eval[redex-eval] \ No newline at end of file +@close-eval[redex-eval] diff --git a/collects/redex/scribblings/tut.scrbl b/collects/redex/scribblings/tut.scrbl index 6108526bd1..2c43b75af7 100644 --- a/collects/redex/scribblings/tut.scrbl +++ b/collects/redex/scribblings/tut.scrbl @@ -1124,5 +1124,4 @@ is rendered as @racketblock[Γ ⊢ e : t] @generate-bibliography[] - -@close-eval[amb-eval] \ No newline at end of file +@close-eval[amb-eval] diff --git a/collects/scribblings/draw/guide.scrbl b/collects/scribblings/draw/guide.scrbl index 52fa7c3a16..23d4125d62 100644 --- a/collects/scribblings/draw/guide.scrbl +++ b/collects/scribblings/draw/guide.scrbl @@ -766,4 +766,4 @@ Different kinds of bitmaps can produce different results: ] -@close-eval[draw-eval] \ No newline at end of file +@close-eval[draw-eval] diff --git a/collects/scribblings/foreign/objc.scrbl b/collects/scribblings/foreign/objc.scrbl index 15aafd345f..eb88d245a4 100644 --- a/collects/scribblings/foreign/objc.scrbl +++ b/collects/scribblings/foreign/objc.scrbl @@ -344,6 +344,4 @@ Analogous to @racket[(unsafe!)], makes unsafe bindings of module.} - - -@close-eval[objc-eval] \ No newline at end of file +@close-eval[objc-eval] diff --git a/collects/scribblings/guide/futures.scrbl b/collects/scribblings/guide/futures.scrbl index 431bca8e23..e50b096a0d 100644 --- a/collects/scribblings/guide/futures.scrbl +++ b/collects/scribblings/guide/futures.scrbl @@ -479,5 +479,4 @@ annotates operations that can be inlined by the compiler (see decompiler can be used to help predict parallel performance. - -@close-eval[future-eval] \ No newline at end of file +@close-eval[future-eval] diff --git a/collects/scribblings/reference/booleans.scrbl b/collects/scribblings/reference/booleans.scrbl index b4feaa5e15..4e65d3b4ed 100644 --- a/collects/scribblings/reference/booleans.scrbl +++ b/collects/scribblings/reference/booleans.scrbl @@ -298,7 +298,7 @@ Returns @racket[(not v)].} If exactly one of @racket[b1] and @racket[b2] is not @racket[#f], then return it. Otherwise, returns @racket[#f]. - + @examples[#:eval bool-eval (xor 11 #f) @@ -309,5 +309,4 @@ Returns @racket[(not v)].} } - -@close-eval[bool-eval] \ No newline at end of file +@close-eval[bool-eval] diff --git a/collects/scribblings/reference/fixnums.scrbl b/collects/scribblings/reference/fixnums.scrbl index a25da77133..4ac824f4a9 100644 --- a/collects/scribblings/reference/fixnums.scrbl +++ b/collects/scribblings/reference/fixnums.scrbl @@ -202,6 +202,4 @@ allocated in the @tech{shared memory space}. @mz-examples[#:eval flfx-eval (make-shared-fxvector 4 3)]} - - -@close-eval[flfx-eval] \ No newline at end of file +@close-eval[flfx-eval] diff --git a/collects/scribblings/reference/trace.scrbl b/collects/scribblings/reference/trace.scrbl index 36bfc46d6b..4310c1c7b9 100644 --- a/collects/scribblings/reference/trace.scrbl +++ b/collects/scribblings/reference/trace.scrbl @@ -1,9 +1,9 @@ #lang scribble/doc @(require "mz.rkt" (for-label racket/trace) - scribble/eval) + scribble/eval) @(begin (define ev (make-base-eval)) - (ev '(require racket/trace))) + (ev '(require racket/trace))) @title{Tracing} @@ -80,8 +80,8 @@ trace information during the call, as described above in the docs for } @defparam[current-trace-print-args trace-print-args - (-> symbol? - list? + (-> symbol? + list? (listof keyword?) list? number? @@ -95,8 +95,8 @@ number indicating the depth of the call. } @defparam[current-trace-print-results trace-print-results - (-> symbol? - list? + (-> symbol? + list? number? any)]{ @@ -105,7 +105,7 @@ traced call. It receives the name of the function, the function's results, and a number indicating the depth of the call. } - + @defparam[current-prefix-in prefix string?]{ This string is used by the default value of @racket[current-trace-print-args] indicating that the current line is showing the a call to a @@ -114,7 +114,7 @@ results, and a number indicating the depth of the call. It defaults to @racket[">"]. } - + @defparam[current-prefix-out prefix string?]{ This string is used by the default value of @racket[current-trace-print-results] indicating that the current line is showing the result @@ -124,6 +124,4 @@ results, and a number indicating the depth of the call. } - - -@close-eval[ev] \ No newline at end of file +@close-eval[ev] diff --git a/collects/syntax/scribblings/keyword.scrbl b/collects/syntax/scribblings/keyword.scrbl index 895d3145b9..6b77b08eb8 100644 --- a/collects/syntax/scribblings/keyword.scrbl +++ b/collects/syntax/scribblings/keyword.scrbl @@ -275,5 +275,4 @@ A @techlink{check-procedure} that accepts syntax booleans. } - -@close-eval[the-eval] \ No newline at end of file +@close-eval[the-eval] diff --git a/collects/syntax/scribblings/modcollapse.scrbl b/collects/syntax/scribblings/modcollapse.scrbl index 263e2aaae7..cde96e2618 100644 --- a/collects/syntax/scribblings/modcollapse.scrbl +++ b/collects/syntax/scribblings/modcollapse.scrbl @@ -60,6 +60,4 @@ refman]{module path index}; in this case, the contains the ``self'' index.} - - -@close-eval[evaluator] \ No newline at end of file +@close-eval[evaluator] diff --git a/collects/tests/data/heap.rkt b/collects/tests/data/heap.rkt index 542d2ec64a..0c9aa3f897 100644 --- a/collects/tests/data/heap.rkt +++ b/collects/tests/data/heap.rkt @@ -84,4 +84,3 @@ [lst (for/list ([x (in-heap/consume! h)]) x)]) (heap-count h)) 0) - \ No newline at end of file diff --git a/collects/typed-racket/scribblings/guide/begin.scrbl b/collects/typed-racket/scribblings/guide/begin.scrbl index 3cfd2ebefd..24c45c7bc2 100644 --- a/collects/typed-racket/scribblings/guide/begin.scrbl +++ b/collects/typed-racket/scribblings/guide/begin.scrbl @@ -1,7 +1,7 @@ #lang scribble/manual @begin[(require (for-label (only-meta-in 0 typed/racket)) scribble/eval - "../utils.rkt" (only-in "quick.scrbl" typed-mod))] + "../utils.rkt" (only-in "quick.scrbl" typed-mod))] @(define the-eval (make-base-eval)) @(the-eval '(require typed/racket)) @@ -133,5 +133,4 @@ Typed Racket also attempts to detect more than one error in the module. } - -@close-eval[the-eval] \ No newline at end of file +@close-eval[the-eval] diff --git a/collects/unstable/automata/scribblings/automata.scrbl b/collects/unstable/automata/scribblings/automata.scrbl index d3a1f8d88c..4bf6ff542e 100644 --- a/collects/unstable/automata/scribblings/automata.scrbl +++ b/collects/unstable/automata/scribblings/automata.scrbl @@ -36,12 +36,12 @@ Each of the subsequent macros compile to instances of the machines provided by t boolean?]{ Returns @racket[#t] if @racket[m] ends in an accepting state after consuming every element of @racket[i]. } - + @defproc[(machine-accepts?/prefix-closed [m machine?] [i (listof any/c)]) boolean?]{ Returns @racket[#t] if @racket[m] stays in an accepting state during the consumption of every element of @racket[i]. } - + @defthing[machine-null machine?]{ A machine that is never accepting. } @@ -63,28 +63,28 @@ Each of the subsequent macros compile to instances of the machines provided by t machine?]{ A machine that simulates the Kleene star of @racket[m]. @racket[m] may be invoked many times. } - + @defproc[(machine-union [m0 machine?] [m1 machine?]) machine?]{ A machine that simulates the union of @racket[m0] and @racket[m1]. } - + @defproc[(machine-intersect [m0 machine?] [m1 machine?]) machine?]{ A machine that simulates the intersection of @racket[m0] and @racket[m1]. } - + @defproc[(machine-seq [m0 machine?] [m1 machine?]) machine?]{ A machine that simulates the sequencing of @racket[m0] and @racket[m1]. @racket[m1] may be invoked many times. } - + @defproc[(machine-seq* [m0 machine?] [make-m1 (-> machine?)]) machine?]{ A machine that simulates the sequencing of @racket[m0] and @racket[(make-m1)]. @racket[(make-m1)] may be invoked many times. } - + @section[#:tag "dfa"]{Deterministic Finite Automata} @@ -214,5 +214,4 @@ This module provides a macro for non-deterministic finite automata with epsilon @include-section["re.scrbl"] - -@close-eval[our-eval] \ No newline at end of file +@close-eval[our-eval] diff --git a/collects/unstable/automata/scribblings/re.scrbl b/collects/unstable/automata/scribblings/re.scrbl index 8dc82fc826..0a30a7bedf 100644 --- a/collects/unstable/automata/scribblings/re.scrbl +++ b/collects/unstable/automata/scribblings/re.scrbl @@ -206,5 +206,4 @@ This module provides a few transformers that extend the syntax of regular expres (list 1 0)])] - -@close-eval[our-eval] \ No newline at end of file +@close-eval[our-eval] diff --git a/collects/unstable/scribblings/custom-write.scrbl b/collects/unstable/scribblings/custom-write.scrbl index 0fdf71693d..59546adf5e 100644 --- a/collects/unstable/scribblings/custom-write.scrbl +++ b/collects/unstable/scribblings/custom-write.scrbl @@ -66,5 +66,4 @@ When attached to a struct type, automatically generates a printer using } - -@close-eval[the-eval] \ No newline at end of file +@close-eval[the-eval] diff --git a/collects/unstable/scribblings/gui/notify.scrbl b/collects/unstable/scribblings/gui/notify.scrbl index 7918b3ca80..7dd883d1f8 100644 --- a/collects/unstable/scribblings/gui/notify.scrbl +++ b/collects/unstable/scribblings/gui/notify.scrbl @@ -155,5 +155,4 @@ listeners. } - -@close-eval[the-eval] \ No newline at end of file +@close-eval[the-eval] diff --git a/collects/unstable/scribblings/logging.scrbl b/collects/unstable/scribblings/logging.scrbl index dd51907746..82c63e0da1 100644 --- a/collects/unstable/scribblings/logging.scrbl +++ b/collects/unstable/scribblings/logging.scrbl @@ -13,7 +13,7 @@ This module provides tools for logging. @defproc[(with-logging-to-port [port output-port?] [proc (-> any)] - [log-spec (or/c 'fatal 'error 'warning 'info 'debug symbol? #f)] ...) + [log-spec (or/c 'fatal 'error 'warning 'info 'debug symbol? #f)] ...) any]{ Runs @racket[proc], outputting any logging that would be received by @@ -35,8 +35,8 @@ Returns whatever @racket[proc] returns. [interceptor (-> (vector/c (or/c 'fatal 'error 'warning 'info 'debug) string? - any/c) - any)] + any/c) + any)] [proc (-> any)] [log-spec (or/c 'fatal 'error 'warning 'info 'debug symbol? #f)] ...) any]{ @@ -88,5 +88,4 @@ will then return a list of the log messages that have been reported. ]} - -@close-eval[the-eval] \ No newline at end of file +@close-eval[the-eval] diff --git a/collects/unstable/scribblings/open-place.scrbl b/collects/unstable/scribblings/open-place.scrbl index 2f376149d5..5b3a288fce 100644 --- a/collects/unstable/scribblings/open-place.scrbl +++ b/collects/unstable/scribblings/open-place.scrbl @@ -21,5 +21,4 @@ Note that these variables must have values accepted by } - -@close-eval[the-eval] \ No newline at end of file +@close-eval[the-eval] diff --git a/collects/unstable/scribblings/parameter-group.scrbl b/collects/unstable/scribblings/parameter-group.scrbl index ebb9d8c054..8bcfb74c98 100644 --- a/collects/unstable/scribblings/parameter-group.scrbl +++ b/collects/unstable/scribblings/parameter-group.scrbl @@ -59,5 +59,4 @@ Corresponds to @racket[parameterize*], but can parameterize parameter groups as } - -@close-eval[evaluator] \ No newline at end of file +@close-eval[evaluator] From 5f74f120c8e22fd306ee625cfb303f9009a891b9 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Mon, 5 Nov 2012 18:30:14 -0500 Subject: [PATCH 180/221] Add examples for the rest of built-in pict constructors --- collects/scribblings/slideshow/picts.scrbl | 128 ++++++++++++++++----- 1 file changed, 101 insertions(+), 27 deletions(-) diff --git a/collects/scribblings/slideshow/picts.scrbl b/collects/scribblings/slideshow/picts.scrbl index f8ad929316..733e5145c3 100644 --- a/collects/scribblings/slideshow/picts.scrbl +++ b/collects/scribblings/slideshow/picts.scrbl @@ -1,12 +1,13 @@ #lang scribble/doc @(require "ss.rkt" "pict-diagram.rkt" scribble/eval + slideshow/face slideshow/pict (for-label racket/gui slideshow/code slideshow/flash slideshow/face slideshow/balloon slideshow/pict-convert)) @(define ss-eval (make-base-eval)) @(ss-eval '(require slideshow/pict racket/math racket/class racket/draw - racket/list)) + racket/list slideshow/balloon slideshow/flash)) @title[#:style 'toc]{Making Pictures} @@ -883,7 +884,12 @@ pict with the same shape and location.} [color (or/c string? (is-a?/c color%)) "gray"]) pict?]{ -Creates a fluffy cloud.} +Creates a fluffy cloud. + +@examples[#:eval ss-eval + (cloud 100 75) + (cloud 100 75 "lavenderblush") +]} @defproc[(file-icon [w real?] [h real?] @@ -894,7 +900,12 @@ Creates a fluffy cloud.} Creates a Mac-like file icon, optionally shaded. If @racket[color] is not a string or @racket[color%] object, it is treated as a boolean, in which case true means @racket["gray"] and false means -@racket["white"].} +@racket["white"]. + +@examples[#:eval ss-eval + (file-icon 50 60 "bisque") + (file-icon 50 60 "honeydew" #t) +]} @defproc[(standard-fish [w real?] [h real?] @@ -910,7 +921,14 @@ If @racket[eye-color] is @racket[#f], no eye is drawn. The @racket[open-mouth] argument can be either @racket[#f] (mouth closed), @racket[#t] (mouth fully open), or a number: @racket[0.0] is closed, @racket[1.0] is fully open, and numbers in between are -partially open.} +partially open. + +@examples[#:eval ss-eval + (standard-fish 100 50) + (standard-fish 100 50 #:direction 'right #:color "chocolate") + (standard-fish 100 50 #:eye-color "saddlebrown" #:color "salmon") + (standard-fish 100 50 #:open-mouth #t #:color "olive") +]} @defproc[(jack-o-lantern [size real?] [pumpkin-color (or/c string? (is-a?/c color%)) "orange"] @@ -918,7 +936,12 @@ partially open.} pict?]{ Creates a jack-o-lantern; use the same pumpkin and face color to get a -plain pumpkin. The @racket[size] determines the width.} +plain pumpkin. The @racket[size] determines the width. + +@examples[#:eval ss-eval + (jack-o-lantern 100) + (jack-o-lantern 100 "cadet blue" "khaki") +]} @defproc[(angel-wing [w real?] [h real?] @@ -926,7 +949,12 @@ plain pumpkin. The @racket[size] determines the width.} pict?]{ Creates an angel wing, left or right, or any size. The color and pen -width for drawing the wing outline is the current one.} +width for drawing the wing outline is the current one. + +@examples[#:eval ss-eval + (angel-wing 100 40 #f) + (angel-wing 100 40 #t) +]} @defproc[(desktop-machine [scale real?] [style (listof symbol?) null]) @@ -946,6 +974,12 @@ The @racket[style] can include any of the following: @item{@racket['devil] --- like @racket['binary], and also give the machine horns and a tail} +] + +@examples[#:eval ss-eval + (desktop-machine 1) + (desktop-machine 1 '(devil plt)) + (desktop-machine 1 '(plt binary)) ]} @defproc[(thermometer [#:height-% height-% (between/c 0 1) 1] @@ -973,8 +1007,12 @@ The @racket[style] can include any of the following: Finally, some number of ticks are drawn, basd on the @racket[ticks] argument. - -} +@examples[#:eval ss-eval + (thermometer #:stem-height 90 + #:bottom-circle-diameter 40 + #:top-circle-diameter 20 + #:mercury-inset 4) +]} @; ---------------------------------------- @@ -1047,7 +1085,19 @@ to the location specified by either @racket[x] and @racket[y] its arguments like @racket[lt-find]. The resulting pict has the same @tech{bounding box}, descent, and ascent as -@racket[base], even if the balloon extends beyond the bounding box.} +@racket[base], even if the balloon extends beyond the bounding box. + +@examples[#:eval ss-eval + (define a-pict (standard-fish 70 40)) + (pin-balloon (balloon 40 30 5 'se 5 5) + (cc-superimpose (blank 300 150) a-pict) + a-pict + lc-find) + (pin-balloon (wrap-balloon (text "Hello!") 'sw -5 3) + (cc-superimpose (blank 300 150) a-pict) + a-pict + rt-find) +]} @defproc[(balloon [w real?] @@ -1087,6 +1137,9 @@ library.} Orange.} +@; helper for the next defproc +@(define (small-face mood) (scale (face mood) 0.25)) + @defproc[(face [mood symbol?] [color (or/c string (is-a?/c color%)) default-face-color]) pict?]{ @@ -1095,22 +1148,33 @@ Returns a pict for a pre-configured face with the given base color. The built-in configurations, selected by mood-symbol, are as follows: -@itemize[ - - @item{@racket['unhappy] --- @racket[(face* 'none 'plain #t default-face-color 6)]} - @item{@racket['sortof-unhappy] --- @racket[(face* 'worried 'grimace #t default-face-color 6)]} - @item{@racket['sortof-happy] --- @racket[(face* 'worried 'medium #f default-face-color 6)]} - @item{@racket['happy] --- @racket[(face* 'none 'plain #f default-face-color 6)]} - @item{@racket['happier] --- @racket[(face* 'none 'large #f default-face-color 3)]} - @item{@racket['embarrassed] --- @racket[(face* 'worried 'medium #f default-face-color 3)]} - @item{@racket['badly-embarrassed] --- @racket[(face* 'worried 'medium #t default-face-color 3)]} - @item{@racket['unhappier] --- @racket[(face* 'normal 'large #t default-face-color 3)]} - @item{@racket['happiest] --- @racket[(face* 'normal 'huge #f default-face-color 0 -3)]} - @item{@racket['unhappiest] --- @racket[(face* 'normal 'huge #t default-face-color 0 -3)]} - @item{@racket['mad] --- @racket[(face* 'angry 'grimace #t default-face-color 0)]} - @item{@racket['mean] --- @racket[(face* 'angry 'narrow #f default-face-color 0)]} - @item{@racket['surprised] --- @racket[(face* 'worried 'oh #t default-face-color -4 -3 2)]} - +@tabular[#:sep @hspace[2] + (list (list @para{@racket['unhappy] --- @racket[(face* 'none 'plain #t default-face-color 6)]} + @(small-face 'unhappy)) + (list @para{@racket['sortof-unhappy] --- @racket[(small-face* 'worried 'grimace #t default-face-color 6)]} + @(small-face 'sortof-unhappy)) + (list @para{@racket['sortof-happy] --- @racket[(small-face* 'worried 'medium #f default-face-color 6)]} + @(small-face 'sortof-happy)) + (list @para{@racket['happy] --- @racket[(small-face* 'none 'plain #f default-face-color 6)]} + @(small-face 'happy)) + (list @para{@racket['happier] --- @racket[(small-face* 'none 'large #f default-face-color 3)]} + @(small-face 'happier)) + (list @para{@racket['embarrassed] --- @racket[(small-face* 'worried 'medium #f default-face-color 3)]} + @(small-face 'embarrassed)) + (list @para{@racket['badly-embarrassed] --- @racket[(small-face* 'worried 'medium #t default-face-color 3)]} + @(small-face 'badly-embarrassed)) + (list @para{@racket['unhappier] --- @racket[(small-face* 'normal 'large #t default-face-color 3)]} + @(small-face 'unhappier)) + (list @para{@racket['happiest] --- @racket[(small-face* 'normal 'huge #f default-face-color 0 -3)]} + @(small-face 'happiest)) + (list @para{@racket['unhappiest] --- @racket[(small-face* 'normal 'huge #t default-face-color 0 -3)]} + @(small-face 'unhappiest)) + (list @para{@racket['mad] --- @racket[(small-face* 'angry 'grimace #t default-face-color 0)]} + @(small-face 'mad)) + (list @para{@racket['mean] --- @racket[(small-face* 'angry 'narrow #f default-face-color 0)]} + @(small-face 'mean)) + (list @para{@racket['surprised] --- @racket[(small-face* 'worried 'oh #t default-face-color -4 -3 2)]} + @(small-face 'surprised))) ]} @defproc[(face* [eyebrow-kind (or/c 'none 'normal 'worried 'angry)] @@ -1196,7 +1260,12 @@ spikes are compared to the bounding oval. The @racket[rotation] argument specifies an angle in radians for counter-clockwise rotation. -The flash is drawn in the default color.} +The flash is drawn in the default color. + +@examples[#:eval ss-eval + (filled-flash 100 50) + (filled-flash 100 50 8 0.25 (/ pi 2)) +]} @defproc[(outline-flash [width real?] [height real?] @@ -1205,7 +1274,12 @@ The flash is drawn in the default color.} [rotation real? 0]) pict?]{ -Like @racket[filled-flash], but drawing only the outline.} +Like @racket[filled-flash], but drawing only the outline. + +@examples[#:eval ss-eval + (outline-flash 100 50) + (outline-flash 100 50 8 0.25 (/ pi 2)) +]} @; ------------------------------------------------------------------------ From 9e6329abeebeee7f1c73fdbe269db5daa1ced11a Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Tue, 6 Nov 2012 14:03:47 -0500 Subject: [PATCH 181/221] slideshow/balloon: fix `balloon` to match docs --- collects/texpict/balloon.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/texpict/balloon.rkt b/collects/texpict/balloon.rkt index b4c246cf3e..49e1d2a803 100644 --- a/collects/texpict/balloon.rkt +++ b/collects/texpict/balloon.rkt @@ -25,7 +25,8 @@ (define (series dc steps start-c end-c f pen? brush?) (color-series dc steps #e0.5 start-c end-c f pen? brush?)) - (define (mk-balloon w h corner-radius spike-pos dx dy color) + (define (mk-balloon w h corner-radius spike-pos dx dy + [color balloon-color]) (let ([dw (if (< corner-radius 1) (* corner-radius w) corner-radius)] From b5f5d420c426cb47d0f396254d6affa218f5102d Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Tue, 6 Nov 2012 14:39:23 -0700 Subject: [PATCH 182/221] correcting the type signature docs for htdp-intermediate's compose. --- collects/lang/private/intermediate-funs.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/lang/private/intermediate-funs.rkt b/collects/lang/private/intermediate-funs.rkt index adbacf6d86..7a7f3e06a4 100644 --- a/collects/lang/private/intermediate-funs.rkt +++ b/collects/lang/private/intermediate-funs.rkt @@ -173,7 +173,7 @@ (apply max a-list) ] } - @defproc[(compose [f (X -> Y)] [g (Y -> Z)]) (X -> Z)]{ + @defproc[(compose [f (Y -> Z)] [g (X -> Y)]) (X -> Z)]{ Composes a sequence of procedures into a single procedure: @codeblock{(compose f g) = (lambda (x) (f (g x)))} @interaction[#:eval (isl) From 9377b634ffa9ffc9c0732a90281bb1264facab71 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 3 Nov 2012 15:52:40 -0500 Subject: [PATCH 183/221] added show-derivations to redex --- collects/redex/gui.rkt | 13 + collects/redex/private/show-derivations.rkt | 339 ++++++++++++++++++++ collects/redex/private/size-snip.rkt | 27 +- collects/redex/private/traces.rkt | 10 +- collects/redex/scribblings/ref.scrbl | 31 ++ 5 files changed, 410 insertions(+), 10 deletions(-) create mode 100644 collects/redex/private/show-derivations.rkt diff --git a/collects/redex/gui.rkt b/collects/redex/gui.rkt index e30e919a4c..41dce2a008 100644 --- a/collects/redex/gui.rkt +++ b/collects/redex/gui.rkt @@ -9,6 +9,8 @@ "private/matcher.rkt" "private/reduction-semantics.rkt" "private/size-snip.rkt" + "private/show-derivations.rkt" + "private/judgment-form.rkt" mrlib/graph racket/contract racket/class @@ -62,6 +64,17 @@ #:post-process (-> (is-a?/c graph-pasteboard<%>) any/c)) any)] + [show-derivations (->* ((cons/c derivation? (listof derivation?))) + (#:pp pp-contract + #:racket-colors? boolean? + #:init-derivation exact-nonnegative-integer?) + any)] + [derivation/ps (->* (derivation? path-string?) + (#:pp pp-contract + #:racket-colors? boolean? + #:post-process (-> (is-a?/c pasteboard%) any)) + any)] + [term-node? (-> any/c boolean?)] [term-node-parents (-> term-node? (listof term-node?))] [term-node-children (-> term-node? (listof term-node?))] diff --git a/collects/redex/private/show-derivations.rkt b/collects/redex/private/show-derivations.rkt new file mode 100644 index 0000000000..0ddbf77fca --- /dev/null +++ b/collects/redex/private/show-derivations.rkt @@ -0,0 +1,339 @@ +#lang racket/base +(require racket/class + racket/gui/base + racket/match + racket/pretty + framework + "size-snip.rkt" + "judgment-form.rkt" + "traces.rkt") + +(provide show-derivations + derivation/ps) + +(define sub-derivation-horizontal-gap 20) +(define sub-derivation-vertical-gap 10) ;; must be even + +(define (derivation/ps derivation filename + #:pp [pp default-pretty-printer] + #:racket-colors? [racket-colors? #f] + #:post-process [post-process void]) + (define-values (ec pb) + (parameterize ([actually-show-window #f]) + (show-derivations (list derivation) + #:pp pp + #:racket-colors? racket-colors?))) + (post-process pb) + (print-to-ps pb ec filename)) + +(define actually-show-window (make-parameter #t)) + +(define (show-derivations derivations + #:pp [pp default-pretty-printer] + #:racket-colors? [racket-colors? #f] + #:init-derivation [init-derivation 0]) + (define init-cw (initial-char-width)) + (define f (new (class deriv-frame% + (define size-callback-queued? #f) + (define/override (on-size w h) + (unless size-callback-queued? + (set! size-callback-queued? #t) + (queue-callback + (λ () + (set! size-callback-queued? #f) + (send pb begin-edit-sequence) + (send pb re-run-layout) + (send pb end-edit-sequence)) + #f)) + (super on-size w h)) + (super-new [label "PLT Redex Judgment Form Derivations"] + [width 400] + [height 400])))) + (define ac (send f get-area-container)) + (define pb #f) + (define current-derivation #f) + (define ec (new editor-canvas% + [parent ac])) + (send f reflow-container) + + (define (show-derivation i) + (set! current-derivation i) + (set! pb (new derivation-pb%)) + (send ec set-editor pb) + (send f reflow-container) + (send pb begin-edit-sequence) + (fill-derivation-pb pb (list-ref derivations i) pp racket-colors? + (if char-width-slider + (send char-width-slider get-value) + init-cw)) + (send which-msg set-label (ith-label i)) + (send pb end-edit-sequence)) + + (define controls-panel (new vertical-panel% [parent ac] [stretchable-height #f])) + (define which-derivation-panel (new horizontal-panel% [parent ac] [stretchable-height #f] [alignment '(right center)])) + + (define (next/prev-derivation dir label) + (new button% + [label label] + [parent which-derivation-panel] + [callback + (λ (x y) + (show-derivation (modulo (+ current-derivation dir) + (length derivations))))])) + (next/prev-derivation -1 "Prev Derivation") + (define (ith-label i) + (format "~a / ~a" (+ i 1) (length derivations))) + (define which-msg + (new message% + [label (ith-label (- (length derivations) 1))] + [parent which-derivation-panel])) + (next/prev-derivation +1 "Next Derivation") + (when (<= (length derivations) 1) + (send ac change-children + (λ (l) (remq which-derivation-panel l)))) + + (define (set-all-cws cw) + (when pb + (let loop ([snip (send pb find-first-snip)]) + (when snip + (when (is-a? snip deriv-editor-snip%) + (send snip set-char-width cw)) + (loop (send snip next)))))) + + (define char-width-slider + (and (number? init-cw) + (new slider% + [parent controls-panel] + [min-value 2] + [max-value 100] + [init-value init-cw] + [label "Pretty Print Width"] + [callback + (λ (_1 _2) + (when pb + (send pb begin-edit-sequence) + (set-all-cws (send char-width-slider get-value)) + (send pb re-run-layout) + (send pb end-edit-sequence)))]))) + (show-derivation 0) + (cond + [(actually-show-window) + (send f show #t)] + [else + (values ec pb)])) + +(define deriv-frame% + (frame:standard-menus-mixin (frame:basic-mixin frame%))) + +(define (fill-derivation-pb pb derivation pp racket-colors? cw) + (define top-snip + (let loop ([derivation derivation]) + (define children + (reverse + (for/fold ([children '()]) ([sub (in-list (derivation-subs derivation))]) + (define child (loop sub)) + (cons child children)))) + (define line-snip (new line-snip%)) + (define name-snip (and (derivation-name derivation) + (make-object string-snip% + (format " [~a]" (derivation-name derivation))))) + (define snip (make-snip (derivation-term derivation) + children + pp + racket-colors? + (get-user-char-width + cw + (derivation-term derivation)) + line-snip + name-snip)) + (send snip set-derivation-children children) + (send pb insert snip) + (send pb insert line-snip) + (when name-snip (send pb insert name-snip)) + snip)) + (send pb set-top-snip top-snip) + (send pb re-run-layout)) + +(define derivation-pb% + (class pasteboard% + + (define top-snip #f) + (define/public (set-top-snip ts) (set! top-snip ts)) + (define/public (get-top-snip) top-snip) + + (define/public (re-run-layout) + (define table (make-hash)) + (send top-snip resize-derivation this table) + (define admin (send this get-admin)) + (define-values (init-x init-y) + (cond + [admin + (define bw (box 0)) + (define bh (box 0)) + (send admin get-view #f #f bw bh) + (match-define (cons derivation-width derivation-height) (hash-ref table top-snip)) + (values (max 0 (- (/ (unbox bw) 2) (/ derivation-width 2))) + (max 0 (- (/ (unbox bh) 2) (/ derivation-height 2))))] + [else + (values 0 0)])) + (send top-snip layout-derivation table this init-x init-y)) + + (define/augment (can-interactive-resize? evt) #f) + (define/augment (can-interactive-move? evt) #f) + (define/augment (can-select? snip on?) (not on?)) + + (inherit get-focus-snip) + + (super-new) + + (inherit set-keymap) + (set-keymap pb-km))) + +(define pb-km (new keymap%)) +(send pb-km add-function "set-focus" + (λ (pb evt) + (define-values (x y) (send pb dc-location-to-editor-location + (send evt get-x) + (send evt get-y))) + (define snp (send pb find-snip x y)) + (cond + [(not snp) + (send pb set-caret-owner #f)] + [(is-a? snp deriv-editor-snip%) + (send pb set-caret-owner snp)]))) +(send pb-km map-function "leftbutton" "set-focus") + +(define deriv-text% + (class size-text% + (inherit get-admin) + (define/override (on-focus on?) + (define admin (get-admin)) + (when (is-a? admin editor-snip-editor-admin<%>) + (define snip (send admin get-snip)) + (send snip show-border on?))) + (super-new))) + +(define (make-snip expr children pp code-colors? cw line-snip name-snip) + (let* ([text (new deriv-text%)] + [es (instantiate deriv-editor-snip% () + [char-width cw] + [editor text] + [pp pp] + [expr expr] + [with-border? #f] + [line-snip line-snip] + [name-snip name-snip])]) + (send text set-autowrap-bitmap #f) + (send text set-max-width 'none) + (send text freeze-colorer) + (unless code-colors? + (send text stop-colorer #t)) + (send es format-expr) + es)) + +(define deriv-editor-snip% + (class* size-editor-snip% () + (define derivation-children '()) + (define/public (set-derivation-children c) (set! derivation-children c)) + (init-field line-snip) + (init-field name-snip) + + (define/public (resize-derivation pb table) + (let loop ([derivation derivation]) + (define-values (children-width children-height) + (for/fold ([width 0] + [height 0]) + ([child (in-list derivation-children)]) + (define-values (this-w this-h) (send child resize-derivation pb table)) + (values (+ width this-w) + (max height this-h)))) + (define sub-derivation-width + (if (null? derivation-children) + 0 + (+ children-width (* (- (length derivation-children) + 1) + sub-derivation-horizontal-gap)))) + (define name-width (if name-snip + (find-snip-width pb name-snip) + 0)) + (define derivation-width + (+ (max sub-derivation-width + (find-snip-width pb this)) + name-width)) + (define derivation-height + (+ children-height + sub-derivation-vertical-gap + (find-snip-height pb this))) + (hash-set! table this (cons derivation-width derivation-height)) + (values derivation-width derivation-height))) + + (define/public (layout-derivation table pb dx dy) + (match-define (cons derivation-width derivation-height) (hash-ref table this)) + (define my-height (find-snip-height pb this)) + (define my-width (find-snip-width pb this)) + (define name-snip-width (if name-snip + (find-snip-width pb name-snip) + 0)) + (define my-x (+ dx (- (/ (- derivation-width name-snip-width) 2) (/ my-width 2)))) + (define my-y (+ dy derivation-height (- my-height))) + (define children-width + (for/sum ([child (in-list derivation-children)]) + (car (hash-ref table child)))) + (define start-dx (+ dx (/ (- (- derivation-width name-snip-width) children-width) 2))) + (send pb move-to this my-x my-y) + (send pb move-to line-snip dx (- my-y (/ sub-derivation-vertical-gap 2))) + (send line-snip set-width (- derivation-width name-snip-width)) + (when name-snip + (define name-snip-height (find-snip-height pb name-snip)) + (send pb move-to name-snip + (+ dx derivation-width (- name-snip-width)) + (- my-y (/ sub-derivation-vertical-gap 2) (/ name-snip-height 2)))) + (for/fold ([dx start-dx]) ([snip (in-list derivation-children)]) + (define that-ones-width (car (hash-ref table snip))) + (define that-ones-height (cdr (hash-ref table snip))) + (send snip layout-derivation table + pb + dx + (+ dy (- derivation-height that-ones-height my-height sub-derivation-vertical-gap))) + (+ dx that-ones-width sub-derivation-horizontal-gap))) + + (super-new))) + +(define line-snip% + (class snip% + (inherit get-admin) + (define width 10) + (define/public (set-width w) + (unless (equal? w width) + (define admin (get-admin)) + (set! width w) + (when admin + (send admin resized this #f) + (send admin needs-update this 0 0 w 1)))) + (define/override (copy) + (define c (new line-snip%)) + (send c set-width width) + c) + (define/override (draw dc x y left top right bottom dx dy draw-caret) + (define old-smoothing (send dc get-smoothing)) + (define old-pen (send dc get-pen)) + (send dc set-pen "black" 1 'transparent) + (send dc set-brush "black" 'solid) + (send dc set-smoothing 'aligned) + (send dc draw-rectangle x y width 1) + (send dc set-smoothing old-smoothing) + (send dc set-pen old-pen)) + (define/override (get-extent dc x y wb hb db sb lb rb) + (super get-extent dc x y wb hb db sb lb rb) + (set-box/f wb width) + (set-box/f hb 1)) + (inherit set-snipclass) + (super-new) + (set-snipclass line-snipclass))) + +(define (set-box/f b v) (when (box? b) (set-box! b v))) + +(define line-snipclass (new snip-class%)) +(send line-snipclass set-classname "redex:derivation-line") +(send line-snipclass set-version 1) +(send (get-the-snip-class-list) add line-snipclass) diff --git a/collects/redex/private/size-snip.rkt b/collects/redex/private/size-snip.rkt index b4ca8bea7b..e505ba5e93 100644 --- a/collects/redex/private/size-snip.rkt +++ b/collects/redex/private/size-snip.rkt @@ -14,7 +14,9 @@ pretty-print-parameters initial-char-width resizing-pasteboard-mixin - get-user-char-width) + get-user-char-width + find-snip-height + find-snip-width) (define initial-char-width (make-parameter 30)) @@ -91,6 +93,11 @@ (inherit get-admin) (define/public (get-expr) expr) (define/public (get-char-width) char-width) + (define/public (set-char-width cw) + (unless (equal? char-width cw) + (set! char-width cw) + (format-expr) + (on-width-changed char-width))) (define/override (resize w h) (super resize w h) @@ -187,3 +194,21 @@ (editor:standard-style-list-mixin text:basic%)))))))) + + +;; find-snip-height : editor snip -> number +(define (find-snip-height ed snip) + (let ([bt (box 0)] + [bb (box 0)]) + (send ed get-snip-location snip #f bt #f) + (send ed get-snip-location snip #f bb #t) + (- (unbox bb) + (unbox bt)))) + +(define (find-snip-width ed snip) + (let ([br (box 0)] + [bl (box 0)]) + (send ed get-snip-location snip br #f #t) + (send ed get-snip-location snip bl #f #f) + (- (unbox br) + (unbox bl)))) diff --git a/collects/redex/private/traces.rkt b/collects/redex/private/traces.rkt index 35f71de5af..1293c19275 100644 --- a/collects/redex/private/traces.rkt +++ b/collects/redex/private/traces.rkt @@ -886,17 +886,9 @@ (send ed get-snip-location snip br #f #t) (unbox br))) -;; find-snip-height : editor snip -> number -(define (find-snip-height ed snip) - (let ([bt (box 0)] - [bb (box 0)]) - (send ed get-snip-location snip #f bt #f) - (send ed get-snip-location snip #f bb #t) - (- (unbox bb) - (unbox bt)))) - (provide traces traces/ps + print-to-ps term-node? term-node-parents term-node-children diff --git a/collects/redex/scribblings/ref.scrbl b/collects/redex/scribblings/ref.scrbl index 0359a123fe..db6e30ebc8 100644 --- a/collects/redex/scribblings/ref.scrbl +++ b/collects/redex/scribblings/ref.scrbl @@ -2162,6 +2162,36 @@ Like @racket[stepper], this function opens a stepper window, but it seeds it with the reduction-sequence supplied in @racket[seed]. } +@defproc[(show-derivations [derivations (cons/c derivation? (listof derivation?))] + [#:pp pp + (or/c (any -> string) + (any output-port number (is-a?/c text%) -> void)) + default-pretty-printer] + [#:racket-colors? racket-colors? boolean? #f] + [#:init-derivation init-derivation exact-nonnegative-integer? 0]) + any]{ + Opens a window to show @racket[derivations]. + + The @racket[pp] and @racket[racket-colors?] arguments are like those to @racket[traces]. + + The initial derivation shown in the window is chosen by @racket[init-derivation], used + as an index into @racket[derivations]. +} + +@defproc[(derivations/ps [derivation derivation?] + [filename path-string?] + [#:pp pp + (or/c (any -> string) + (any output-port number (is-a?/c text%) -> void)) + default-pretty-printer] + [#:racket-colors? racket-colors? boolean? #f] + [#:post-process post-process (-> (is-a?/c pasteboard%) any)]) + void?]{ + + Like @racket[show-derivations], except it prints a single + derivation in PostScript to @racket[filename]. +} + @defproc[(term-node-children [tn term-node?]) (listof term-node?)]{ Returns a list of the children (ie, terms that this term @@ -2172,6 +2202,7 @@ term reduces to -- only those that are currently in the graph. } + @defproc[(term-node-parents [tn term-node?]) (listof term-node?)]{ Returns a list of the parents (ie, terms that reduced to the From 66c1045b420cbed4b2b29de7e9129499677d8d27 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 6 Nov 2012 18:31:08 -0600 Subject: [PATCH 184/221] adjust the language dialog so that clicking on the example the corresponding #lang line. --- .../private/language-configuration.rkt | 137 ++++++++++++++++-- .../private/english-string-constants.rkt | 23 ++- 2 files changed, 148 insertions(+), 12 deletions(-) diff --git a/collects/drracket/private/language-configuration.rkt b/collects/drracket/private/language-configuration.rkt index 12d0db5b86..a9a0bfeae6 100644 --- a/collects/drracket/private/language-configuration.rkt +++ b/collects/drracket/private/language-configuration.rkt @@ -60,7 +60,8 @@ [prefix drracket:app: drracket:app^] [prefix drracket:tools: drracket:tools^] [prefix drracket:help-desk: drracket:help-desk^] - [prefix drracket:module-language: drracket:module-language/int^]) + [prefix drracket:module-language: drracket:module-language/int^] + [prefix drracket: drracket:interface^]) (export drracket:language-configuration/internal^) ;; settings-preferences-symbol : symbol @@ -246,7 +247,9 @@ button-panel language-settings-to-show #f - ok-handler)) + ok-handler + (and (is-a? parent drracket:unit:frame<%>) + (send parent get-definitions-text)))) ;; create ok/cancel buttons (make-object horizontal-pane% button-panel) @@ -281,7 +284,8 @@ (define fill-language-dialog (λ (parent show-details-parent language-settings-to-show [re-center #f] - [ok-handler void]) ; en/disable button, execute it + [ok-handler void] + [definitions-text #f]) ; en/disable button, execute it (define-values (language-to-show settings-to-show) (let ([request-lang-to-show (language-settings-language language-settings-to-show)]) @@ -431,7 +435,7 @@ [parent in-source-discussion-panel] [stretchable-width #f] [min-width 32])) - (define in-source-discussion-editor-canvas (add-discussion in-source-discussion-panel)) + (define in-source-discussion-editor-canvas (add-discussion in-source-discussion-panel definitions-text)) (define most-recent-languages-hier-list-selection (preferences:get 'drracket:language-dialog:hierlist-default)) (define most-recent-teaching-languages-hier-list-selection (preferences:get 'drracket:language-dialog:teaching-hierlist-default)) @@ -1125,7 +1129,7 @@ #f)] [else #f]))))) - (define (add-discussion p) + (define (add-discussion p definitions-text) (define t (new (text:hide-caret/selection-mixin text:standard-style-list%))) (define c (new editor-canvas% [stretchable-width #t] @@ -1166,14 +1170,77 @@ (channel-put xref-chan xref) (loop)))) - (for ([lang (in-list '(racket typed/racket scribble/base))]) - (do-insert (format " #lang ~a" lang) #t) + (define spacer-snips '()) + (define spacer-poses '()) + + (for ([lang (in-list '(racket racket/base typed/racket scribble/base))]) + (define the-lang-line (format "#lang ~a" lang)) + (do-insert " " #t) + (define before-lang (send t last-position)) + (do-insert the-lang-line #t) + (define after-lang (send t last-position)) + (define spacer (new spacer-snip%)) + (define spacer-pos (send t last-position)) + (set! spacer-snips (cons spacer spacer-snips)) + (set! spacer-poses (cons spacer-pos spacer-poses)) + (send t insert spacer spacer-pos spacer-pos) (do-insert " [" #f) - (define before (send t last-position)) + (define before-docs (send t last-position)) (do-insert "docs" #f) - (define after (send t last-position)) + (define after-docs (send t last-position)) (do-insert "]\n" #f) - (send t set-clickback before after + (send t set-clickback before-lang after-lang + (λ (t start end) + (define-values (current-line-start current-line-end) + (if definitions-text + (find-language-position definitions-text) + (values #f #f))) + (define existing-lang-line (and current-line-start + (send definitions-text get-text current-line-start current-line-end))) + (case (message-box/custom + (string-constant drscheme) + (string-append + (string-constant racket-dialect-in-buffer-message) + (cond + [(and existing-lang-line + (equal? existing-lang-line the-lang-line)) + ""] + [existing-lang-line + (string-append + "\n\n" + (format (string-constant racket-dialect-replace-#lang-line) + existing-lang-line + the-lang-line))] + [else + (string-append + "\n\n" + (format (string-constant racket-dialect-add-new-#lang-line) the-lang-line))])) + (cond + [(and existing-lang-line + (equal? existing-lang-line the-lang-line)) + (string-constant ok)] + [existing-lang-line + (string-constant replace-#lang-line)] + [else + (string-constant add-#lang-line)]) + (and (not (equal? existing-lang-line the-lang-line)) + (string-constant cancel)) + #f #f + '(default=1)) + [(1) + (cond + [current-line-start + (send definitions-text begin-edit-sequence) + (send definitions-text delete current-line-start current-line-end) + (send definitions-text insert the-lang-line current-line-start current-line-start) + (send definitions-text end-edit-sequence)] + [else + (send definitions-text begin-edit-sequence) + (send definitions-text insert "\n" 0 0) + (send definitions-text insert the-lang-line 0 0) + (send definitions-text end-edit-sequence)])] + [else (void)]))) + (send t set-clickback before-docs after-docs (λ (t start end) (define-values (path tag) (xref-tag->path+anchor (channel-get xref-chan) `(mod-path ,(symbol->string lang)))) (define url (path->url path)) @@ -1189,15 +1256,65 @@ url)) (send-url (url->string url2))))) + (do-insert (string-constant racket-language-discussion-end) #f) + (define kmp (send t set-keymap (keymap:get-editor))) + (send (send c get-parent) reflow-container) + + (define xb (box 0)) + (define max-spacer-pos + (for/fold ([m 0]) ([spacer-pos (in-list spacer-poses)]) + (send t position-location spacer-pos xb #f) + (max m (unbox xb)))) + (for ([spacer-pos (in-list spacer-poses)] + [spacer-snip (in-list spacer-snips)]) + (send t position-location spacer-pos xb #f) + (send spacer-snip set-width (- max-spacer-pos (unbox xb)))) + (send t hide-caret #t) (send t auto-wrap #t) (send t lock #t) (send c accept-tab-focus #f) (send c allow-tab-exit #t) + c) + (define (find-language-position definitions-text) + (define prt (open-input-text-editor definitions-text)) + (port-count-lines! prt) + (define l (with-handlers ((exn:fail? (λ (x) #f))) + (read-language prt))) + (cond + [l + (define-values (line col pos) (port-next-location prt)) + (define hash-lang-start (send definitions-text find-string "#lang" 'backward pos 0 #f)) + (if hash-lang-start + (values hash-lang-start (- pos 1)) + (values #f #f))] + [else + (values #f #f)])) + + (define spacer-snip% + (class snip% + (inherit get-admin) + (define width 0) + (define/public (set-width w) + (set! width w) + (define admin (get-admin)) + (when admin + (send admin resized this #t))) + (define/override (get-text [start 0] [end 'eof] [flattened? #f] [force-cr? #f]) + "") + (define/override (get-extent dc x y wb hb db ab lb sp) + (super get-extent dc x y wb hb db ab lb sp) + (when (box? wb) (set-box! wb width))) + (super-new))) + (define spacer-sc (new snip-class%)) + (send spacer-sc set-classname "drracket:spacer-snipclass") + (send spacer-sc set-version 0) + (send (get-the-snip-class-list) add spacer-sc) + (define (size-discussion-canvas canvas) (define t (send canvas get-editor)) (define by (box 0)) diff --git a/collects/string-constants/private/english-string-constants.rkt b/collects/string-constants/private/english-string-constants.rkt index 4978c8d7f8..7223fc9043 100644 --- a/collects/string-constants/private/english-string-constants.rkt +++ b/collects/string-constants/private/english-string-constants.rkt @@ -1162,8 +1162,27 @@ please adhere to these guidelines: ;; for the upper portion of the language dialog (the-racket-language "The Racket Language") (choose-a-language "Choose a language") - (racket-language-discussion - "Start your program with #lang to specify the desired dialect. For example:\n\n") + + ;; the next two string constants appear in the + ;; language dialog with a list + ;; of example languages appearing between them + (racket-language-discussion "Start your program with #lang to specify the desired dialect. For example:\n\n") + (racket-language-discussion-end "\n... and many more") + + ;; the next three string constants are put into a message-box dialog + ;; that appears when the user clicks on the example #lang languages + ;; in the language dialog. The first one always appears and then either + ;; the second or the third appears. The second one has the clicked + ;; on #lang line placed into the ~a, and third one has the + ;; current #lang line in the first ~a and the clicked on in the second one. + ;; The two comments are separated by a blank line. + (racket-dialect-in-buffer-message "Racket dialects are generally chosen by editing the buffer directly, not by selecting these entries in the language dialog.") + (racket-dialect-add-new-#lang-line "That said, shall I add “~a” to the beginning of the definitions window?") + (racket-dialect-replace-#lang-line "That said, I see you have “~a” in your file; shall I replace it with “~a”?") + + ;; in the dialog containing the above strings, one of these is a button that appears + (add-#lang-line "Add #lang line") + (replace-#lang-line "Replace #lang line") ;; for the 'new drracket user' dialog (use-language-in-source "Use the language declared in the source") From c02797b12160651762a769414de06dcca8ba635e Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 6 Nov 2012 20:31:12 -0600 Subject: [PATCH 185/221] improve the language dialog a little bit: - make clicking on the example languages select the 'The Racket Language' radio button - when the clicked example language matches the buffer, have a more friendly message --- .../private/language-configuration.rkt | 21 +++++++++---------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/collects/drracket/private/language-configuration.rkt b/collects/drracket/private/language-configuration.rkt index a9a0bfeae6..f748bfdc43 100644 --- a/collects/drracket/private/language-configuration.rkt +++ b/collects/drracket/private/language-configuration.rkt @@ -435,7 +435,7 @@ [parent in-source-discussion-panel] [stretchable-width #f] [min-width 32])) - (define in-source-discussion-editor-canvas (add-discussion in-source-discussion-panel definitions-text)) + (define in-source-discussion-editor-canvas (add-discussion in-source-discussion-panel definitions-text use-language-in-source-rb-callback)) (define most-recent-languages-hier-list-selection (preferences:get 'drracket:language-dialog:hierlist-default)) (define most-recent-teaching-languages-hier-list-selection (preferences:get 'drracket:language-dialog:teaching-hierlist-default)) @@ -1129,7 +1129,7 @@ #f)] [else #f]))))) - (define (add-discussion p definitions-text) + (define (add-discussion p definitions-text use-language-in-source-rb-callback) (define t (new (text:hide-caret/selection-mixin text:standard-style-list%))) (define c (new editor-canvas% [stretchable-width #t] @@ -1191,6 +1191,7 @@ (do-insert "]\n" #f) (send t set-clickback before-lang after-lang (λ (t start end) + (use-language-in-source-rb-callback) (define-values (current-line-start current-line-end) (if definitions-text (find-language-position definitions-text) @@ -1201,20 +1202,18 @@ (string-constant drscheme) (string-append (string-constant racket-dialect-in-buffer-message) + "\n\n" (cond [(and existing-lang-line (equal? existing-lang-line the-lang-line)) - ""] + (format (string-constant racket-dialect-already-same-#lang-line) + existing-lang-line)] [existing-lang-line - (string-append - "\n\n" - (format (string-constant racket-dialect-replace-#lang-line) - existing-lang-line - the-lang-line))] + (format (string-constant racket-dialect-replace-#lang-line) + existing-lang-line + the-lang-line)] [else - (string-append - "\n\n" - (format (string-constant racket-dialect-add-new-#lang-line) the-lang-line))])) + (format (string-constant racket-dialect-add-new-#lang-line) the-lang-line)])) (cond [(and existing-lang-line (equal? existing-lang-line the-lang-line)) From b778e4e03cfbc9384db1c84ba6bab51be5a772f8 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 6 Nov 2012 19:52:54 -0700 Subject: [PATCH 186/221] enabling shared in plai with some shameless copying of kernel code --- collects/plai/datatype.rkt | 432 +++++++++++++---------- collects/tests/plai/datatype-exports.rkt | 4 +- collects/tests/plai/shared.rkt | 24 ++ 3 files changed, 270 insertions(+), 190 deletions(-) create mode 100644 collects/tests/plai/shared.rkt diff --git a/collects/plai/datatype.rkt b/collects/plai/datatype.rkt index f8a0eb9cbe..1c0a604c65 100644 --- a/collects/plai/datatype.rkt +++ b/collects/plai/datatype.rkt @@ -1,14 +1,17 @@ -#lang scheme -(require (for-syntax scheme/list)) +#lang racket/base +(require (for-syntax racket/base + racket/list) + racket/list + racket/contract) (provide define-type type-case) (define-for-syntax (plai-syntax-error id stx-loc format-string . args) - (raise-syntax-error + (raise-syntax-error id (apply format (cons format-string args)) stx-loc)) (define bug:fallthru-no-else - (string-append + (string-append "You have encountered a bug in the PLAI code. (Error: type-case " "fallthru on cond without an else clause.)")) (define-for-syntax bound-id @@ -41,146 +44,202 @@ (define-for-syntax (assert-unique variant-stx) (let ([dup-id (check-duplicate-identifier (syntax->list variant-stx))]) (when dup-id - (plai-syntax-error 'define-type dup-id + (plai-syntax-error 'define-type dup-id define-type:duplicate-variant)))) (define-for-syntax type-symbol (gensym)) (define-for-syntax (validate-and-remove-type-symbol stx-loc lst) (if (and (list? lst) (eq? type-symbol (first lst))) - (rest lst) - (plai-syntax-error 'type-case stx-loc type-case:not-a-type))) + (rest lst) + (plai-syntax-error 'type-case stx-loc type-case:not-a-type))) (require (for-syntax syntax/parse racket/syntax unstable/syntax - (only-in scheme/function curry))) + (only-in racket/function curry))) (define-for-syntax (syntax-string s) (symbol->string (syntax-e s))) +;; XXX Copied from racket/private/define-struct +(begin-for-syntax + (require racket/struct-info) + (define (transfer-srcloc orig stx) + (datum->syntax orig (syntax-e orig) stx orig)) + (struct self-ctor-checked-struct-info (info renamer) + #:property prop:struct-info + (λ (i) + ((self-ctor-checked-struct-info-info i))) + #:property prop:procedure + (λ (i stx) + (define orig ((self-ctor-checked-struct-info-renamer i))) + (syntax-case stx () + [(self arg ...) + (datum->syntax + stx + (cons (syntax-property (transfer-srcloc orig #'self) + 'constructor-for + (syntax-local-introduce + #'self)) + (syntax-e (syntax (arg ...)))) + stx + stx)] + [_ (transfer-srcloc orig stx)])))) + +(define the-undefined + (letrec ([x x]) x)) +(define (undefined? x) + (eq? the-undefined x)) + (define-syntax (define-type stx) (syntax-parse - stx - [(_ datatype:id - [variant:id (field:id field/c:expr) ...] - ...) - - ; Ensure we have at least one variant. - (when (empty? (syntax->list #'(variant ...))) - (plai-syntax-error 'define-type stx define-type:zero-variants - (syntax-e #'datatype))) - - ; Ensure variant names are unique. - (assert-unique #'(variant ...)) - ; Ensure each set of fields have unique names. - (syntax-map assert-unique #'((field ...) ...)) - - ; Ensure type and variant names are unbound - (map (assert-unbound 'define-type) - (cons #'datatype? (syntax->list #'(variant ...)))) - (with-syntax - ([(variant* ...) - (generate-temporaries #'(variant ...))]) - - (with-syntax - ([((field/c-val ...) ...) - (syntax-map generate-temporaries #'((field/c ...) ...))] - [datatype? - (format-id stx "~a?" #'datatype #:source #'datatype)] - [(variant? ...) - (syntax-map (λ (x) (format-id stx "~a?" x #:source x)) #'(variant ...))] - [(variant*? ...) - (syntax-map (λ (x) (format-id x "~a?" x #:source x)) #'(variant* ...))] - [(make-variant ...) - (syntax-map (λ (x) (format-id stx "make-~a" x #:source x)) #'(variant ...))] - [(make-variant* ...) - (syntax-map (λ (x) (format-id x "make-~a" x #:source x)) #'(variant* ...))]) - - (with-syntax - ([((f:variant? ...) ...) - (syntax-map (lambda (v? fs) - (syntax-map (lambda (f) v?) fs)) - #'(variant? ...) - #'((field ...) ...))] - [((variant-field ...) ...) - (syntax-map (lambda (variant fields) - (syntax-map (λ (f) (format-id stx "~a-~a" variant f #:source f)) - fields)) - #'(variant ...) - #'((field ...) ...))] - [((variant*-field ...) ...) - (syntax-map (lambda (variant fields) - (syntax-map (λ (f) (format-id variant "~a-~a" variant f #:source f)) - fields)) - #'(variant* ...) - #'((field ...) ...))] - - [((set-variant-field! ...) ...) - (syntax-map (lambda (variant fields) - (syntax-map (λ (f) (format-id stx "set-~a-~a!" variant f #:source f)) - fields)) - #'(variant ...) - #'((field ...) ...))] - [((set-variant*-field! ...) ...) - (syntax-map (lambda (variant fields) - (syntax-map (λ (f) (format-id variant "set-~a-~a!" variant f #:source f)) - fields)) - #'(variant* ...) - #'((field ...) ...))]) - - (syntax/loc stx - (begin - (define-syntax datatype - (list type-symbol - (list (list #'variant (list #'variant-field ...) #'variant?) - ...) - #'datatype?)) - (define-struct variant* (field ...) - #:transparent - #:omit-define-syntaxes - #:mutable - #:reflection-name 'variant) - ... - (define variant? - variant*?) - ... - (define (datatype? x) - (or (variant? x) ...)) - (begin - ; If this is commented in, then contracts will be checked early. - ; However, this will disallow mutual recursion, which PLAI relies on. - ; It could be allowed if we could have module-begin cooperate and lift the define-struct to the top-level - ; but, that would break web which doesn't use the plai language AND would complicate going to a student-language based deployment - #;(define field/c-val field/c) - ;... - (define make-variant - (lambda-memocontract (field ...) - (contract (field/c ... . -> . variant?) - make-variant* - 'make-variant 'use - 'make-variant #'variant))) - (define variant - (lambda-memocontract (field ...) - (contract (field/c ... . -> . variant?) - make-variant* - 'variant 'use - 'variant #'variant))) - (define variant-field - (lambda-memocontract (v) - (contract (f:variant? . -> . field/c) - variant*-field - 'variant-field 'use - 'variant-field #'field))) - ... - (define set-variant-field! - (lambda-memocontract (v nv) - (contract (f:variant? field/c . -> . void) - set-variant*-field! - 'set-variant-field! 'use - 'set-variant-field! #'field))) - ... - ) - ...)))))])) + stx + [(_ datatype:id + [variant:id (field:id field/c:expr) ...] + ...) + + ;; Ensure we have at least one variant. + (when (empty? (syntax->list #'(variant ...))) + (plai-syntax-error 'define-type stx define-type:zero-variants + (syntax-e #'datatype))) + + ;; Ensure variant names are unique. + (assert-unique #'(variant ...)) + ;; Ensure each set of fields have unique names. + (syntax-map assert-unique #'((field ...) ...)) + + ;; Ensure type and variant names are unbound + (map (assert-unbound 'define-type) + (cons #'datatype? (syntax->list #'(variant ...)))) + (with-syntax + ([(variant* ...) + (generate-temporaries #'(variant ...))] + [(underlying-variant ...) + (generate-temporaries #'(variant ...))]) + + (with-syntax + ([((field/c-val ...) ...) + (syntax-map generate-temporaries #'((field/c ...) ...))] + [((the-field/c ...) ...) + (syntax-map generate-temporaries #'((field/c ...) ...))] + [datatype? + (format-id stx "~a?" #'datatype #:source #'datatype)] + [(variant? ...) + (syntax-map (λ (x) (format-id stx "~a?" x #:source x)) #'(variant ...))] + [(variant*? ...) + (syntax-map (λ (x) (format-id x "~a?" x #:source x)) #'(variant* ...))] + [(make-variant ...) + (syntax-map (λ (x) (format-id stx "make-~a" x #:source x)) #'(variant ...))] + [(make-variant* ...) + (syntax-map (λ (x) (format-id x "make-~a" x #:source x)) #'(variant* ...))]) + + (with-syntax + ([((f:variant? ...) ...) + (syntax-map (lambda (v? fs) + (syntax-map (lambda (f) v?) fs)) + #'(variant? ...) + #'((field ...) ...))] + [((variant-field ...) ...) + (syntax-map (lambda (variant fields) + (syntax-map (λ (f) (format-id stx "~a-~a" variant f #:source f)) + fields)) + #'(variant ...) + #'((field ...) ...))] + [((variant*-field ...) ...) + (syntax-map (lambda (variant fields) + (syntax-map (λ (f) (format-id variant "~a-~a" variant f #:source f)) + fields)) + #'(variant* ...) + #'((field ...) ...))] + + [((set-variant-field! ...) ...) + (syntax-map (lambda (variant fields) + (syntax-map (λ (f) (format-id stx "set-~a-~a!" variant f #:source f)) + fields)) + #'(variant ...) + #'((field ...) ...))] + [((set-variant*-field! ...) ...) + (syntax-map (lambda (variant fields) + (syntax-map (λ (f) (format-id variant "set-~a-~a!" variant f #:source f)) + fields)) + #'(variant* ...) + #'((field ...) ...))]) + + (syntax/loc stx + (begin + (define-syntax datatype + (list type-symbol + (list (list #'variant (list #'variant-field ...) #'variant?) + ...) + #'datatype?)) + (define-struct variant* (field ...) + #:transparent + #:omit-define-syntaxes + #:mutable + #:reflection-name 'variant) + ... + (define variant? + variant*?) + ... + (define (datatype? x) + (or (variant? x) ...)) + (begin + ;; If this is commented in, then contracts will be + ;; checked early. However, this will disallow mutual + ;; recursion, which PLAI relies on. It could be + ;; allowed if we could have module-begin cooperate + ;; and lift the define-struct to the top-level but, + ;; that would break web which doesn't use the plai + ;; language AND would complicate going to a + ;; student-language based deployment + + ;; (define field/c-val field/c) + ;; ... + + (define (the-field/c) + (or/c undefined? + field/c)) + ... + + (define make-variant + (lambda-memocontract (field ...) + (contract ((the-field/c) ... . -> . variant?) + make-variant* + 'make-variant 'use + 'make-variant #'variant))) + (define underlying-variant + (lambda-memocontract (field ...) + (contract ((the-field/c) ... . -> . variant?) + make-variant* + 'variant 'use + 'variant #'variant))) + (define-syntax + variant + (self-ctor-checked-struct-info + (λ () + (list #'struct:variant* + #'make-variant* + #'variant*? + (reverse (list #'variant*-field ...)) + (reverse (list #'set-variant*-field! ...)) + #t)) + (λ () #'underlying-variant))) + (define variant-field + (lambda-memocontract (v) + (contract (f:variant? . -> . (the-field/c)) + variant*-field + 'variant-field 'use + 'variant-field #'field))) + ... + (define set-variant-field! + (lambda-memocontract (v nv) + (contract (f:variant? (the-field/c) . -> . void) + set-variant*-field! + 'set-variant-field! 'use + 'set-variant-field! #'field))) + ... + ) + ...)))))])) (define-syntax-rule (lambda-memocontract (field ...) c-expr) (let ([cd #f]) @@ -189,10 +248,10 @@ (set! cd c-expr)) (cd field ...)))) -;;; Asserts that variant-id-stx is a variant of the type described by +;;; Asserts that variant-id-stx is a variant of the type described by ;;; type-stx. (define-for-syntax ((assert-variant type-info) variant-id-stx) - (unless (ormap (λ (stx) (free-identifier=? variant-id-stx stx)) + (unless (ormap (λ (stx) (free-identifier=? variant-id-stx stx)) (map first type-info)) (plai-syntax-error 'type-case variant-id-stx type-case:not-a-variant))) @@ -204,13 +263,13 @@ (length (second type)))) type-info)]) (unless (= field-count (length (syntax->list field-stx))) - (plai-syntax-error 'type-case variant-id-stx type-case:argument-count + (plai-syntax-error 'type-case variant-id-stx type-case:argument-count field-count (length (syntax->list field-stx)))))) (define-for-syntax ((ensure-variant-present stx-loc variants) variant) (unless (ormap (λ (id-stx) (free-identifier=? variant id-stx)) (syntax->list variants)) - (plai-syntax-error 'type-case stx-loc type-case:missing-variant + (plai-syntax-error 'type-case stx-loc type-case:missing-variant (syntax->datum variant)))) (define-for-syntax ((variant-missing? stx-loc variants) variant) @@ -234,14 +293,14 @@ [(not (identifier? #'variant)) (plai-syntax-error 'type-case #'variant "this must be the name of a variant")] - [(ormap (λ (stx) + [(ormap (λ (stx) (and (not (identifier? stx)) stx)) (syntax->list #'(field ...))) => (λ (malformed-field) (plai-syntax-error 'type-case malformed-field "this must be an identifier that names the value of a field"))] [(not (= (length (syntax->list #'(body ...))) 1)) - (plai-syntax-error + (plai-syntax-error 'type-case clause-stx (string-append "there must be just one body expression in a clause, but you " @@ -252,7 +311,7 @@ (plai-syntax-error 'type-case clause-stx "this case is missing a body expression")] - [_ + [_ (plai-syntax-error 'type-case clause-stx "this case is missing a field list (possibly an empty field list)")])) @@ -261,15 +320,15 @@ (syntax-case stx () [(_ (binding-name ...) case-variant-id ((variant-id (selector-id ...) ___) . rest) value-id body-expr) (if (free-identifier=? #'case-variant-id #'variant-id) - #'(let ([binding-name (selector-id value-id)] - ...) - body-expr) - #'(bind-fields-in (binding-name ...) case-variant-id rest value-id body-expr))])) + #'(let ([binding-name (selector-id value-id)] + ...) + body-expr) + #'(bind-fields-in (binding-name ...) case-variant-id rest value-id body-expr))])) (define-syntax (type-case stx) (syntax-case stx (else) [(_ type-id test-expr [variant (field ...) case-expr] ... [else else-expr]) - ; Ensure that everything that should be an identifier is an identifier. + ;; Ensure that everything that should be an identifier is an identifier. (and (identifier? #'type-id) (andmap identifier? (syntax->list #'(variant ...))) (andmap (λ (stx) (andmap identifier? (syntax->list stx))) @@ -278,76 +337,76 @@ #'type-id (syntax-local-value #'type-id (λ () #f)))] [type-info (first info)] [type? (second info)]) - - ; Ensure all names are unique + + ;; Ensure all names are unique (assert-unique #'(variant ...)) (map assert-unique (syntax->list #'((field ...) ...))) - - ; Ensure variants are valid. + + ;; Ensure variants are valid. (map (assert-variant type-info) (syntax->list #'(variant ...))) - - ; Ensure field counts match. - (map (assert-field-count type-info) + + ;; Ensure field counts match. + (map (assert-field-count type-info) (syntax->list #'(variant ...)) (syntax->list #'((field ...) ...))) - - ; Ensure some variant is missing. - (unless (ormap (variant-missing? stx #'(variant ...)) + + ;; Ensure some variant is missing. + (unless (ormap (variant-missing? stx #'(variant ...)) (map first type-info)) (plai-syntax-error 'type-case stx type-case:unreachable-else)) - - + + #`(let ([expr test-expr]) (if (not (#,type? expr)) - #,(syntax/loc #'test-expr - (error 'type-case "expected a value from type ~a, got: ~a" - 'type-id - expr)) - (cond - [(let ([variant-info (lookup-variant variant #,type-info)]) - ((second variant-info) expr)) - (bind-fields-in (field ...) variant #,type-info expr case-expr)] - ... - [else else-expr]))))] + #,(syntax/loc #'test-expr + (error 'type-case "expected a value from type ~a, got: ~a" + 'type-id + expr)) + (cond + [(let ([variant-info (lookup-variant variant #,type-info)]) + ((second variant-info) expr)) + (bind-fields-in (field ...) variant #,type-info expr case-expr)] + ... + [else else-expr]))))] [(_ type-id test-expr [variant (field ...) case-expr] ...) - ; Ensure that everything that should be an identifier is an identifier. + ;; Ensure that everything that should be an identifier is an identifier. (and (identifier? #'type-id) (andmap identifier? (syntax->list #'(variant ...))) (andmap (λ (stx) (andmap identifier? (syntax->list stx))) (syntax->list #'((field ...) ...)))) - (let* ([info (validate-and-remove-type-symbol + (let* ([info (validate-and-remove-type-symbol #'type-id (syntax-local-value #'type-id (λ () #f)))] [type-info (first info)] [type? (second info)]) - - ; Ensure all names are unique + + ;; Ensure all names are unique (assert-unique #'(variant ...)) (map assert-unique (syntax->list #'((field ...) ...))) - - ; Ensure variants are valid. + + ;; Ensure variants are valid. (map (assert-variant type-info) (syntax->list #'(variant ...))) - - ; Ensure field counts match. - (map (assert-field-count type-info) + + ;; Ensure field counts match. + (map (assert-field-count type-info) (syntax->list #'(variant ...)) (syntax->list #'((field ...) ...))) - - ; Ensure all variants are covered + + ;; Ensure all variants are covered (map (ensure-variant-present stx #'(variant ...)) (map first type-info)) - + #`(let ([expr test-expr]) (if (not (#,type? expr)) - #,(syntax/loc #'test-expr - (error 'type-case "expected a value from type ~a, got: ~a" - 'type-id - expr)) - (cond - [(let ([variant-info (lookup-variant variant #,type-info)]) - ((second variant-info) expr)) - (bind-fields-in (field ...) variant #,type-info expr case-expr)] - ... - [else (error 'type-case bug:fallthru-no-else)]))))] + #,(syntax/loc #'test-expr + (error 'type-case "expected a value from type ~a, got: ~a" + 'type-id + expr)) + (cond + [(let ([variant-info (lookup-variant variant #,type-info)]) + ((second variant-info) expr)) + (bind-fields-in (field ...) variant #,type-info expr case-expr)] + ... + [else (error 'type-case bug:fallthru-no-else)]))))] ;;; The remaining clauses are for error reporting only. If we got this ;;; far, either the clauses are malformed or the error is completely ;;; unintelligible. @@ -359,6 +418,3 @@ (andmap validate-clause (syntax->list #'(clauses ...))) (plai-syntax-error 'type-case stx "Unknown error"))] [_ (plai-syntax-error 'type-case stx type-case:generic)])) - - - diff --git a/collects/tests/plai/datatype-exports.rkt b/collects/tests/plai/datatype-exports.rkt index 75d9c52b21..7a89dde775 100644 --- a/collects/tests/plai/datatype-exports.rkt +++ b/collects/tests/plai/datatype-exports.rkt @@ -11,6 +11,6 @@ (let ([exports (syntax-local-module-exports (syntax->datum #'module-name))]) #`(quote #,(cdaddr exports)))])) -(test (exports-of 'ex) +(test (sort (exports-of 'ex) string-cistring) => - '(Type set-Variant-field! make-Variant Variant? Variant-field Variant Type?)) + '(make-Variant set-Variant-field! Type Type? Variant Variant-field Variant?)) diff --git a/collects/tests/plai/shared.rkt b/collects/tests/plai/shared.rkt new file mode 100644 index 0000000000..4bd806891c --- /dev/null +++ b/collects/tests/plai/shared.rkt @@ -0,0 +1,24 @@ +#lang plai + +(define-type Node + (node (data string?) (adj list?))) + +(define g + (shared ([PVD (node "Providence" (list ORH BOS))] + [ORH (node "Worcester" (list PVD BOS))] + [BOS (node "Boston" (list PVD ORH))]) + (list PVD ORH BOS))) + +g + +(define PVD (first g)) +(define ORH (second g)) +(define BOS (third g)) + +PVD +ORH +BOS + +(test (node-adj PVD) (list ORH BOS)) +(test (node-adj ORH) (list PVD BOS)) +(test (node-adj BOS) (list PVD ORH)) From 261700ef2cc9689608abebecf7fcfd646a82ed29 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 6 Nov 2012 20:56:30 -0600 Subject: [PATCH 187/221] whoops, forgot to add this file in my last commit --- collects/string-constants/private/english-string-constants.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/string-constants/private/english-string-constants.rkt b/collects/string-constants/private/english-string-constants.rkt index 7223fc9043..e7d784f42a 100644 --- a/collects/string-constants/private/english-string-constants.rkt +++ b/collects/string-constants/private/english-string-constants.rkt @@ -1179,6 +1179,7 @@ please adhere to these guidelines: (racket-dialect-in-buffer-message "Racket dialects are generally chosen by editing the buffer directly, not by selecting these entries in the language dialog.") (racket-dialect-add-new-#lang-line "That said, shall I add “~a” to the beginning of the definitions window?") (racket-dialect-replace-#lang-line "That said, I see you have “~a” in your file; shall I replace it with “~a”?") + (racket-dialect-already-same-#lang-line "I see you already have “~a” in your file, however; so you should be all set to start programming!") ;; in the dialog containing the above strings, one of these is a button that appears (add-#lang-line "Add #lang line") From bc59cc43d4e6911a2147eff804819ef1ce127b07 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 6 Nov 2012 21:55:36 -0600 Subject: [PATCH 188/221] fix the draw contract (and change some one-of/c's to or/c's) --- collects/racket/snip/private/contract.rkt | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/collects/racket/snip/private/contract.rkt b/collects/racket/snip/private/contract.rkt index 33a7bbe98c..0647510311 100644 --- a/collects/racket/snip/private/contract.rkt +++ b/collects/racket/snip/private/contract.rkt @@ -53,10 +53,10 @@ (or/c 'base 'top 'center 'bottom)) (define tab-snip-filetype/c - (one-of/c 'unknown 'unknown/mask 'unknown/alpha - 'gif 'gif/mask 'gif/alpha - 'jpeg 'png 'png/mask 'png/alpha - 'xbm 'xpm 'bmp 'pict)) + (or/c 'unknown 'unknown/mask 'unknown/alpha + 'gif 'gif/mask 'gif/alpha + 'jpeg 'png 'png/mask 'png/alpha + 'xbm 'xpm 'bmp 'pict)) (define style-delta%/c (class/c @@ -150,9 +150,9 @@ ;; snip% utils (define snip%-edit-operation/c - (one-of/c 'undo 'redo 'clear 'cut - 'copy 'paste 'kill 'select-all - 'insert-text-box 'insert-pasteboard-box 'insert-image)) + (or/c 'undo 'redo 'clear 'cut + 'copy 'paste 'kill 'select-all + 'insert-text-box 'insert-pasteboard-box 'insert-image)) ;; snip% methods (define snip%-adjust-cursor/c @@ -185,7 +185,9 @@ real? real? real? - (one-of/c 'no-caret 'show-inactive-caret 'show-caret) + (or/c 'no-caret 'show-inactive-caret 'show-caret + (cons/c exact-nonnegative-integer? + exact-nonnegative-integer?)) void?)) (define snip%-other-equal-to?/c @@ -520,12 +522,12 @@ (>=/c 0) (>=/c 0) any/c) - ((one-of/c 'start 'end 'none)) + ((or/c 'start 'end 'none)) boolean?)) (define snip-admin%-set-caret-owner/c (->m (is-a?/c snip%) - (one-of/c 'immediate 'display 'global) + (or/c 'immediate 'display 'global) void?)) (define snip-admin%-update-cursor/c From 39a0ab60a78d6d60e8c20450f10b273261c0d325 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 6 Nov 2012 14:47:08 -0500 Subject: [PATCH 189/221] Some more `#lang racket' -> `#lang racket/base' conversions (And some other related minor racketisms.) --- collects/gui-debugger/debug-tool.rkt | 27 ++++++++++++++------------- collects/honu/core/private/syntax.rkt | 5 +++-- collects/lazy/lazy-tool.rkt | 18 +++++++++--------- collects/mrlib/private/regmk.rkt | 7 +++++-- collects/racket/math.rkt | 1 - collects/setup/collects.rkt | 3 +-- collects/srfi/19/time.rkt | 12 ++++++------ collects/test-engine/racket-tests.rkt | 16 ++++++++-------- 8 files changed, 46 insertions(+), 43 deletions(-) diff --git a/collects/gui-debugger/debug-tool.rkt b/collects/gui-debugger/debug-tool.rkt index 9bef7cbbb5..b0e2fb1dcb 100644 --- a/collects/gui-debugger/debug-tool.rkt +++ b/collects/gui-debugger/debug-tool.rkt @@ -1,14 +1,14 @@ -#lang racket +#lang racket/base ;; DrRacket's debugging tool -(require mzlib/etc - mzlib/list - mzlib/class - mzlib/unit - mzlib/contract - mred - mzlib/match +(require racket/function + racket/list + racket/class + racket/unit + racket/contract + racket/match + racket/gui drscheme/tool "marks.rkt" mrlib/switchable-button @@ -20,7 +20,8 @@ string-constants lang/debugger-language-interface images/compile-time - (for-syntax racket/class + (for-syntax racket/base + racket/class racket/draw images/icons/arrow images/icons/control @@ -112,7 +113,7 @@ ;; (
) => () ;; ( ... ) => ( ...) (define trim-expr-str - (opt-lambda (str [len 10]) + (lambda (str [len 10]) (let* ([strlen (string-length str)] [starts-with-paren (and (> strlen 0) (char=? (string-ref str 0) #\())] @@ -157,7 +158,7 @@ [else v])) (define filename->defs - (opt-lambda (source [default #f]) + (lambda (source [default #f]) (let/ec k (cond [(is-a? source editor<%>) source] @@ -985,7 +986,7 @@ (rest frames)))))) (define/public suspend-gui - (opt-lambda (frames status [switch-tabs? #f] [already-stopped? #f]) + (lambda (frames status [switch-tabs? #f] [already-stopped? #f]) (let ([top-of-stack? (zero? (get-frame-num))] [status-message (send (get-frame) get-status-message)]) (set! want-suspend-on-break? #f) @@ -1052,7 +1053,7 @@ (define/public suspend ;; ==called from user thread== - (opt-lambda (break-handler frames [status #f]) + (lambda (break-handler frames [status #f]) ;; suspend-sema ensures that we allow only one suspended thread ;; at a time (cond diff --git a/collects/honu/core/private/syntax.rkt b/collects/honu/core/private/syntax.rkt index ee17c9c9e8..a296f73464 100644 --- a/collects/honu/core/private/syntax.rkt +++ b/collects/honu/core/private/syntax.rkt @@ -1,8 +1,9 @@ -#lang racket +#lang racket/base (provide (all-defined-out)) -(require (for-syntax syntax/define +(require (for-syntax racket/base + syntax/define "transformer.rkt")) #| diff --git a/collects/lazy/lazy-tool.rkt b/collects/lazy/lazy-tool.rkt index e65c260853..8dadeb65c0 100644 --- a/collects/lazy/lazy-tool.rkt +++ b/collects/lazy/lazy-tool.rkt @@ -1,17 +1,18 @@ -#lang racket +#lang racket/base -(require string-constants +(require racket/unit + racket/class + string-constants drracket/tool lang/stepper-language-interface) (provide tool@) (define tool@ - (unit + (unit (import drracket:tool^) (export drracket:tool-exports^) - (define (stepper-settings-language %) (if (implementation? % stepper-language<%>) (class* % (stepper-language<%>) @@ -50,13 +51,12 @@ ; (equal? (drracket:language:simple-settings->vector s) ; (drracket:language:simple-settings->vector (default-settings)))) (super-new))) - - + (define (phase1) (void)) - + ;; phase2 : -> void (define (phase2) - + (define lazy-language% (stepper-settings-language ((drracket:language:get-default-mixin) @@ -64,7 +64,7 @@ (module-based-language-extension (drracket:language:simple-module-based-language->module-based-language-mixin drracket:language:simple-module-based-language%)))))) - + (drracket:language-configuration:add-language (instantiate lazy-language% () (one-line-summary "Lazy Racket") diff --git a/collects/mrlib/private/regmk.rkt b/collects/mrlib/private/regmk.rkt index bf5d8bf1ff..a6401351ca 100644 --- a/collects/mrlib/private/regmk.rkt +++ b/collects/mrlib/private/regmk.rkt @@ -1,6 +1,9 @@ -#lang racket +#lang racket/base + +(require (for-syntax racket/base)) + (provide define-struct/reg-mk - id->constructor + id->constructor (struct-out point) (struct-out bb)) diff --git a/collects/racket/math.rkt b/collects/racket/math.rkt index f4c37709a0..c607a0765a 100644 --- a/collects/racket/math.rkt +++ b/collects/racket/math.rkt @@ -1,5 +1,4 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;; math.rkt: some extra math routines ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/collects/setup/collects.rkt b/collects/setup/collects.rkt index 31c5c7d6fc..45dd7b208b 100644 --- a/collects/setup/collects.rkt +++ b/collects/setup/collects.rkt @@ -1,8 +1,7 @@ -#lang racket +#lang racket/base (provide (struct-out cc)) (define-struct cc (collection path name info omit-root info-root info-path info-path-mode shadowing-policy) #:inspector #f) - diff --git a/collects/srfi/19/time.rkt b/collects/srfi/19/time.rkt index a37fac7036..37adbf89f6 100644 --- a/collects/srfi/19/time.rkt +++ b/collects/srfi/19/time.rkt @@ -1,7 +1,7 @@ -#lang racket +#lang racket/base ;;; -;;; ---- SRFI 19 Time Data Types and Procedures port to PLT Scheme +;;; ---- SRFI 19 Time Data Types and Procedures port to Racket ;;; Time-stamp: <2004-07-21 12:57:06 solsona> ;;; ;;; Usually, I would add a copyright notice, and the announce that @@ -60,7 +60,7 @@ ;; -- Multiple helper procedures. TM:xxx procedures are meant to be ;; internal. -(require scheme/serialize +(require racket/serialize srfi/8/receive srfi/29 srfi/optional) @@ -77,12 +77,12 @@ ;; Time arithmetic time-difference time-difference! add-duration add-duration! subtract-duration subtract-duration! ;; Date object and accessors - ;; date structure is provided by core PLT Scheme, we just extended tu support miliseconds: + ;; date structure is provided by core Racket, we just extended tu support miliseconds: srfi:make-date srfi:date? deserialize-info:tm:date-v0 date-nanosecond srfi:date-second srfi:date-minute srfi:date-hour srfi:date-day srfi:date-month srfi:date-year date-zone-offset - ;; This are not part of the date structure (as they are in the original PLT Scheme's date) + ;; This are not part of the date structure (as they are in the original Racket's date) srfi:date-year-day srfi:date-week-day date-week-number ;; The following procedures work with this modified version. @@ -643,7 +643,7 @@ (tm:set-date-year! d1 (srfi:date-year d0)) (tm:set-date-zone-offset! d1 (date-zone-offset d0)))))))) -;; PLT Scheme date structure has the following: +;; Racket's date structure has the following: ;; * second : 0 to 61 (60 and 61 are for unusual leap-seconds) ;; * minute : 0 to 59 ;; * hour : 0 to 23 diff --git a/collects/test-engine/racket-tests.rkt b/collects/test-engine/racket-tests.rkt index 822b1c01b5..dfaf02c170 100644 --- a/collects/test-engine/racket-tests.rkt +++ b/collects/test-engine/racket-tests.rkt @@ -1,14 +1,14 @@ -#lang racket +#lang racket/base (require lang/private/teachprims - (for-syntax lang/private/rewrite-error-message) - scheme/class - scheme/match - lang/private/continuation-mark-key + (for-syntax racket/base + lang/private/rewrite-error-message) + racket/class + racket/match + lang/private/continuation-mark-key lang/private/rewrite-error-message - (only-in scheme/base for memf findf) "test-engine.rkt" - "test-info.scm") + "test-info.scm") (require (for-syntax stepper/private/syntax-property)) @@ -72,7 +72,7 @@ #`(define #,bogus-name #,(stepper-syntax-property #`(let ([test-engine (namespace-variable-value - 'test~object #f builder (current-namespace))]) + 'test~object #f builder (current-namespace))]) (when test-engine (insert-test test-engine (lambda () From 26045a27fb1f1faeb8c9ba1208366e6c519fba52 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 6 Nov 2012 15:07:09 -0500 Subject: [PATCH 190/221] `#lang racket' -> `#lang racket/base' conversions in drracket and in redex. --- collects/drracket/private/colored-errors.rkt | 13 +++++++++---- collects/drracket/private/follow-log.rkt | 9 +++++++-- collects/redex/private/compiler/redextomatrix.rkt | 8 ++++++-- collects/redex/private/pat-unify.rkt | 8 ++++++-- 4 files changed, 28 insertions(+), 10 deletions(-) diff --git a/collects/drracket/private/colored-errors.rkt b/collects/drracket/private/colored-errors.rkt index 8f0f884447..33eabce707 100644 --- a/collects/drracket/private/colored-errors.rkt +++ b/collects/drracket/private/colored-errors.rkt @@ -1,13 +1,18 @@ -#lang racket +#lang racket/base -(define-syntax (test stx) #'(begin)) ;; TODO: convert my test into DrRacket's test framework -(require ; gmarceau/test - parser-tools/lex +(require (for-syntax racket/base) + racket/list + racket/string + racket/contract + racket/match + parser-tools/lex (prefix-in : parser-tools/lex-sre) (rename-in srfi/26 [cut //]) (only-in srfi/1 break) unstable/contract) +(define-syntax (test stx) #'(begin)) ;; TODO: convert my test into DrRacket's test framework + ;; An error message has many fragments. The fragments will be concatenated ;; before being presented to the user. Some fragment are simply string. (struct msg-fragment:str (str) #:transparent) diff --git a/collects/drracket/private/follow-log.rkt b/collects/drracket/private/follow-log.rkt index f834e98e3a..bc3f52efc0 100644 --- a/collects/drracket/private/follow-log.rkt +++ b/collects/drracket/private/follow-log.rkt @@ -1,5 +1,10 @@ -#lang racket -(require racket/gui/base +#lang racket/base + +(require racket/list + racket/class + racket/match + racket/pretty + racket/gui/base framework/private/logging-timer) #| diff --git a/collects/redex/private/compiler/redextomatrix.rkt b/collects/redex/private/compiler/redextomatrix.rkt index dd1a2deac5..9cadc28fe4 100644 --- a/collects/redex/private/compiler/redextomatrix.rkt +++ b/collects/redex/private/compiler/redextomatrix.rkt @@ -1,9 +1,13 @@ -#lang racket +#lang racket/base + +(require (except-in racket/base compile) + racket/function + racket/match) (require (except-in redex make-bind plug)) (require "match.rkt") (require racket/set) (require profile) -(require (only-in "../../private/matcher.rkt" +(require (only-in "../../private/matcher.rkt" make-bindings make-bind make-mtch diff --git a/collects/redex/private/pat-unify.rkt b/collects/redex/private/pat-unify.rkt index 780ad6d267..f3338a3388 100644 --- a/collects/redex/private/pat-unify.rkt +++ b/collects/redex/private/pat-unify.rkt @@ -1,6 +1,10 @@ -#lang racket +#lang racket/base -(require (for-syntax "rewrite-side-conditions.rkt") +(require racket/list + racket/contract + racket/set + racket/match + (for-syntax "rewrite-side-conditions.rkt") "match-a-pattern.rkt" "matcher.rkt" "extract-conditions.rkt") From bffe336220134ae2d019b768a9c1e8db2e83fe1c Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 6 Nov 2012 15:11:25 -0500 Subject: [PATCH 191/221] `#lang racket' -> `#lang racket/base' conversions in plot and in images. --- collects/images/icons/style.rkt | 6 +++--- collects/plot/common/math.rkt | 5 +++-- collects/plot/common/worker-thread.rkt | 4 ++-- 3 files changed, 8 insertions(+), 7 deletions(-) diff --git a/collects/images/icons/style.rkt b/collects/images/icons/style.rkt index 302558df58..2133e6fa3d 100644 --- a/collects/images/icons/style.rkt +++ b/collects/images/icons/style.rkt @@ -1,10 +1,10 @@ -#lang racket +#lang racket/base -(require racket/draw unstable/parameter-group +(require racket/class racket/draw unstable/parameter-group racket/contract unstable/latent-contract unstable/latent-contract/defthing "../private/flomap.rkt" "../private/deep-flomap.rkt" - (for-syntax syntax/parse)) + (for-syntax racket/base syntax/parse)) (provide light-metal-icon-color metal-icon-color diff --git a/collects/plot/common/math.rkt b/collects/plot/common/math.rkt index fe86d4e275..b1ccb7eef9 100644 --- a/collects/plot/common/math.rkt +++ b/collects/plot/common/math.rkt @@ -1,6 +1,7 @@ -#lang racket +#lang racket/base -(require racket/contract racket/unsafe/ops +(require racket/math racket/string racket/match racket/list racket/vector + racket/contract racket/unsafe/ops unstable/flonum unstable/latent-contract/defthing) (provide (all-defined-out)) diff --git a/collects/plot/common/worker-thread.rkt b/collects/plot/common/worker-thread.rkt index 5edb0744f7..8514ffa44a 100644 --- a/collects/plot/common/worker-thread.rkt +++ b/collects/plot/common/worker-thread.rkt @@ -1,6 +1,6 @@ -#lang racket +#lang racket/base -(require racket/async-channel) +(require racket/bool racket/match racket/async-channel) (provide make-worker-thread worker-thread? worker-thread-working? worker-thread-waiting? worker-thread-put worker-thread-try-put From 4c8d1f67b253473fe3febe783cc2e637c66729de Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 6 Nov 2012 15:19:53 -0500 Subject: [PATCH 192/221] `#lang racket' -> `#lang racket/base' conversions in demodularizer. --- collects/compiler/demodularizer/alpha.rkt | 5 ++- collects/compiler/demodularizer/batch.rkt | 4 +- .../compiler/demodularizer/gc-toplevels.rkt | 38 ++++++++++--------- collects/compiler/demodularizer/merge.rkt | 20 ++++++---- collects/compiler/demodularizer/module.rkt | 8 +++- collects/compiler/demodularizer/mpi.rkt | 6 ++- collects/compiler/demodularizer/nodep.rkt | 11 ++++-- .../compiler/demodularizer/replace-modidx.rkt | 8 +++- .../demodularizer/update-toplevels.rkt | 7 +++- collects/compiler/demodularizer/util.rkt | 6 ++- 10 files changed, 72 insertions(+), 41 deletions(-) diff --git a/collects/compiler/demodularizer/alpha.rkt b/collects/compiler/demodularizer/alpha.rkt index 9b459b6ca3..2f3c71398d 100644 --- a/collects/compiler/demodularizer/alpha.rkt +++ b/collects/compiler/demodularizer/alpha.rkt @@ -1,5 +1,6 @@ -#lang racket -(require compiler/zo-parse) +#lang racket/base + +(require racket/match racket/contract compiler/zo-parse) (define (alpha-vary-ctop top) (match top diff --git a/collects/compiler/demodularizer/batch.rkt b/collects/compiler/demodularizer/batch.rkt index afb495a473..bd98894ad3 100644 --- a/collects/compiler/demodularizer/batch.rkt +++ b/collects/compiler/demodularizer/batch.rkt @@ -1,4 +1,5 @@ -#lang racket +#lang racket/base + #| Here's the idea: @@ -40,6 +41,7 @@ Here's the idea: (require racket/pretty racket/system + racket/cmdline "mpi.rkt" "util.rkt" "nodep.rkt" diff --git a/collects/compiler/demodularizer/gc-toplevels.rkt b/collects/compiler/demodularizer/gc-toplevels.rkt index aa6b780389..ad8c74faee 100644 --- a/collects/compiler/demodularizer/gc-toplevels.rkt +++ b/collects/compiler/demodularizer/gc-toplevels.rkt @@ -1,5 +1,10 @@ -#lang racket -(require compiler/zo-parse +#lang racket/base + +(require racket/match + racket/list + racket/dict + racket/contract + compiler/zo-parse "util.rkt") ; XXX Use efficient set structure @@ -150,21 +155,20 @@ (match (dict-ref g n) [(struct refs (n-tls n-stxs)) (hash-set! visited? n #t) - (local - [(define-values (new-tls1 new-stxs1) - (for/fold ([new-tls tls] - [new-stxs stxs]) - ([tl (in-list n-tls)]) - (visit-tl tl new-tls new-stxs))) - (define new-stxs2 - (for/fold ([new-stxs new-stxs1]) - ([stx (in-list n-stxs)]) - (define this-stx (visit-stx stx)) - (if this-stx - (list* this-stx new-stxs) - new-stxs)))] - (values (list* n new-tls1) - new-stxs2))]))) + (define-values (new-tls1 new-stxs1) + (for/fold ([new-tls tls] + [new-stxs stxs]) + ([tl (in-list n-tls)]) + (visit-tl tl new-tls new-stxs))) + (define new-stxs2 + (for/fold ([new-stxs new-stxs1]) + ([stx (in-list n-stxs)]) + (define this-stx (visit-stx stx)) + (if this-stx + (list* this-stx new-stxs) + new-stxs))) + (values (list* n new-tls1) + new-stxs2)]))) (define stx-visited? (make-hasheq)) (define (visit-stx n) (if (hash-has-key? stx-visited? n) diff --git a/collects/compiler/demodularizer/merge.rkt b/collects/compiler/demodularizer/merge.rkt index 5b087e257f..f118e6b9e4 100644 --- a/collects/compiler/demodularizer/merge.rkt +++ b/collects/compiler/demodularizer/merge.rkt @@ -1,5 +1,9 @@ -#lang racket -(require compiler/zo-parse +#lang racket/base + +(require racket/list + racket/match + racket/contract + compiler/zo-parse "util.rkt" "mpi.rkt" "nodep.rkt" @@ -156,12 +160,12 @@ (cond [(mod-lift-start . <= . n) ; This is a lift - (local [(define which-lift (- n mod-lift-start)) - (define lift-tl (+ top-lift-start lift-offset which-lift))] - (when (lift-tl . >= . max-toplevel) - (error 'merge-module "[~S] lift error: orig(~a) which(~a) max(~a) lifts(~a) now(~a)" - name n which-lift num-mod-toplevels mod-num-lifts lift-tl)) - lift-tl)] + (define which-lift (- n mod-lift-start)) + (define lift-tl (+ top-lift-start lift-offset which-lift)) + (when (lift-tl . >= . max-toplevel) + (error 'merge-module "[~S] lift error: orig(~a) which(~a) max(~a) lifts(~a) now(~a)" + name n which-lift num-mod-toplevels mod-num-lifts lift-tl)) + lift-tl] [else (list-ref toplevel-remap n)])) (lambda (n) diff --git a/collects/compiler/demodularizer/module.rkt b/collects/compiler/demodularizer/module.rkt index 9c907a5153..dca4498fec 100644 --- a/collects/compiler/demodularizer/module.rkt +++ b/collects/compiler/demodularizer/module.rkt @@ -1,5 +1,9 @@ -#lang racket -(require compiler/zo-parse +#lang racket/base + +(require racket/list + racket/match + racket/contract + compiler/zo-parse "util.rkt") (define (->module-path-index s) diff --git a/collects/compiler/demodularizer/mpi.rkt b/collects/compiler/demodularizer/mpi.rkt index 10f8cd23a5..bb430570dc 100644 --- a/collects/compiler/demodularizer/mpi.rkt +++ b/collects/compiler/demodularizer/mpi.rkt @@ -1,5 +1,7 @@ -#lang racket -(require syntax/modresolve) +#lang racket/base + +(require racket/contract + syntax/modresolve) (define current-module-path (make-parameter #f)) diff --git a/collects/compiler/demodularizer/nodep.rkt b/collects/compiler/demodularizer/nodep.rkt index 60afbaf7ec..4e55b46545 100644 --- a/collects/compiler/demodularizer/nodep.rkt +++ b/collects/compiler/demodularizer/nodep.rkt @@ -1,5 +1,9 @@ -#lang racket -(require compiler/zo-parse +#lang racket/base + +(require racket/list + racket/match + racket/contract + compiler/zo-parse "util.rkt" "mpi.rkt" racket/set) @@ -92,7 +96,8 @@ (define (nodep-form form phase) (if (mod? form) - (local [(define-values (modvar-rewrite lang-info mods) (nodep-module form phase))] + (let-values ([(modvar-rewrite lang-info mods) + (nodep-module form phase)]) (values modvar-rewrite lang-info (make-splice mods))) (error 'nodep-form "Doesn't support non mod forms"))) diff --git a/collects/compiler/demodularizer/replace-modidx.rkt b/collects/compiler/demodularizer/replace-modidx.rkt index 7ad45cbc56..f470e2b8f1 100644 --- a/collects/compiler/demodularizer/replace-modidx.rkt +++ b/collects/compiler/demodularizer/replace-modidx.rkt @@ -1,6 +1,10 @@ -#lang racket -(require unstable/struct +#lang racket/base + +(require racket/match + racket/vector + unstable/struct "util.rkt") + (provide replace-modidx) (define (replace-modidx expr self-modidx) diff --git a/collects/compiler/demodularizer/update-toplevels.rkt b/collects/compiler/demodularizer/update-toplevels.rkt index 3cc4ef9e14..6c1c83704e 100644 --- a/collects/compiler/demodularizer/update-toplevels.rkt +++ b/collects/compiler/demodularizer/update-toplevels.rkt @@ -1,5 +1,8 @@ -#lang racket -(require compiler/zo-structs +#lang racket/base + +(require racket/match + racket/contract + compiler/zo-structs "util.rkt") (define (update-toplevels toplevel-updater topsyntax-updater topsyntax-new-midpt) diff --git a/collects/compiler/demodularizer/util.rkt b/collects/compiler/demodularizer/util.rkt index 1865bc133f..e18966798e 100644 --- a/collects/compiler/demodularizer/util.rkt +++ b/collects/compiler/demodularizer/util.rkt @@ -1,5 +1,7 @@ -#lang racket -(require compiler/zo-parse) +#lang racket/base + +(require racket/contract + compiler/zo-parse) (define (prefix-syntax-start pre) (length (prefix-toplevels pre))) From f7dd4317a11de080acbdec49940724e8502b3d29 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 6 Nov 2012 15:22:02 -0500 Subject: [PATCH 193/221] `#lang racket' -> `#lang racket/base' conversions in future-visualizer. --- .../private/graph-drawing.rkt | 18 +++++++++++------- .../future-visualizer/scribblings/common.rkt | 2 +- 2 files changed, 12 insertions(+), 8 deletions(-) diff --git a/collects/future-visualizer/private/graph-drawing.rkt b/collects/future-visualizer/private/graph-drawing.rkt index ee4f6963df..a95662ad16 100644 --- a/collects/future-visualizer/private/graph-drawing.rkt +++ b/collects/future-visualizer/private/graph-drawing.rkt @@ -1,13 +1,17 @@ -#lang racket -(require rackunit +#lang racket/base + +(require racket/list + racket/contract + ;; rackunit "constants.rkt") -(provide (struct-out point) - (struct-out node) - (struct-out drawable-node) - (struct-out graph-layout) + +(provide (struct-out point) + (struct-out node) + (struct-out drawable-node) + (struct-out graph-layout) (struct-out attributed-node) draw-tree - drawable-node-center + drawable-node-center build-attr-tree) (define-struct/contract point ([x integer?] [y integer?]) #:transparent) diff --git a/collects/future-visualizer/scribblings/common.rkt b/collects/future-visualizer/scribblings/common.rkt index e445f288ea..8dd07868b8 100644 --- a/collects/future-visualizer/scribblings/common.rkt +++ b/collects/future-visualizer/scribblings/common.rkt @@ -1,4 +1,4 @@ -#lang racket +#lang racket/base (require (for-label racket/base) scribble/manual From 586b3234304ec5daa3e6bc56bd105024ed9315a5 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 6 Nov 2012 15:27:39 -0500 Subject: [PATCH 194/221] `#lang racket' -> `#lang racket/base' conversions in net/websocket. --- collects/net/websocket/client.rkt | 30 ++++++++++++++++------------ collects/net/websocket/conn.rkt | 7 +++++-- collects/net/websocket/handshake.rkt | 7 +++++-- collects/net/websocket/server.rkt | 10 +++++++--- 4 files changed, 34 insertions(+), 20 deletions(-) diff --git a/collects/net/websocket/client.rkt b/collects/net/websocket/client.rkt index 8df8708561..aef067f47a 100644 --- a/collects/net/websocket/client.rkt +++ b/collects/net/websocket/client.rkt @@ -1,5 +1,10 @@ -#lang racket -(require net/url +#lang racket/base + +(require racket/list + racket/port + racket/contract + racket/tcp + net/url web-server/http/response web-server/http/request web-server/http/request-structs @@ -32,17 +37,16 @@ (define the-path (if (empty? upath) "/" - (local - [(define pre-path - (add-between - (map (λ (pp) - (define p (path/param-path pp)) - (case p - [(up) ".."] - [(same) "."] - [else p])) - upath) - "/"))] + (let ([pre-path + (add-between + (map (λ (pp) + (define p (path/param-path pp)) + (case p + [(up) ".."] + [(same) "."] + [else p])) + upath) + "/")]) (apply string-append (if (url-path-absolute? url) (list* "/" diff --git a/collects/net/websocket/conn.rkt b/collects/net/websocket/conn.rkt index 46606fcd16..aeaad3a462 100644 --- a/collects/net/websocket/conn.rkt +++ b/collects/net/websocket/conn.rkt @@ -1,5 +1,8 @@ -#lang racket -(require web-server/http/request-structs) +#lang racket/base + +(require racket/match + racket/contract + web-server/http/request-structs) (define framing-mode (make-parameter 'old)) diff --git a/collects/net/websocket/handshake.rkt b/collects/net/websocket/handshake.rkt index ffd7f461ac..e05b05d9bb 100644 --- a/collects/net/websocket/handshake.rkt +++ b/collects/net/websocket/handshake.rkt @@ -1,5 +1,8 @@ -#lang racket -(require file/md5) +#lang racket/base + +(require racket/list + racket/contract + file/md5) (define RANGE 100000) diff --git a/collects/net/websocket/server.rkt b/collects/net/websocket/server.rkt index 76d253802f..e74db8406a 100644 --- a/collects/net/websocket/server.rkt +++ b/collects/net/websocket/server.rkt @@ -1,12 +1,16 @@ -#lang racket -(require web-server/private/dispatch-server-unit +#lang racket/base + +(require racket/list + racket/unit + racket/contract + unstable/contract + web-server/private/dispatch-server-unit web-server/private/dispatch-server-sig web-server/private/connection-manager web-server/http/response web-server/http/request web-server/http/request-structs racket/async-channel - unstable/contract net/tcp-sig (prefix-in raw: net/tcp-unit) net/websocket/conn From 6e4cad01e61cf5cfcd131fc8dc088d755fbececd Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 6 Nov 2012 15:33:49 -0500 Subject: [PATCH 195/221] `#lang racket' -> `#lang racket/base' conversions in stepper. --- collects/stepper/external-interface.rkt | 5 +++-- collects/stepper/private/annotate.rkt | 3 ++- collects/stepper/private/display-break-stuff.rkt | 6 ++---- collects/stepper/private/lifting.rkt | 4 +++- collects/stepper/private/macro-unwind.rkt | 4 +++- collects/stepper/private/mred-extensions.rkt | 6 +++--- collects/stepper/private/my-macros.rkt | 4 +++- collects/stepper/private/shared.rkt | 9 +++++++-- collects/stepper/private/xml-snip-helpers.rkt | 4 ++-- collects/stepper/stepper+xml-tool.rkt | 5 +++-- collects/stepper/xml-tool.rkt | 5 +++-- 11 files changed, 34 insertions(+), 21 deletions(-) diff --git a/collects/stepper/external-interface.rkt b/collects/stepper/external-interface.rkt index c2eb5c6b26..5136fae263 100644 --- a/collects/stepper/external-interface.rkt +++ b/collects/stepper/external-interface.rkt @@ -1,6 +1,7 @@ -#lang racket +#lang racket/base -(require "private/annotate.rkt" +(require racket/contract + "private/annotate.rkt" "private/marks.rkt") ;; an external interface for the stepper. diff --git a/collects/stepper/private/annotate.rkt b/collects/stepper/private/annotate.rkt index ece889520d..239c1a0e92 100644 --- a/collects/stepper/private/annotate.rkt +++ b/collects/stepper/private/annotate.rkt @@ -1,6 +1,7 @@ -#lang racket +#lang racket/base (require (prefix-in kernel: syntax/kerncase) + racket/match racket/contract "marks.rkt" "shared.rkt" diff --git a/collects/stepper/private/display-break-stuff.rkt b/collects/stepper/private/display-break-stuff.rkt index 8942841922..3eaae39bbb 100644 --- a/collects/stepper/private/display-break-stuff.rkt +++ b/collects/stepper/private/display-break-stuff.rkt @@ -1,6 +1,6 @@ -#lang racket +#lang racket/base -(require mred mzlib/class "marks.rkt") +(require racket/gui racket/class "marks.rkt") (provide display-break-stuff) @@ -63,5 +63,3 @@ returned-value-list) (add-sel break-number mark-set break-kind returned-value-list) (send f show #t)) - - diff --git a/collects/stepper/private/lifting.rkt b/collects/stepper/private/lifting.rkt index 466df5d1d5..1d05d85a51 100644 --- a/collects/stepper/private/lifting.rkt +++ b/collects/stepper/private/lifting.rkt @@ -1,6 +1,8 @@ -#lang racket +#lang racket/base (require (prefix-in kernel: syntax/kerncase) + racket/match + racket/contract "shared.rkt" "syntax-property.rkt" (for-syntax racket/base)) diff --git a/collects/stepper/private/macro-unwind.rkt b/collects/stepper/private/macro-unwind.rkt index e221af4094..8616b48548 100644 --- a/collects/stepper/private/macro-unwind.rkt +++ b/collects/stepper/private/macro-unwind.rkt @@ -1,6 +1,8 @@ -#lang racket +#lang racket/base (require (only-in syntax/kerncase kernel-syntax-case) + racket/list + racket/contract "model-settings.rkt" "shared.rkt" "syntax-property.rkt") diff --git a/collects/stepper/private/mred-extensions.rkt b/collects/stepper/private/mred-extensions.rkt index 6cc0e93df7..c3e7598de8 100644 --- a/collects/stepper/private/mred-extensions.rkt +++ b/collects/stepper/private/mred-extensions.rkt @@ -1,6 +1,6 @@ -#lang racket - -(require mred +#lang racket/base + +(require racket/gui (prefix-in f: framework) racket/pretty "syntax-property.rkt" diff --git a/collects/stepper/private/my-macros.rkt b/collects/stepper/private/my-macros.rkt index ee610095f8..2030750415 100644 --- a/collects/stepper/private/my-macros.rkt +++ b/collects/stepper/private/my-macros.rkt @@ -1,5 +1,7 @@ -#lang racket +#lang racket/base +(require (for-syntax racket/base) + racket/match) ;;;;;;;;;; ;; diff --git a/collects/stepper/private/shared.rkt b/collects/stepper/private/shared.rkt index e11c39080f..f45ef24e4b 100644 --- a/collects/stepper/private/shared.rkt +++ b/collects/stepper/private/shared.rkt @@ -1,6 +1,11 @@ -#lang racket +#lang racket/base -(require "syntax-property.rkt") +(require racket/list + racket/match + racket/contract + racket/class + racket/unit + "syntax-property.rkt") ; CONTRACTS diff --git a/collects/stepper/private/xml-snip-helpers.rkt b/collects/stepper/private/xml-snip-helpers.rkt index 33b7804860..d9fc7d2423 100644 --- a/collects/stepper/private/xml-snip-helpers.rkt +++ b/collects/stepper/private/xml-snip-helpers.rkt @@ -1,8 +1,8 @@ -#lang racket +#lang racket/base (require xml/xml syntax/readerr - mred + racket/gui "syntax-property.rkt") (provide xml-read-special diff --git a/collects/stepper/stepper+xml-tool.rkt b/collects/stepper/stepper+xml-tool.rkt index f3e05e45d5..7dd8cb52f1 100644 --- a/collects/stepper/stepper+xml-tool.rkt +++ b/collects/stepper/stepper+xml-tool.rkt @@ -1,6 +1,7 @@ -#lang racket +#lang racket/base -(require drracket/tool +(require racket/unit + drracket/tool "stepper-tool.rkt" "xml-tool.rkt" "private/view-controller.rkt") diff --git a/collects/stepper/xml-tool.rkt b/collects/stepper/xml-tool.rkt index f3c64d6206..5f3739dbd9 100644 --- a/collects/stepper/xml-tool.rkt +++ b/collects/stepper/xml-tool.rkt @@ -1,9 +1,10 @@ -#lang racket +#lang racket/base (require "private/xml-snip-helpers.rkt" "private/find-tag.rkt" "private/xml-sig.rkt" - mred + racket/unit + racket/gui framework drracket/tool xml/xml From b786a49b5b931e82baf40500c17192592a8993c6 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 6 Nov 2012 15:41:50 -0500 Subject: [PATCH 196/221] `#lang racket' -> `#lang racket/base' conversions in frtime. --- collects/frtime/animation/graphics-sig.rkt | 3 ++- collects/frtime/animation/graphics-unit.rkt | 3 ++- collects/frtime/animation/graphics.rkt | 3 ++- collects/frtime/core/contract.rkt | 7 +++--- collects/frtime/core/dv.rkt | 6 +++-- collects/frtime/core/erl.rkt | 7 ++++-- collects/frtime/core/frp.rkt | 9 +++++-- collects/frtime/core/heap.rkt | 8 +++++-- collects/frtime/core/mailbox.rkt | 8 +++++-- collects/frtime/core/match.rkt | 2 +- collects/frtime/core/sema-mailbox.rkt | 8 +++++-- collects/frtime/develop-frtime.rkt | 26 +++++++++------------ collects/frtime/frlibs/date.rkt | 7 +++--- collects/frtime/opt/lowered-equivs.rkt | 4 ++-- 14 files changed, 62 insertions(+), 39 deletions(-) diff --git a/collects/frtime/animation/graphics-sig.rkt b/collects/frtime/animation/graphics-sig.rkt index d7cc99d319..20cb989db4 100644 --- a/collects/frtime/animation/graphics-sig.rkt +++ b/collects/frtime/animation/graphics-sig.rkt @@ -1,4 +1,5 @@ -#lang racket +#lang racket/base + (require racket/unit) (provide graphics^ graphics:posn-less^ graphics:posn^) diff --git a/collects/frtime/animation/graphics-unit.rkt b/collects/frtime/animation/graphics-unit.rkt index d7753a4cdd..d5839d0b18 100644 --- a/collects/frtime/animation/graphics-unit.rkt +++ b/collects/frtime/animation/graphics-unit.rkt @@ -1,4 +1,5 @@ -#lang racket +#lang racket/base + (require racket/unit mred/mred-sig "graphics-sig.rkt" diff --git a/collects/frtime/animation/graphics.rkt b/collects/frtime/animation/graphics.rkt index 89dc677b8e..0f61b8d078 100644 --- a/collects/frtime/animation/graphics.rkt +++ b/collects/frtime/animation/graphics.rkt @@ -1,4 +1,5 @@ -#lang racket +#lang racket/base + (require racket/unit mred/mred-sig mred diff --git a/collects/frtime/core/contract.rkt b/collects/frtime/core/contract.rkt index b97b17cd7c..3d97d9b3d6 100644 --- a/collects/frtime/core/contract.rkt +++ b/collects/frtime/core/contract.rkt @@ -1,8 +1,9 @@ -#lang racket +#lang racket/base + +#;(require (for-syntax racket/contract)) (define-syntax-rule (provide/contract* [id ctrct] ...) #;(provide/contract [id ctrct] ...) (provide id ...)) -(provide - provide/contract*) +(provide provide/contract*) diff --git a/collects/frtime/core/dv.rkt b/collects/frtime/core/dv.rkt index 4b9ba467b6..b80fa42fa1 100644 --- a/collects/frtime/core/dv.rkt +++ b/collects/frtime/core/dv.rkt @@ -1,5 +1,7 @@ -#lang racket -(require "contract.rkt") +#lang racket/base + +(require racket/match + "contract.rkt") (define-struct dv (vec-length next-avail-pos vec) #:mutable) diff --git a/collects/frtime/core/erl.rkt b/collects/frtime/core/erl.rkt index 2849650c2d..1496b4a97a 100644 --- a/collects/frtime/core/erl.rkt +++ b/collects/frtime/core/erl.rkt @@ -1,5 +1,8 @@ -#lang racket -(require "match.rkt" +#lang racket/base + +(require racket/bool + racket/match + "match.rkt" "contract.rkt" #;"sema-mailbox.rkt" "mailbox.rkt") diff --git a/collects/frtime/core/frp.rkt b/collects/frtime/core/frp.rkt index 39d1375db1..f9e126e848 100644 --- a/collects/frtime/core/frp.rkt +++ b/collects/frtime/core/frp.rkt @@ -1,5 +1,10 @@ -#lang racket -(require "contract.rkt" +#lang racket/base + +(require racket/function + racket/list + racket/match + racket/contract + "contract.rkt" "erl.rkt" "heap.rkt") diff --git a/collects/frtime/core/heap.rkt b/collects/frtime/core/heap.rkt index 0f23a7feb3..9ec64ba06e 100644 --- a/collects/frtime/core/heap.rkt +++ b/collects/frtime/core/heap.rkt @@ -1,5 +1,9 @@ -#lang racket -(require "dv.rkt" +#lang racket/base + +(require racket/bool + racket/match + racket/contract + "dv.rkt" "contract.rkt") (define-struct t (sorter equality data)) diff --git a/collects/frtime/core/mailbox.rkt b/collects/frtime/core/mailbox.rkt index 228fd94360..a22a6fb1ca 100644 --- a/collects/frtime/core/mailbox.rkt +++ b/collects/frtime/core/mailbox.rkt @@ -1,5 +1,9 @@ -#lang racket -(require "contract.rkt" +#lang racket/base + +(require racket/bool + racket/list + racket/match + "contract.rkt" "match.rkt" racket/async-channel) diff --git a/collects/frtime/core/match.rkt b/collects/frtime/core/match.rkt index a2b6d71741..ac3808c9d7 100644 --- a/collects/frtime/core/match.rkt +++ b/collects/frtime/core/match.rkt @@ -1,4 +1,4 @@ -#lang racket +#lang racket/base (define-struct a-match-fail ()) (define match-fail (make-a-match-fail)) diff --git a/collects/frtime/core/sema-mailbox.rkt b/collects/frtime/core/sema-mailbox.rkt index 44b1e72e75..d3d88e8f59 100644 --- a/collects/frtime/core/sema-mailbox.rkt +++ b/collects/frtime/core/sema-mailbox.rkt @@ -1,5 +1,9 @@ -#lang racket -(require "match.rkt" +#lang racket/base + +(require racket/list + racket/bool + racket/match + "match.rkt" "contract.rkt") (define (call-with-semaphore s thunk) diff --git a/collects/frtime/develop-frtime.rkt b/collects/frtime/develop-frtime.rkt index 25cce1fc7f..979e304dbb 100644 --- a/collects/frtime/develop-frtime.rkt +++ b/collects/frtime/develop-frtime.rkt @@ -1,6 +1,6 @@ -#lang racket -(require setup/link) +#lang racket/base +(require setup/link) #|Update this to point to your racket installation directory|# (define install-path "C:/Program Files/Racket/collects/frtime") @@ -9,20 +9,16 @@ (define dev-path "C:/Users/user/Documents/GitHub/racket/collects/frtime") #|Then call one of these functions to begin developing frtime, or to halt development.|# -(define start-developing-frtime - (lambda () - (start-developing-collection dev-path install-path))) +(define (start-developing-frtime) + (start-developing-collection dev-path install-path)) -(define stop-developing-frtime - (lambda () - (stop-developing-collection dev-path install-path))) +(define (stop-developing-frtime) + (stop-developing-collection dev-path install-path)) -(define start-developing-collection - (lambda (dev-coll-path install-coll-path) - (links install-coll-path #:remove? #t) - (links dev-coll-path))) +(define (start-developing-collection dev-coll-path install-coll-path) + (links install-coll-path #:remove? #t) + (links dev-coll-path)) -(define stop-developing-collection - (lambda (dev-coll-path install-coll-path) - (start-developing-collection install-coll-path dev-coll-path))) +(define (stop-developing-collection dev-coll-path install-coll-path) + (start-developing-collection install-coll-path dev-coll-path)) diff --git a/collects/frtime/frlibs/date.rkt b/collects/frtime/frlibs/date.rkt index 55fbcee54d..6cc4a870e0 100644 --- a/collects/frtime/frlibs/date.rkt +++ b/collects/frtime/frlibs/date.rkt @@ -1,6 +1,7 @@ -#lang racket -(require (rename-in (only-in frtime/frtime provide) - [provide frtime:provide])) +#lang racket/base + +(require racket/promise + (only-in frtime/frtime [provide frtime:provide])) (frtime:provide (lifted date->string date-display-format diff --git a/collects/frtime/opt/lowered-equivs.rkt b/collects/frtime/opt/lowered-equivs.rkt index 1702f2a97f..d017785393 100644 --- a/collects/frtime/opt/lowered-equivs.rkt +++ b/collects/frtime/opt/lowered-equivs.rkt @@ -1,10 +1,10 @@ ;; This module defines all the logic necessary for working with lowered ;; equivalents at the syntactic level. That is, it treats functions simply ;; as syntactic identifiers. -#lang racket +#lang racket/base + (provide (except-out (all-defined-out) module-identifier=?)) -(require (only-in srfi/1 any)) (define module-identifier=? free-identifier=?) From 8033900674329c0dbebba802e6484546fb0dfc8d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 6 Nov 2012 18:06:44 -0700 Subject: [PATCH 197/221] add ad hoc optimization of `car' to `unsafe-car', etc. In `(if (pair? x) E1 E2)', convert `(car x)' in E1 to `(unsafe-car x)', and similarly for `(cdr x)'. Also, `(begin (car x) (cdr x))' converts to `(begin (car x) (unsafe-cdr x))' since `(car x)' implies a `pair?' test on `x'. --- .../tests/racket/benchmarks/common/auto.rkt | 20 +- collects/tests/racket/optimize.rktl | 57 + src/racket/src/cstartup.inc | 1296 +++++++++-------- src/racket/src/list.c | 24 + src/racket/src/mzmarksrc.c | 1 + src/racket/src/optimize.c | 104 +- src/racket/src/schpriv.h | 10 + src/racket/src/schvers.h | 4 +- src/racket/src/vector.c | 7 + 9 files changed, 866 insertions(+), 657 deletions(-) diff --git a/collects/tests/racket/benchmarks/common/auto.rkt b/collects/tests/racket/benchmarks/common/auto.rkt index f0078280ed..bc0e323f34 100755 --- a/collects/tests/racket/benchmarks/common/auto.rkt +++ b/collects/tests/racket/benchmarks/common/auto.rkt @@ -353,6 +353,10 @@ exec racket -qu "$0" ${1+"$@"} sort1)) (define racket-specific-progs '(nucleic3 ray)) + ;; could put `mutable-pair-progs' on next line, but they're + ;; run as R5RS-module program + (define racket-skip-progs null) + (define impls (list (make-impl 'racket @@ -362,7 +366,7 @@ exec racket -qu "$0" ${1+"$@"} (system (format "racket -u ~a.rkt" bm))) extract-racket-times clean-up-zo - mutable-pair-progs) + racket-skip-progs) (make-impl 'mz-old void mk-mz-old @@ -370,7 +374,7 @@ exec racket -qu "$0" ${1+"$@"} (system (format "mz-old -u ~a.rkt" bm))) extract-racket-times clean-up-zo - mutable-pair-progs) + racket-skip-progs) (make-impl 'racketcgc void mk-racket @@ -378,7 +382,7 @@ exec racket -qu "$0" ${1+"$@"} (system (format "racketcgc -u ~a.rkt" bm))) extract-racket-times clean-up-zo - mutable-pair-progs) + racket-skip-progs) (make-impl 'racket3m void mk-racket @@ -386,7 +390,7 @@ exec racket -qu "$0" ${1+"$@"} (system (format "racket3m -u ~a.rkt" bm))) extract-racket-times clean-up-zo - mutable-pair-progs) + racket-skip-progs) (make-impl 'plt-r5rs void mk-plt-r5rs @@ -405,7 +409,7 @@ exec racket -qu "$0" ${1+"$@"} extract-racket-times clean-up-extension (append '(takr takr2) - mutable-pair-progs)) + racket-skip-progs)) (make-impl 'racket-j void mk-racket @@ -413,7 +417,7 @@ exec racket -qu "$0" ${1+"$@"} (system (format "racket -jqu ~a.rkt" bm))) extract-racket-times clean-up-zo - mutable-pair-progs) + racket-skip-progs) (make-impl 'racketcgc-j void mk-racket @@ -421,7 +425,7 @@ exec racket -qu "$0" ${1+"$@"} (system (format "racketcgc -jqu ~a.rkt" bm))) extract-racket-times clean-up-zo - mutable-pair-progs) + racket-skip-progs) (make-impl 'racketcgc-tl void mk-racket-tl @@ -430,7 +434,7 @@ exec racket -qu "$0" ${1+"$@"} extract-racket-times clean-up-zo (append '(nucleic2) - mutable-pair-progs)) + racket-skip-progs)) (make-impl 'typed-racket-non-optimizing void mk-typed-racket-non-optimizing diff --git a/collects/tests/racket/optimize.rktl b/collects/tests/racket/optimize.rktl index a28af619e6..8bfffb6abc 100644 --- a/collects/tests/racket/optimize.rktl +++ b/collects/tests/racket/optimize.rktl @@ -1447,6 +1447,63 @@ (test-bin 'eq?) (test-bin 'eqv?)) +(let ([test-use-unsafe + (lambda (pred op unsafe-op) + (test-comp `(module m racket/base + (require racket/unsafe/ops) + (define (f x) + (if (,pred x) + (,op x) + (cdr x)))) + `(module m racket/base + (require racket/unsafe/ops) + (define (f x) + (if (,pred x) + (,unsafe-op x) + (cdr x))))) + (test-comp `(module m racket/base + (require racket/unsafe/ops) + (define (f x) + (list (,op x) (,op x)))) + `(module m racket/base + (require racket/unsafe/ops) + (define (f x) + (list (,op x) (,unsafe-op x))))) + (test-comp `(module m racket/base + (require racket/unsafe/ops) + (define (f x) + (if (and (,pred x) + (zero? (random 2))) + (,op x) + (cdr x)))) + `(module m racket/base + (require racket/unsafe/ops) + (define (f x) + (if (and (,pred x) + (zero? (random 2))) + (,unsafe-op x) + (cdr x))))))]) + (test-use-unsafe 'pair? 'car 'unsafe-car) + (test-use-unsafe 'pair? 'cdr 'unsafe-cdr) + (test-use-unsafe 'mpair? 'mcar 'unsafe-mcar) + (test-use-unsafe 'mpair? 'mcdr 'unsafe-mcdr) + (test-use-unsafe 'box? 'unbox 'unsafe-unbox)) + +(test-comp `(module m racket/base + (require racket/unsafe/ops) + (define (f x) + (thread (lambda () (set! x 5))) + (if (pair? x) + (car x) + (cdr x)))) + `(module m racket/base + (require racket/unsafe/ops) + (define (f x) + (thread (lambda () (set! x 5))) + (if (pair? x) + (unsafe-car x) + (cdr x)))) + #f) ;; + fold to fixnum overflow, fx+ doesn't (test-comp `(module m racket/base diff --git a/src/racket/src/cstartup.inc b/src/racket/src/cstartup.inc index 83534ecb81..769f9e02b5 100644 --- a/src/racket/src/cstartup.inc +++ b/src/racket/src/cstartup.inc @@ -1,15 +1,15 @@ { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,52,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,53,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,51,0,0,0,1,0,0,10,0,14,0, -21,0,25,0,29,0,36,0,41,0,54,0,61,0,66,0,69,0,74,0,83, +21,0,28,0,33,0,37,0,40,0,45,0,58,0,62,0,67,0,74,0,83, 0,87,0,93,0,107,0,121,0,124,0,130,0,134,0,136,0,147,0,149,0, 163,0,170,0,192,0,194,0,208,0,19,1,48,1,59,1,70,1,96,1,129, -1,162,1,221,1,21,2,99,2,155,2,160,2,180,2,73,3,93,3,145,3, -211,3,100,4,242,4,40,5,51,5,130,5,0,0,92,7,0,0,69,35,37, -109,105,110,45,115,116,120,29,11,11,11,66,100,101,102,105,110,101,63,97,110, -100,63,108,101,116,66,117,110,108,101,115,115,64,99,111,110,100,72,112,97,114, -97,109,101,116,101,114,105,122,101,66,108,101,116,114,101,99,64,108,101,116,42, -62,111,114,64,119,104,101,110,68,104,101,114,101,45,115,116,120,29,11,11,11, +1,162,1,224,1,24,2,105,2,161,2,166,2,187,2,84,3,105,3,158,3, +225,3,114,4,2,5,56,5,67,5,150,5,0,0,112,7,0,0,69,35,37, +109,105,110,45,115,116,120,29,11,11,11,66,100,101,102,105,110,101,66,108,101, +116,114,101,99,64,108,101,116,42,63,97,110,100,62,111,114,64,119,104,101,110, +72,112,97,114,97,109,101,116,101,114,105,122,101,63,108,101,116,64,99,111,110, +100,66,117,110,108,101,115,115,68,104,101,114,101,45,115,116,120,29,11,11,11, 65,113,117,111,116,101,29,94,2,15,68,35,37,107,101,114,110,101,108,11,29, 94,2,15,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, @@ -17,8 +17,8 @@ 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, 110,88,0,0,95,159,2,17,36,36,159,2,16,36,36,159,2,16,36,36,16, -20,2,3,2,2,2,4,2,2,2,5,2,2,2,6,2,2,2,10,2,2, -2,7,2,2,2,8,2,2,2,9,2,2,2,11,2,2,2,12,2,2,97, +20,2,3,2,2,2,4,2,2,2,5,2,2,2,6,2,2,2,7,2,2, +2,8,2,2,2,11,2,2,2,10,2,2,2,9,2,2,2,12,2,2,97, 37,11,8,240,110,88,0,0,93,159,2,16,36,37,16,2,2,13,161,2,2, 37,2,13,2,2,2,13,96,38,11,8,240,110,88,0,0,16,0,96,11,11, 8,240,110,88,0,0,16,0,18,98,64,104,101,114,101,13,16,6,36,2,14, @@ -27,79 +27,80 @@ 248,22,106,201,27,248,22,163,4,195,249,22,156,4,80,158,39,36,251,22,89, 2,18,248,22,104,199,249,22,79,2,19,248,22,106,201,12,27,248,22,81,248, 22,163,4,196,28,248,22,87,193,20,14,159,37,36,37,28,248,22,87,248,22, -81,194,248,22,80,193,249,22,156,4,80,158,39,36,251,22,89,2,18,248,22, -80,199,249,22,79,2,4,248,22,81,201,11,18,100,10,13,16,6,36,2,14, -2,2,11,11,11,8,32,8,31,8,30,8,29,16,4,11,11,2,20,3,1, -8,101,110,118,49,55,51,51,57,16,4,11,11,2,21,3,1,8,101,110,118, -49,55,51,52,48,27,248,22,81,248,22,163,4,196,28,248,22,87,193,20,14, -159,37,36,37,28,248,22,87,248,22,81,194,248,22,80,193,249,22,156,4,80, -158,39,36,250,22,89,2,22,248,22,89,249,22,89,248,22,89,2,23,248,22, -80,201,251,22,89,2,18,2,23,2,23,249,22,79,2,11,248,22,81,204,18, -100,11,13,16,6,36,2,14,2,2,11,11,11,8,32,8,31,8,30,8,29, -16,4,11,11,2,20,3,1,8,101,110,118,49,55,51,52,50,16,4,11,11, -2,21,3,1,8,101,110,118,49,55,51,52,51,248,22,163,4,193,27,248,22, -163,4,194,249,22,79,248,22,89,248,22,80,196,248,22,81,195,27,248,22,81, -248,22,163,4,23,197,1,249,22,156,4,80,158,39,36,28,248,22,64,248,22, -157,4,248,22,80,23,198,2,27,249,22,2,32,0,88,163,8,36,37,43,11, -9,222,33,40,248,22,163,4,248,22,104,23,200,2,250,22,89,2,24,248,22, -89,249,22,89,248,22,89,248,22,80,23,204,2,250,22,90,2,25,249,22,2, -22,80,23,204,2,248,22,106,23,206,2,249,22,79,248,22,80,23,202,1,249, -22,2,22,104,23,200,1,250,22,90,2,22,249,22,2,32,0,88,163,8,36, -37,47,11,9,222,33,41,248,22,163,4,248,22,80,201,248,22,81,198,27,248, -22,163,4,194,249,22,79,248,22,89,248,22,80,196,248,22,81,195,27,248,22, -81,248,22,163,4,23,197,1,249,22,156,4,80,158,39,36,250,22,90,2,24, -249,22,2,32,0,88,163,8,36,37,47,11,9,222,33,43,248,22,163,4,248, -22,80,201,248,22,81,198,27,248,22,81,248,22,163,4,196,27,248,22,163,4, -248,22,80,195,249,22,156,4,80,158,40,36,28,248,22,87,195,250,22,90,2, -22,9,248,22,81,199,250,22,89,2,5,248,22,89,248,22,80,199,250,22,90, -2,10,248,22,81,201,248,22,81,202,27,248,22,81,248,22,163,4,23,197,1, -27,249,22,1,22,93,249,22,2,22,163,4,248,22,163,4,248,22,80,199,248, -22,183,4,249,22,156,4,80,158,41,36,251,22,89,1,22,119,105,116,104,45, -99,111,110,116,105,110,117,97,116,105,111,110,45,109,97,114,107,2,26,250,22, -90,1,23,101,120,116,101,110,100,45,112,97,114,97,109,101,116,101,114,105,122, -97,116,105,111,110,21,95,1,27,99,111,110,116,105,110,117,97,116,105,111,110, -45,109,97,114,107,45,115,101,116,45,102,105,114,115,116,11,2,26,202,250,22, -90,2,22,9,248,22,81,204,27,248,22,81,248,22,163,4,196,28,248,22,87, -193,20,14,159,37,36,37,249,22,156,4,80,158,39,36,27,248,22,163,4,248, -22,80,197,28,249,22,152,9,62,61,62,248,22,157,4,248,22,104,196,250,22, -89,2,22,248,22,89,249,22,89,21,93,2,27,248,22,80,199,250,22,90,2, -7,249,22,89,2,27,249,22,89,248,22,113,203,2,27,248,22,81,202,251,22, -89,2,18,28,249,22,152,9,248,22,157,4,248,22,80,200,64,101,108,115,101, -10,248,22,80,197,250,22,90,2,22,9,248,22,81,200,249,22,79,2,7,248, -22,81,202,99,13,16,6,36,2,14,2,2,11,11,11,8,32,8,31,8,30, -8,29,16,4,11,11,2,20,3,1,8,101,110,118,49,55,51,54,53,16,4, -11,11,2,21,3,1,8,101,110,118,49,55,51,54,54,18,158,94,10,64,118, -111,105,100,8,48,27,248,22,81,248,22,163,4,196,249,22,156,4,80,158,39, -36,28,248,22,64,248,22,157,4,248,22,80,197,250,22,89,2,28,248,22,89, -248,22,80,199,248,22,104,198,27,248,22,157,4,248,22,80,197,250,22,89,2, -28,248,22,89,248,22,80,197,250,22,90,2,25,248,22,81,199,248,22,81,202, -159,36,20,113,159,36,16,1,11,16,0,20,26,149,9,2,1,2,1,2,2, -9,9,11,11,11,10,36,80,158,36,36,20,113,159,36,16,0,16,0,38,39, -36,16,0,36,16,0,36,11,11,11,16,10,2,3,2,4,2,5,2,6,2, -7,2,8,2,9,2,10,2,11,2,12,16,10,11,11,11,11,11,11,11,11, -11,11,16,10,2,3,2,4,2,5,2,6,2,7,2,8,2,9,2,10,2, -11,2,12,36,46,37,16,0,36,16,1,2,13,37,11,11,11,16,0,16,0, -16,0,36,36,11,12,11,11,16,0,16,0,16,0,36,36,16,11,16,5,11, -20,15,16,2,20,14,159,36,36,37,80,158,36,36,36,20,113,159,36,16,1, -2,13,16,1,33,33,10,16,5,2,6,88,163,8,36,37,53,37,9,223,0, -33,34,36,20,113,159,36,16,1,2,13,16,0,11,16,5,2,12,88,163,8, -36,37,53,37,9,223,0,33,35,36,20,113,159,36,16,1,2,13,16,0,11, -16,5,2,4,88,163,8,36,37,53,37,9,223,0,33,36,36,20,113,159,36, -16,1,2,13,16,1,33,37,11,16,5,2,11,88,163,8,36,37,56,37,9, -223,0,33,38,36,20,113,159,36,16,1,2,13,16,1,33,39,11,16,5,2, -5,88,163,8,36,37,58,37,9,223,0,33,42,36,20,113,159,36,16,1,2, -13,16,0,11,16,5,2,9,88,163,8,36,37,53,37,9,223,0,33,44,36, -20,113,159,36,16,1,2,13,16,0,11,16,5,2,10,88,163,8,36,37,54, -37,9,223,0,33,45,36,20,113,159,36,16,1,2,13,16,0,11,16,5,2, -8,88,163,8,36,37,56,37,9,223,0,33,46,36,20,113,159,36,16,1,2, -13,16,0,11,16,5,2,7,88,163,8,36,37,58,37,9,223,0,33,47,36, -20,113,159,36,16,1,2,13,16,1,33,49,11,16,5,2,3,88,163,8,36, -37,54,37,9,223,0,33,50,36,20,113,159,36,16,1,2,13,16,0,11,16, -0,94,2,16,2,17,93,2,16,9,9,36,0}; - EVAL_ONE_SIZED_STR((char *)expr, 2028); +81,194,248,22,163,17,193,249,22,156,4,80,158,39,36,251,22,89,2,18,248, +22,163,17,199,249,22,79,2,6,248,22,164,17,201,11,18,100,10,13,16,6, +36,2,14,2,2,11,11,11,8,32,8,31,8,30,8,29,16,4,11,11,2, +20,3,1,8,101,110,118,49,55,51,51,57,16,4,11,11,2,21,3,1,8, +101,110,118,49,55,51,52,48,27,248,22,81,248,22,163,4,196,28,248,22,87, +193,20,14,159,37,36,37,28,248,22,87,248,22,81,194,248,22,163,17,193,249, +22,156,4,80,158,39,36,250,22,89,2,22,248,22,89,249,22,89,248,22,89, +2,23,248,22,163,17,201,251,22,89,2,18,2,23,2,23,249,22,79,2,7, +248,22,164,17,204,18,100,11,13,16,6,36,2,14,2,2,11,11,11,8,32, +8,31,8,30,8,29,16,4,11,11,2,20,3,1,8,101,110,118,49,55,51, +52,50,16,4,11,11,2,21,3,1,8,101,110,118,49,55,51,52,51,248,22, +163,4,193,27,248,22,163,4,194,249,22,79,248,22,89,248,22,80,196,248,22, +164,17,195,27,248,22,81,248,22,163,4,23,197,1,249,22,156,4,80,158,39, +36,28,248,22,64,248,22,157,4,248,22,80,23,198,2,27,249,22,2,32,0, +88,163,8,36,37,43,11,9,222,33,40,248,22,163,4,248,22,104,23,200,2, +250,22,89,2,24,248,22,89,249,22,89,248,22,89,248,22,163,17,23,204,2, +250,22,90,2,25,249,22,2,22,80,23,204,2,248,22,106,23,206,2,249,22, +79,248,22,163,17,23,202,1,249,22,2,22,104,23,200,1,250,22,90,2,22, +249,22,2,32,0,88,163,8,36,37,47,11,9,222,33,41,248,22,163,4,248, +22,163,17,201,248,22,164,17,198,27,248,22,163,4,194,249,22,79,248,22,89, +248,22,80,196,248,22,164,17,195,27,248,22,81,248,22,163,4,23,197,1,249, +22,156,4,80,158,39,36,250,22,90,2,24,249,22,2,32,0,88,163,8,36, +37,47,11,9,222,33,43,248,22,163,4,248,22,80,201,248,22,164,17,198,27, +248,22,81,248,22,163,4,196,27,248,22,163,4,248,22,80,195,249,22,156,4, +80,158,40,36,28,248,22,87,195,250,22,90,2,22,9,248,22,81,199,250,22, +89,2,10,248,22,89,248,22,80,199,250,22,90,2,5,248,22,164,17,201,248, +22,81,202,27,248,22,81,248,22,163,4,23,197,1,27,249,22,1,22,93,249, +22,2,22,163,4,248,22,163,4,248,22,80,199,248,22,183,4,249,22,156,4, +80,158,41,36,251,22,89,1,22,119,105,116,104,45,99,111,110,116,105,110,117, +97,116,105,111,110,45,109,97,114,107,2,26,250,22,90,1,23,101,120,116,101, +110,100,45,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,21,95, +1,27,99,111,110,116,105,110,117,97,116,105,111,110,45,109,97,114,107,45,115, +101,116,45,102,105,114,115,116,11,2,26,202,250,22,90,2,22,9,248,22,81, +204,27,248,22,81,248,22,163,4,196,28,248,22,87,193,20,14,159,37,36,37, +249,22,156,4,80,158,39,36,27,248,22,163,4,248,22,80,197,28,249,22,152, +9,62,61,62,248,22,157,4,248,22,104,196,250,22,89,2,22,248,22,89,249, +22,89,21,93,2,27,248,22,80,199,250,22,90,2,11,249,22,89,2,27,249, +22,89,248,22,113,203,2,27,248,22,81,202,251,22,89,2,18,28,249,22,152, +9,248,22,157,4,248,22,80,200,64,101,108,115,101,10,248,22,163,17,197,250, +22,90,2,22,9,248,22,164,17,200,249,22,79,2,11,248,22,81,202,99,13, +16,6,36,2,14,2,2,11,11,11,8,32,8,31,8,30,8,29,16,4,11, +11,2,20,3,1,8,101,110,118,49,55,51,54,53,16,4,11,11,2,21,3, +1,8,101,110,118,49,55,51,54,54,18,158,94,10,64,118,111,105,100,8,48, +27,248,22,81,248,22,163,4,196,249,22,156,4,80,158,39,36,28,248,22,64, +248,22,157,4,248,22,80,197,250,22,89,2,28,248,22,89,248,22,163,17,199, +248,22,104,198,27,248,22,157,4,248,22,163,17,197,250,22,89,2,28,248,22, +89,248,22,80,197,250,22,90,2,25,248,22,164,17,199,248,22,164,17,202,159, +36,20,113,159,36,16,1,11,16,0,20,26,149,9,2,1,2,1,2,2,9, +9,11,11,11,10,36,80,158,36,36,20,113,159,36,16,0,16,0,38,39,36, +16,0,36,16,0,36,11,11,11,16,10,2,3,2,4,2,5,2,6,2,7, +2,8,2,9,2,10,2,11,2,12,16,10,11,11,11,11,11,11,11,11,11, +11,16,10,2,3,2,4,2,5,2,6,2,7,2,8,2,9,2,10,2,11, +2,12,36,46,37,16,0,36,16,1,2,13,37,11,11,11,16,0,16,0,16, +0,36,36,11,12,11,11,16,0,16,0,16,0,36,36,16,11,16,5,11,20, +15,16,2,20,14,159,36,36,37,80,158,36,36,36,20,113,159,36,16,1,2, +13,16,1,33,33,10,16,5,2,12,88,163,8,36,37,53,37,9,223,0,33, +34,36,20,113,159,36,16,1,2,13,16,0,11,16,5,2,8,88,163,8,36, +37,53,37,9,223,0,33,35,36,20,113,159,36,16,1,2,13,16,0,11,16, +5,2,6,88,163,8,36,37,53,37,9,223,0,33,36,36,20,113,159,36,16, +1,2,13,16,1,33,37,11,16,5,2,7,88,163,8,36,37,56,37,9,223, +0,33,38,36,20,113,159,36,16,1,2,13,16,1,33,39,11,16,5,2,10, +88,163,8,36,37,58,37,9,223,0,33,42,36,20,113,159,36,16,1,2,13, +16,0,11,16,5,2,4,88,163,8,36,37,53,37,9,223,0,33,44,36,20, +113,159,36,16,1,2,13,16,0,11,16,5,2,5,88,163,8,36,37,54,37, +9,223,0,33,45,36,20,113,159,36,16,1,2,13,16,0,11,16,5,2,9, +88,163,8,36,37,56,37,9,223,0,33,46,36,20,113,159,36,16,1,2,13, +16,0,11,16,5,2,11,88,163,8,36,37,58,37,9,223,0,33,47,36,20, +113,159,36,16,1,2,13,16,1,33,49,11,16,5,2,3,88,163,8,36,37, +54,37,9,223,0,33,50,36,20,113,159,36,16,1,2,13,16,0,11,16,0, +94,2,16,2,17,93,2,16,9,9,36,0}; + EVAL_ONE_SIZED_STR((char *)expr, 2048); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,52,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,53,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,126,0,0,0,1,0,0,8,0,21,0, 26,0,43,0,55,0,77,0,106,0,121,0,139,0,151,0,167,0,181,0,203, 0,219,0,236,0,2,1,13,1,19,1,28,1,35,1,42,1,54,1,70,1, @@ -109,10 +110,10 @@ 3,130,3,171,3,194,3,202,3,226,3,247,3,191,4,221,4,90,8,113,8, 130,8,78,10,181,10,195,10,99,11,22,13,31,13,40,13,54,13,64,13,105, 14,208,14,7,15,62,15,149,15,170,15,227,15,80,16,137,16,47,17,55,17, -161,17,224,17,226,17,82,18,142,18,147,18,14,19,25,19,162,19,172,19,98, -21,120,21,129,21,122,22,140,22,154,22,175,22,187,22,232,22,239,22,1,23, -49,23,62,23,124,25,35,26,180,26,165,27,147,28,154,28,161,28,23,29,141, -29,241,30,66,31,149,31,234,31,169,32,195,32,68,33,0,0,245,37,0,0, +161,17,224,17,226,17,82,18,142,18,147,18,15,19,26,19,164,19,174,19,100, +21,122,21,131,21,124,22,142,22,156,22,177,22,189,22,237,22,244,22,6,23, +57,23,70,23,132,25,43,26,188,26,173,27,155,28,162,28,169,28,31,29,149, +29,249,30,74,31,157,31,242,31,177,32,203,32,76,33,0,0,253,37,0,0, 67,35,37,117,116,105,108,115,72,112,97,116,104,45,115,116,114,105,110,103,63, 64,98,115,98,115,76,110,111,114,109,97,108,45,99,97,115,101,45,112,97,116, 104,71,114,101,114,111,111,116,45,112,97,116,104,1,20,102,105,110,100,45,101, @@ -342,244 +343,245 @@ 115,105,111,110,248,22,191,5,193,28,248,22,88,23,194,2,28,28,249,22,191, 3,38,248,22,92,23,196,2,10,249,22,191,3,39,248,22,92,23,196,2,28, 28,248,22,142,7,248,22,80,23,195,2,10,249,22,152,9,64,114,111,111,116, -248,22,80,23,196,2,28,27,248,22,104,194,28,248,22,184,14,23,194,2,10, +248,22,163,17,23,196,2,28,27,248,22,104,194,28,248,22,184,14,23,194,2, +10,28,248,22,142,7,23,194,2,28,248,22,142,15,23,194,2,10,248,22,143, +15,23,194,1,11,27,248,22,87,248,22,106,195,28,192,192,248,22,186,15,248, +22,113,195,11,11,11,11,250,22,158,2,196,197,249,22,79,197,200,28,28,248, +22,87,248,22,106,23,197,2,10,249,22,177,15,248,22,113,23,198,2,247,22, +160,8,27,248,22,147,15,249,22,145,15,248,22,104,23,200,2,23,198,1,28, +248,22,64,248,22,80,23,198,2,86,94,23,196,1,86,94,28,250,22,160,2, +196,11,11,12,250,22,158,2,196,11,9,249,22,164,2,195,88,163,8,36,38, +50,11,9,224,3,2,33,94,27,248,22,67,248,22,163,17,23,199,1,250,22, +158,2,23,198,2,23,196,2,249,22,79,248,22,131,2,23,200,1,250,22,160, +2,23,203,1,23,201,1,9,12,250,22,158,2,195,196,248,22,94,198,20,13, +159,80,159,37,58,37,88,163,36,37,54,8,240,0,144,0,0,9,225,1,0, +2,33,88,27,250,22,155,15,28,23,197,2,80,159,41,48,38,80,159,41,51, +38,11,32,0,88,163,8,36,36,41,11,9,222,33,89,28,249,22,129,4,23, +195,2,28,23,196,2,80,158,40,50,80,158,40,56,20,13,159,80,159,38,58, +37,20,20,94,88,163,36,37,55,8,240,0,240,24,0,9,226,2,1,3,0, +33,90,23,196,1,20,13,159,80,159,38,53,37,26,29,80,159,8,31,54,37, +249,22,33,11,80,159,8,33,53,37,22,154,14,10,22,155,14,10,22,156,14, +10,22,159,14,10,22,158,14,10,22,160,14,10,22,157,14,10,22,161,14,10, +22,162,14,10,22,163,14,10,22,164,14,10,22,165,14,10,22,166,14,11,22, +152,14,11,27,249,22,182,5,28,196,80,159,41,48,38,80,159,41,51,38,66, +98,105,110,97,114,121,27,250,22,46,22,37,88,163,8,36,36,44,11,9,223, +4,33,91,20,20,94,88,163,36,36,43,11,9,223,4,33,92,23,197,1,86, +94,28,28,248,22,88,23,194,2,249,22,4,32,0,88,163,8,36,37,45,11, +9,222,33,93,23,195,2,11,12,248,22,185,9,6,18,18,105,108,108,45,102, +111,114,109,101,100,32,99,111,110,116,101,110,116,27,247,22,140,2,27,90,159, +39,11,89,161,39,36,11,248,22,141,15,28,201,80,159,46,48,38,80,159,46, +51,38,192,86,96,249,22,3,20,20,94,88,163,8,36,37,54,11,9,224,2, +3,33,95,23,195,1,23,197,1,249,22,164,2,195,88,163,8,36,38,48,11, +9,223,3,33,96,28,197,86,94,20,18,159,11,80,158,42,49,193,20,18,159, +11,80,158,42,50,196,86,94,20,18,159,11,80,158,42,55,193,20,18,159,11, +80,158,42,56,196,193,28,193,80,158,38,49,80,158,38,55,248,22,9,88,163, +8,32,37,8,40,8,240,0,240,94,0,9,224,1,2,33,97,0,7,35,114, +120,34,47,43,34,28,248,22,142,7,23,195,2,27,249,22,175,15,2,99,196, +28,192,28,249,22,191,3,248,22,103,195,248,22,181,3,248,22,145,7,198,249, +22,7,250,22,164,7,199,36,248,22,103,198,197,249,22,7,250,22,164,7,199, +36,248,22,103,198,249,22,79,249,22,164,7,200,248,22,105,199,199,249,22,7, +196,197,90,159,39,11,89,161,39,36,11,248,22,141,15,23,198,1,86,94,23, +195,1,28,249,22,152,9,23,195,2,2,40,249,22,7,195,199,27,249,22,79, +23,197,1,23,201,1,28,248,22,142,7,23,195,2,27,249,22,175,15,2,99, +196,28,192,28,249,22,191,3,248,22,103,195,248,22,181,3,248,22,145,7,198, +249,22,7,250,22,164,7,199,36,248,22,103,198,195,249,22,7,250,22,164,7, +199,36,248,22,103,198,249,22,79,249,22,164,7,200,248,22,105,199,197,249,22, +7,196,195,90,159,39,11,89,161,39,36,11,248,22,141,15,23,198,1,28,249, +22,152,9,194,2,40,249,22,7,195,197,249,80,159,45,59,39,194,249,22,79, +197,199,32,101,88,163,36,43,8,27,11,65,99,108,111,111,112,222,33,110,32, +102,88,163,8,36,37,47,11,2,41,222,33,105,32,103,88,163,36,37,43,11, +69,116,111,45,115,116,114,105,110,103,222,33,104,28,248,22,184,14,193,248,22, +188,14,193,192,28,248,22,87,248,22,81,23,195,2,248,22,89,248,2,103,248, +22,163,17,23,196,1,250,22,90,248,2,103,248,22,163,17,23,198,2,2,50, +248,2,102,248,22,164,17,23,198,1,249,22,190,7,2,51,194,32,107,88,163, +36,38,48,11,66,102,105,108,116,101,114,222,33,108,28,248,22,87,23,195,2, +9,28,248,23,194,2,248,22,80,23,196,2,249,22,79,248,22,163,17,23,197, +2,249,2,107,23,197,1,248,22,164,17,23,199,1,249,2,107,194,248,22,164, +17,196,249,22,190,7,2,51,248,22,134,2,23,196,1,28,248,22,87,23,199, +2,86,94,23,198,1,28,23,199,2,28,196,249,22,138,15,200,198,198,27,28, +248,22,87,23,197,2,2,49,249,22,1,22,165,7,248,2,102,23,199,2,248, +23,198,1,251,22,190,7,6,70,70,99,111,108,108,101,99,116,105,111,110,32, +110,111,116,32,102,111,117,110,100,10,32,32,99,111,108,108,101,99,116,105,111, +110,58,32,126,115,10,32,32,105,110,32,99,111,108,108,101,99,116,105,111,110, +32,100,105,114,101,99,116,111,114,105,101,115,58,126,97,126,97,28,248,22,87, +23,202,1,248,2,103,23,201,1,250,22,165,7,248,2,103,23,204,1,2,50, +23,201,2,249,22,1,22,165,7,249,22,2,32,0,88,163,8,36,37,44,11, +9,222,33,106,249,2,107,22,184,14,23,205,2,28,249,22,5,22,133,2,23, +201,2,250,22,190,7,6,49,49,10,32,32,32,115,117,98,45,99,111,108,108, +101,99,116,105,111,110,58,32,126,115,10,32,32,105,110,32,112,97,114,101,110, +116,32,100,105,114,101,99,116,111,114,105,101,115,58,126,97,23,201,1,249,22, +1,22,165,7,249,22,2,32,0,88,163,8,36,37,45,11,9,222,33,109,249, +2,107,22,133,2,23,208,1,86,95,23,199,1,23,198,1,2,49,27,248,22, +80,23,200,2,27,28,248,22,184,14,23,195,2,249,22,138,15,23,196,1,23, +198,2,248,22,134,2,23,195,1,28,28,248,22,184,14,248,22,80,23,202,2, +248,22,133,15,23,194,2,10,27,250,22,1,22,138,15,23,197,1,23,201,2, +28,28,248,22,87,23,199,2,10,248,22,133,15,23,194,2,28,23,200,2,28, +28,248,22,132,15,249,22,138,15,195,202,10,27,28,248,22,184,14,201,248,22, +188,14,201,200,27,248,22,145,7,23,195,2,27,28,249,22,131,4,23,196,2, +40,28,249,22,148,7,6,4,4,46,114,107,116,249,22,164,7,23,199,2,249, +22,183,3,23,200,2,40,249,22,165,7,250,22,164,7,23,200,1,36,249,22, +183,3,23,201,1,40,6,3,3,46,115,115,86,95,23,195,1,23,194,1,11, +11,28,23,193,2,248,22,132,15,249,22,138,15,198,23,196,1,11,28,199,249, +22,138,15,194,201,192,254,2,101,202,203,204,205,206,248,22,81,23,16,28,23, +16,23,16,199,28,199,249,22,138,15,194,201,192,254,2,101,202,203,204,205,206, +248,22,81,23,16,23,16,254,2,101,201,202,203,204,205,248,22,81,23,15,23, +15,90,159,38,11,89,161,38,36,11,249,80,159,40,59,39,23,199,1,23,200, +1,27,248,22,67,28,248,22,184,14,195,248,22,188,14,195,194,27,247,22,166, +15,27,250,22,93,28,23,197,2,28,247,22,165,15,27,248,80,159,46,57,39, +10,27,250,22,160,2,23,197,2,23,203,2,11,28,23,193,2,192,86,94,23, +193,1,250,22,160,2,23,197,1,11,9,9,9,28,23,197,1,28,80,159,44, +51,38,27,248,80,159,46,57,39,11,27,250,22,160,2,23,197,2,23,203,1, +11,28,23,193,2,192,86,94,23,193,1,250,22,160,2,23,197,1,11,9,86, +94,23,198,1,9,9,247,22,162,15,254,2,101,199,202,203,205,23,16,199,11, +86,95,28,28,248,22,185,14,23,194,2,10,28,248,22,184,14,23,194,2,10, 28,248,22,142,7,23,194,2,28,248,22,142,15,23,194,2,10,248,22,143,15, -23,194,1,11,27,248,22,87,248,22,106,195,28,192,192,248,22,186,15,248,22, -113,195,11,11,11,11,250,22,158,2,196,197,249,22,79,197,200,28,28,248,22, -87,248,22,106,23,197,2,10,249,22,177,15,248,22,113,23,198,2,247,22,160, -8,27,248,22,147,15,249,22,145,15,248,22,104,23,200,2,23,198,1,28,248, -22,64,248,22,80,23,198,2,86,94,23,196,1,86,94,28,250,22,160,2,196, -11,11,12,250,22,158,2,196,11,9,249,22,164,2,195,88,163,8,36,38,50, -11,9,224,3,2,33,94,27,248,22,67,248,22,80,23,199,1,250,22,158,2, -23,198,2,23,196,2,249,22,79,248,22,131,2,23,200,1,250,22,160,2,23, -203,1,23,201,1,9,12,250,22,158,2,195,196,248,22,94,198,20,13,159,80, -159,37,58,37,88,163,36,37,54,8,240,0,144,0,0,9,225,1,0,2,33, -88,27,250,22,155,15,28,23,197,2,80,159,41,48,38,80,159,41,51,38,11, -32,0,88,163,8,36,36,41,11,9,222,33,89,28,249,22,129,4,23,195,2, -28,23,196,2,80,158,40,50,80,158,40,56,20,13,159,80,159,38,58,37,20, -20,94,88,163,36,37,55,8,240,0,240,24,0,9,226,2,1,3,0,33,90, -23,196,1,20,13,159,80,159,38,53,37,26,29,80,159,8,31,54,37,249,22, -33,11,80,159,8,33,53,37,22,154,14,10,22,155,14,10,22,156,14,10,22, -159,14,10,22,158,14,10,22,160,14,10,22,157,14,10,22,161,14,10,22,162, -14,10,22,163,14,10,22,164,14,10,22,165,14,10,22,166,14,11,22,152,14, -11,27,249,22,182,5,28,196,80,159,41,48,38,80,159,41,51,38,66,98,105, -110,97,114,121,27,250,22,46,22,37,88,163,8,36,36,44,11,9,223,4,33, -91,20,20,94,88,163,36,36,43,11,9,223,4,33,92,23,197,1,86,94,28, -28,248,22,88,23,194,2,249,22,4,32,0,88,163,8,36,37,45,11,9,222, -33,93,23,195,2,11,12,248,22,185,9,6,18,18,105,108,108,45,102,111,114, -109,101,100,32,99,111,110,116,101,110,116,27,247,22,140,2,27,90,159,39,11, -89,161,39,36,11,248,22,141,15,28,201,80,159,46,48,38,80,159,46,51,38, -192,86,96,249,22,3,20,20,94,88,163,8,36,37,54,11,9,224,2,3,33, -95,23,195,1,23,197,1,249,22,164,2,195,88,163,8,36,38,48,11,9,223, -3,33,96,28,197,86,94,20,18,159,11,80,158,42,49,193,20,18,159,11,80, -158,42,50,196,86,94,20,18,159,11,80,158,42,55,193,20,18,159,11,80,158, -42,56,196,193,28,193,80,158,38,49,80,158,38,55,248,22,8,88,163,8,32, -37,8,40,8,240,0,240,94,0,9,224,1,2,33,97,0,7,35,114,120,34, -47,43,34,28,248,22,142,7,23,195,2,27,249,22,175,15,2,99,196,28,192, -28,249,22,191,3,248,22,103,195,248,22,181,3,248,22,145,7,198,249,22,7, -250,22,164,7,199,36,248,22,103,198,197,249,22,7,250,22,164,7,199,36,248, -22,103,198,249,22,79,249,22,164,7,200,248,22,105,199,199,249,22,7,196,197, -90,159,39,11,89,161,39,36,11,248,22,141,15,23,198,1,86,94,23,195,1, -28,249,22,152,9,23,195,2,2,40,249,22,7,195,199,27,249,22,79,23,197, -1,23,201,1,28,248,22,142,7,23,195,2,27,249,22,175,15,2,99,196,28, -192,28,249,22,191,3,248,22,103,195,248,22,181,3,248,22,145,7,198,249,22, -7,250,22,164,7,199,36,248,22,103,198,195,249,22,7,250,22,164,7,199,36, -248,22,103,198,249,22,79,249,22,164,7,200,248,22,105,199,197,249,22,7,196, -195,90,159,39,11,89,161,39,36,11,248,22,141,15,23,198,1,28,249,22,152, -9,194,2,40,249,22,7,195,197,249,80,159,45,59,39,194,249,22,79,197,199, -32,101,88,163,36,43,8,27,11,65,99,108,111,111,112,222,33,110,32,102,88, -163,8,36,37,47,11,2,41,222,33,105,32,103,88,163,36,37,43,11,69,116, -111,45,115,116,114,105,110,103,222,33,104,28,248,22,184,14,193,248,22,188,14, -193,192,28,248,22,87,248,22,81,23,195,2,248,22,89,248,2,103,248,22,80, -23,196,1,250,22,90,248,2,103,248,22,80,23,198,2,2,50,248,2,102,248, -22,81,23,198,1,249,22,190,7,2,51,194,32,107,88,163,36,38,48,11,66, -102,105,108,116,101,114,222,33,108,28,248,22,87,23,195,2,9,28,248,23,194, -2,248,22,80,23,196,2,249,22,79,248,22,80,23,197,2,249,2,107,23,197, -1,248,22,81,23,199,1,249,2,107,194,248,22,81,196,249,22,190,7,2,51, -248,22,134,2,23,196,1,28,248,22,87,23,199,2,86,94,23,198,1,28,23, -199,2,28,196,249,22,138,15,200,198,198,27,28,248,22,87,23,197,2,2,49, -249,22,1,22,165,7,248,2,102,23,199,2,248,23,198,1,251,22,190,7,6, -70,70,99,111,108,108,101,99,116,105,111,110,32,110,111,116,32,102,111,117,110, -100,10,32,32,99,111,108,108,101,99,116,105,111,110,58,32,126,115,10,32,32, -105,110,32,99,111,108,108,101,99,116,105,111,110,32,100,105,114,101,99,116,111, -114,105,101,115,58,126,97,126,97,28,248,22,87,23,202,1,248,2,103,23,201, -1,250,22,165,7,248,2,103,23,204,1,2,50,23,201,2,249,22,1,22,165, -7,249,22,2,32,0,88,163,8,36,37,44,11,9,222,33,106,249,2,107,22, -184,14,23,205,2,28,249,22,5,22,133,2,23,201,2,250,22,190,7,6,49, -49,10,32,32,32,115,117,98,45,99,111,108,108,101,99,116,105,111,110,58,32, -126,115,10,32,32,105,110,32,112,97,114,101,110,116,32,100,105,114,101,99,116, -111,114,105,101,115,58,126,97,23,201,1,249,22,1,22,165,7,249,22,2,32, -0,88,163,8,36,37,45,11,9,222,33,109,249,2,107,22,133,2,23,208,1, -86,95,23,199,1,23,198,1,2,49,27,248,22,80,23,200,2,27,28,248,22, -184,14,23,195,2,249,22,138,15,23,196,1,23,198,2,248,22,134,2,23,195, -1,28,28,248,22,184,14,248,22,80,23,202,2,248,22,133,15,23,194,2,10, -27,250,22,1,22,138,15,23,197,1,23,201,2,28,28,248,22,87,23,199,2, -10,248,22,133,15,23,194,2,28,23,200,2,28,28,248,22,132,15,249,22,138, -15,195,202,10,27,28,248,22,184,14,201,248,22,188,14,201,200,27,248,22,145, -7,23,195,2,27,28,249,22,131,4,23,196,2,40,28,249,22,148,7,6,4, -4,46,114,107,116,249,22,164,7,23,199,2,249,22,183,3,23,200,2,40,249, -22,165,7,250,22,164,7,23,200,1,36,249,22,183,3,23,201,1,40,6,3, -3,46,115,115,86,95,23,195,1,23,194,1,11,11,28,23,193,2,248,22,132, -15,249,22,138,15,198,23,196,1,11,28,199,249,22,138,15,194,201,192,254,2, -101,202,203,204,205,206,248,22,81,23,16,28,23,16,23,16,199,28,199,249,22, -138,15,194,201,192,254,2,101,202,203,204,205,206,248,22,81,23,16,23,16,254, -2,101,201,202,203,204,205,248,22,81,23,15,23,15,90,159,38,11,89,161,38, -36,11,249,80,159,40,59,39,23,199,1,23,200,1,27,248,22,67,28,248,22, -184,14,195,248,22,188,14,195,194,27,247,22,166,15,27,250,22,93,28,23,197, -2,28,247,22,165,15,27,248,80,159,46,57,39,10,27,250,22,160,2,23,197, -2,23,203,2,11,28,23,193,2,192,86,94,23,193,1,250,22,160,2,23,197, -1,11,9,9,9,28,23,197,1,28,80,159,44,51,38,27,248,80,159,46,57, -39,11,27,250,22,160,2,23,197,2,23,203,1,11,28,23,193,2,192,86,94, -23,193,1,250,22,160,2,23,197,1,11,9,86,94,23,198,1,9,9,247,22, -162,15,254,2,101,199,202,203,205,23,16,199,11,86,95,28,28,248,22,185,14, -23,194,2,10,28,248,22,184,14,23,194,2,10,28,248,22,142,7,23,194,2, -28,248,22,142,15,23,194,2,10,248,22,143,15,23,194,2,11,12,252,22,189, -9,23,200,2,2,33,36,23,198,2,23,199,2,28,28,248,22,142,7,23,195, -2,10,248,22,131,8,23,195,2,86,94,23,194,1,12,252,22,189,9,23,200, -2,2,52,37,23,198,2,23,199,1,90,159,39,11,89,161,39,36,11,248,22, -141,15,23,197,2,86,94,23,195,1,86,94,28,192,12,250,22,128,10,23,201, -1,2,53,23,199,1,249,22,7,194,195,90,159,38,11,89,161,38,36,11,86, -95,28,28,248,22,185,14,23,196,2,10,28,248,22,184,14,23,196,2,10,28, -248,22,142,7,23,196,2,28,248,22,142,15,23,196,2,10,248,22,143,15,23, -196,2,11,12,252,22,189,9,2,27,2,33,36,23,200,2,23,201,2,28,28, -248,22,142,7,23,197,2,10,248,22,131,8,23,197,2,12,252,22,189,9,2, -27,2,52,37,23,200,2,23,201,2,90,159,39,11,89,161,39,36,11,248,22, -141,15,23,199,2,86,94,23,195,1,86,94,28,192,12,250,22,128,10,2,27, -2,53,23,201,2,249,22,7,194,195,27,249,22,130,15,250,22,184,15,0,20, -35,114,120,35,34,40,63,58,91,46,93,91,94,46,93,42,124,41,36,34,248, -22,190,14,23,201,1,28,248,22,142,7,23,203,2,249,22,157,8,23,204,1, -8,63,23,202,1,28,248,22,185,14,23,199,2,248,22,186,14,23,199,1,86, -94,23,198,1,247,22,187,14,28,248,22,184,14,194,249,22,138,15,195,194,192, -90,159,38,11,89,161,38,36,11,86,95,28,28,248,22,185,14,23,196,2,10, -28,248,22,184,14,23,196,2,10,28,248,22,142,7,23,196,2,28,248,22,142, -15,23,196,2,10,248,22,143,15,23,196,2,11,12,252,22,189,9,2,28,2, -33,36,23,200,2,23,201,2,28,28,248,22,142,7,23,197,2,10,248,22,131, -8,23,197,2,12,252,22,189,9,2,28,2,52,37,23,200,2,23,201,2,90, -159,39,11,89,161,39,36,11,248,22,141,15,23,199,2,86,94,23,195,1,86, -94,28,192,12,250,22,128,10,2,28,2,53,23,201,2,249,22,7,194,195,27, -249,22,130,15,249,22,143,8,250,22,185,15,0,9,35,114,120,35,34,91,46, -93,34,248,22,190,14,23,203,1,6,1,1,95,28,248,22,142,7,23,202,2, -249,22,157,8,23,203,1,8,63,23,201,1,28,248,22,185,14,23,199,2,248, -22,186,14,23,199,1,86,94,23,198,1,247,22,187,14,28,248,22,184,14,194, -249,22,138,15,195,194,192,249,247,22,171,5,194,11,249,247,22,171,5,194,11, +23,194,2,11,12,252,22,189,9,23,200,2,2,33,36,23,198,2,23,199,2, +28,28,248,22,142,7,23,195,2,10,248,22,131,8,23,195,2,86,94,23,194, +1,12,252,22,189,9,23,200,2,2,52,37,23,198,2,23,199,1,90,159,39, +11,89,161,39,36,11,248,22,141,15,23,197,2,86,94,23,195,1,86,94,28, +192,12,250,22,128,10,23,201,1,2,53,23,199,1,249,22,7,194,195,90,159, +38,11,89,161,38,36,11,86,95,28,28,248,22,185,14,23,196,2,10,28,248, +22,184,14,23,196,2,10,28,248,22,142,7,23,196,2,28,248,22,142,15,23, +196,2,10,248,22,143,15,23,196,2,11,12,252,22,189,9,2,27,2,33,36, +23,200,2,23,201,2,28,28,248,22,142,7,23,197,2,10,248,22,131,8,23, +197,2,12,252,22,189,9,2,27,2,52,37,23,200,2,23,201,2,90,159,39, +11,89,161,39,36,11,248,22,141,15,23,199,2,86,94,23,195,1,86,94,28, +192,12,250,22,128,10,2,27,2,53,23,201,2,249,22,7,194,195,27,249,22, +130,15,250,22,184,15,0,20,35,114,120,35,34,40,63,58,91,46,93,91,94, +46,93,42,124,41,36,34,248,22,190,14,23,201,1,28,248,22,142,7,23,203, +2,249,22,157,8,23,204,1,8,63,23,202,1,28,248,22,185,14,23,199,2, +248,22,186,14,23,199,1,86,94,23,198,1,247,22,187,14,28,248,22,184,14, +194,249,22,138,15,195,194,192,90,159,38,11,89,161,38,36,11,86,95,28,28, +248,22,185,14,23,196,2,10,28,248,22,184,14,23,196,2,10,28,248,22,142, +7,23,196,2,28,248,22,142,15,23,196,2,10,248,22,143,15,23,196,2,11, +12,252,22,189,9,2,28,2,33,36,23,200,2,23,201,2,28,28,248,22,142, +7,23,197,2,10,248,22,131,8,23,197,2,12,252,22,189,9,2,28,2,52, +37,23,200,2,23,201,2,90,159,39,11,89,161,39,36,11,248,22,141,15,23, +199,2,86,94,23,195,1,86,94,28,192,12,250,22,128,10,2,28,2,53,23, +201,2,249,22,7,194,195,27,249,22,130,15,249,22,143,8,250,22,185,15,0, +9,35,114,120,35,34,91,46,93,34,248,22,190,14,23,203,1,6,1,1,95, +28,248,22,142,7,23,202,2,249,22,157,8,23,203,1,8,63,23,201,1,28, +248,22,185,14,23,199,2,248,22,186,14,23,199,1,86,94,23,198,1,247,22, +187,14,28,248,22,184,14,194,249,22,138,15,195,194,192,249,247,22,171,5,194, +11,249,247,22,171,5,194,11,28,248,22,87,23,195,2,9,27,248,22,80,23, +196,2,27,28,248,22,144,15,23,195,2,23,194,1,28,248,22,143,15,23,195, +2,249,22,145,15,23,196,1,250,80,159,43,40,39,248,22,160,15,2,46,11, +10,250,80,159,41,40,39,248,22,160,15,2,46,23,197,1,10,28,23,193,2, +249,22,79,248,22,147,15,249,22,145,15,23,198,1,247,22,161,15,248,80,159, +41,8,30,39,248,22,81,23,200,1,248,80,159,39,8,30,39,248,22,81,197, 28,248,22,87,23,195,2,9,27,248,22,80,23,196,2,27,28,248,22,144,15, 23,195,2,23,194,1,28,248,22,143,15,23,195,2,249,22,145,15,23,196,1, 250,80,159,43,40,39,248,22,160,15,2,46,11,10,250,80,159,41,40,39,248, 22,160,15,2,46,23,197,1,10,28,23,193,2,249,22,79,248,22,147,15,249, -22,145,15,23,198,1,247,22,161,15,248,80,159,41,8,30,39,248,22,81,23, -200,1,248,80,159,39,8,30,39,248,22,81,197,28,248,22,87,23,195,2,9, +22,145,15,23,198,1,247,22,161,15,248,80,159,41,8,31,39,248,22,81,23, +200,1,248,80,159,39,8,31,39,248,22,81,197,28,248,22,87,23,195,2,9, 27,248,22,80,23,196,2,27,28,248,22,144,15,23,195,2,23,194,1,28,248, 22,143,15,23,195,2,249,22,145,15,23,196,1,250,80,159,43,40,39,248,22, 160,15,2,46,11,10,250,80,159,41,40,39,248,22,160,15,2,46,23,197,1, 10,28,23,193,2,249,22,79,248,22,147,15,249,22,145,15,23,198,1,247,22, -161,15,248,80,159,41,8,31,39,248,22,81,23,200,1,248,80,159,39,8,31, -39,248,22,81,197,28,248,22,87,23,195,2,9,27,248,22,80,23,196,2,27, -28,248,22,144,15,23,195,2,23,194,1,28,248,22,143,15,23,195,2,249,22, -145,15,23,196,1,250,80,159,43,40,39,248,22,160,15,2,46,11,10,250,80, -159,41,40,39,248,22,160,15,2,46,23,197,1,10,28,23,193,2,249,22,79, -248,22,147,15,249,22,145,15,23,198,1,247,22,161,15,27,248,22,81,23,200, -1,28,248,22,87,23,194,2,9,27,248,22,80,23,195,2,27,28,248,22,144, -15,23,195,2,23,194,1,28,248,22,143,15,23,195,2,249,22,145,15,23,196, -1,250,80,159,48,40,39,248,22,160,15,2,46,11,10,250,80,159,46,40,39, -248,22,160,15,2,46,23,197,1,10,28,23,193,2,249,22,79,248,22,147,15, -249,22,145,15,23,198,1,247,22,161,15,248,80,159,46,8,32,39,248,22,81, -23,199,1,86,94,23,193,1,248,80,159,44,8,32,39,248,22,81,23,197,1, -86,94,23,193,1,27,248,22,81,23,198,1,28,248,22,87,23,194,2,9,27, -248,22,80,23,195,2,27,28,248,22,144,15,23,195,2,23,194,1,28,248,22, -143,15,23,195,2,249,22,145,15,23,196,1,250,80,159,46,40,39,248,22,160, -15,2,46,11,10,250,80,159,44,40,39,248,22,160,15,2,46,23,197,1,10, -28,23,193,2,249,22,79,248,22,147,15,249,22,145,15,23,198,1,247,22,161, -15,248,80,159,44,8,32,39,248,22,81,23,199,1,248,80,159,42,8,32,39, -248,22,81,196,27,247,22,165,15,249,80,159,39,41,38,28,23,195,2,27,248, -22,162,8,2,54,28,192,192,2,49,2,49,27,28,23,196,1,250,22,138,15, -248,22,160,15,2,55,247,22,160,8,2,56,11,27,248,80,159,42,8,30,39, -250,22,93,9,248,22,89,248,22,160,15,2,45,9,28,193,249,22,79,195,194, -192,27,247,22,165,15,249,80,159,39,41,38,28,23,195,2,27,248,22,162,8, -2,54,28,192,192,2,49,2,49,27,28,23,196,1,250,22,138,15,248,22,160, -15,2,55,247,22,160,8,2,56,11,27,248,80,159,42,8,31,39,250,22,93, -23,203,1,248,22,89,248,22,160,15,2,45,9,28,193,249,22,79,195,194,192, -27,247,22,165,15,249,80,159,39,41,38,28,23,195,2,27,248,22,162,8,2, -54,28,192,192,2,49,2,49,27,28,23,196,1,250,22,138,15,248,22,160,15, -2,55,247,22,160,8,2,56,11,27,248,80,159,42,8,32,39,250,22,93,23, -203,1,248,22,89,248,22,160,15,2,45,23,204,1,28,193,249,22,79,195,194, -192,27,20,13,159,80,159,37,53,37,254,80,159,44,54,37,249,22,33,11,80, -159,46,53,37,22,158,14,10,22,165,14,10,22,166,14,10,248,22,139,6,23, -196,2,28,248,22,137,7,23,194,2,12,86,94,248,22,160,9,23,194,1,27, -20,13,159,80,159,38,53,37,254,80,159,45,54,37,249,22,33,11,80,159,47, -53,37,22,158,14,10,22,165,14,10,22,166,14,10,248,22,139,6,23,197,2, -28,248,22,137,7,23,194,2,12,86,94,248,22,160,9,23,194,1,27,20,13, -159,80,159,39,53,37,254,80,159,46,54,37,249,22,33,11,80,159,48,53,37, -22,158,14,10,22,165,14,10,22,166,14,10,248,22,139,6,23,198,2,28,248, -22,137,7,23,194,2,12,86,94,248,22,160,9,23,194,1,248,80,159,40,8, -33,39,197,86,94,249,22,130,7,247,22,167,5,195,248,22,154,6,249,22,135, -4,36,249,22,183,3,197,198,27,28,23,197,2,86,95,23,196,1,23,195,1, -23,197,1,86,94,23,197,1,27,248,22,160,15,2,46,27,250,80,159,42,40, -39,23,197,1,11,11,27,248,22,138,4,23,199,1,27,28,23,194,2,23,194, -1,86,94,23,194,1,36,27,248,22,138,4,23,202,1,27,28,23,194,2,23, -194,1,86,94,23,194,1,36,249,22,134,6,23,199,1,20,20,95,88,163,8, -36,36,48,11,9,224,4,2,33,124,23,195,1,23,197,1,27,248,22,183,5, -23,195,1,248,80,159,39,8,33,39,193,159,36,20,113,159,36,16,1,11,16, -0,20,26,144,9,2,1,2,1,29,11,11,11,9,9,11,11,11,10,43,80, -158,36,36,20,113,159,40,16,30,2,2,2,3,2,4,2,5,2,6,2,7, -2,8,2,9,2,10,2,11,2,12,2,13,2,14,2,15,2,16,2,17,30, -2,20,76,102,105,110,100,45,108,105,110,107,115,45,112,97,116,104,33,11,4, -30,2,21,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110, -45,107,101,121,11,6,30,2,21,1,23,101,120,116,101,110,100,45,112,97,114, -97,109,101,116,101,114,105,122,97,116,105,111,110,11,3,2,22,2,23,2,24, -30,2,20,1,21,101,120,99,101,112,116,105,111,110,45,104,97,110,100,108,101, -114,45,107,101,121,11,2,2,25,2,26,2,27,2,28,2,29,2,30,2,31, -16,0,37,39,36,16,0,36,16,13,2,9,2,10,2,8,2,3,2,26,2, -24,2,22,2,17,2,23,2,25,2,15,2,14,2,16,49,11,11,11,16,13, -2,13,2,11,2,31,2,12,2,6,2,30,2,29,2,4,2,28,2,7,2, -27,2,2,2,5,16,13,11,11,11,11,11,11,11,11,11,11,11,11,11,16, -13,2,13,2,11,2,31,2,12,2,6,2,30,2,29,2,4,2,28,2,7, -2,27,2,2,2,5,49,49,37,12,11,11,16,0,16,0,16,0,36,36,11, -12,11,11,16,0,16,0,16,0,36,36,16,30,20,15,16,2,32,0,88,163, -36,37,45,11,2,2,222,33,57,80,159,36,36,37,20,15,16,2,249,22,144, -7,7,92,7,92,80,159,36,37,37,20,15,16,2,88,163,36,37,54,38,2, -4,223,0,33,62,80,159,36,38,37,20,15,16,2,88,163,36,38,58,38,2, -5,223,0,33,64,80,159,36,39,37,20,15,16,2,20,25,96,2,6,88,163, -8,36,39,8,25,8,32,9,223,0,33,71,88,163,36,38,47,52,9,223,0, -33,72,88,163,36,37,46,52,9,223,0,33,73,80,159,36,40,37,20,15,16, -2,27,248,22,169,15,248,22,156,8,27,28,249,22,152,9,247,22,164,8,2, -34,6,1,1,59,6,1,1,58,250,22,190,7,6,14,14,40,91,94,126,97, -93,42,41,126,97,40,46,42,41,23,196,2,23,196,1,88,163,8,36,38,48, -11,2,7,223,0,33,77,80,159,36,41,37,20,15,16,2,32,0,88,163,8, -36,38,47,11,2,8,222,33,78,80,159,36,42,37,20,15,16,2,32,0,88, -163,8,36,39,48,11,2,9,222,33,80,80,159,36,43,37,20,15,16,2,32, -0,88,163,8,36,38,46,11,2,10,222,33,81,80,159,36,44,37,20,15,16, -2,88,163,45,39,49,8,128,16,2,11,223,0,33,83,80,159,36,45,37,20, -15,16,2,88,163,45,40,50,8,128,16,2,13,223,0,33,85,80,159,36,47, -37,20,15,16,2,248,22,160,15,70,108,105,110,107,115,45,102,105,108,101,80, -159,36,48,37,20,15,16,2,247,22,140,2,80,158,36,49,20,15,16,2,2, -86,80,158,36,50,20,15,16,2,248,80,159,37,52,37,88,163,36,36,49,8, -240,16,0,6,0,9,223,1,33,87,80,159,36,51,37,20,15,16,2,247,22, -140,2,80,158,36,55,20,15,16,2,2,86,80,158,36,56,20,15,16,2,88, -163,36,37,44,8,240,0,240,94,0,2,24,223,0,33,98,80,159,36,57,37, -20,15,16,2,88,163,36,38,56,8,240,0,0,128,0,2,25,223,0,33,100, -80,159,36,59,37,20,15,16,2,88,163,36,40,59,8,240,0,128,160,0,2, -12,223,0,33,111,80,159,36,46,37,20,15,16,2,32,0,88,163,36,39,50, -11,2,26,222,33,112,80,159,36,8,24,37,20,15,16,2,32,0,88,163,36, -38,53,11,2,27,222,33,113,80,159,36,8,25,37,20,15,16,2,32,0,88, -163,36,38,54,11,2,28,222,33,114,80,159,36,8,26,37,20,15,16,2,20, -27,158,32,0,88,163,36,37,44,11,2,29,222,33,115,32,0,88,163,36,37, -44,11,2,29,222,33,116,80,159,36,8,27,37,20,15,16,2,88,163,8,36, -37,51,16,2,52,8,240,0,64,0,0,2,41,223,0,33,117,80,159,36,8, -30,39,20,15,16,2,88,163,8,36,37,51,16,2,52,8,240,0,128,0,0, -2,41,223,0,33,118,80,159,36,8,31,39,20,15,16,2,88,163,8,36,37, -56,16,4,52,36,37,36,2,41,223,0,33,119,80,159,36,8,32,39,20,15, -16,2,20,25,96,2,30,88,163,36,36,53,16,2,8,32,8,240,0,64,0, -0,9,223,0,33,120,88,163,36,37,54,16,2,8,32,8,240,0,128,0,0, -9,223,0,33,121,88,163,36,38,55,16,4,8,32,36,37,36,9,223,0,33, -122,80,159,36,8,28,37,20,15,16,2,88,163,8,36,37,55,16,4,36,42, -38,36,2,41,223,0,33,123,80,159,36,8,33,39,20,15,16,2,88,163,8, -36,39,54,16,4,52,36,38,36,2,31,223,0,33,125,80,159,36,8,29,37, -95,29,94,2,18,68,35,37,107,101,114,110,101,108,11,29,94,2,18,69,35, -37,109,105,110,45,115,116,120,11,2,20,9,9,9,36,0}; - EVAL_ONE_SIZED_STR((char *)expr, 10011); +161,15,27,248,22,81,23,200,1,28,248,22,87,23,194,2,9,27,248,22,80, +23,195,2,27,28,248,22,144,15,23,195,2,23,194,1,28,248,22,143,15,23, +195,2,249,22,145,15,23,196,1,250,80,159,48,40,39,248,22,160,15,2,46, +11,10,250,80,159,46,40,39,248,22,160,15,2,46,23,197,1,10,28,23,193, +2,249,22,79,248,22,147,15,249,22,145,15,23,198,1,247,22,161,15,248,80, +159,46,8,32,39,248,22,81,23,199,1,86,94,23,193,1,248,80,159,44,8, +32,39,248,22,81,23,197,1,86,94,23,193,1,27,248,22,81,23,198,1,28, +248,22,87,23,194,2,9,27,248,22,80,23,195,2,27,28,248,22,144,15,23, +195,2,23,194,1,28,248,22,143,15,23,195,2,249,22,145,15,23,196,1,250, +80,159,46,40,39,248,22,160,15,2,46,11,10,250,80,159,44,40,39,248,22, +160,15,2,46,23,197,1,10,28,23,193,2,249,22,79,248,22,147,15,249,22, +145,15,23,198,1,247,22,161,15,248,80,159,44,8,32,39,248,22,81,23,199, +1,248,80,159,42,8,32,39,248,22,81,196,27,247,22,165,15,249,80,159,39, +41,38,28,23,195,2,27,248,22,162,8,2,54,28,192,192,2,49,2,49,27, +28,23,196,1,250,22,138,15,248,22,160,15,2,55,247,22,160,8,2,56,11, +27,248,80,159,42,8,30,39,250,22,93,9,248,22,89,248,22,160,15,2,45, +9,28,193,249,22,79,195,194,192,27,247,22,165,15,249,80,159,39,41,38,28, +23,195,2,27,248,22,162,8,2,54,28,192,192,2,49,2,49,27,28,23,196, +1,250,22,138,15,248,22,160,15,2,55,247,22,160,8,2,56,11,27,248,80, +159,42,8,31,39,250,22,93,23,203,1,248,22,89,248,22,160,15,2,45,9, +28,193,249,22,79,195,194,192,27,247,22,165,15,249,80,159,39,41,38,28,23, +195,2,27,248,22,162,8,2,54,28,192,192,2,49,2,49,27,28,23,196,1, +250,22,138,15,248,22,160,15,2,55,247,22,160,8,2,56,11,27,248,80,159, +42,8,32,39,250,22,93,23,203,1,248,22,89,248,22,160,15,2,45,23,204, +1,28,193,249,22,79,195,194,192,27,20,13,159,80,159,37,53,37,254,80,159, +44,54,37,249,22,33,11,80,159,46,53,37,22,158,14,10,22,165,14,10,22, +166,14,10,248,22,139,6,23,196,2,28,248,22,137,7,23,194,2,12,86,94, +248,22,160,9,23,194,1,27,20,13,159,80,159,38,53,37,254,80,159,45,54, +37,249,22,33,11,80,159,47,53,37,22,158,14,10,22,165,14,10,22,166,14, +10,248,22,139,6,23,197,2,28,248,22,137,7,23,194,2,12,86,94,248,22, +160,9,23,194,1,27,20,13,159,80,159,39,53,37,254,80,159,46,54,37,249, +22,33,11,80,159,48,53,37,22,158,14,10,22,165,14,10,22,166,14,10,248, +22,139,6,23,198,2,28,248,22,137,7,23,194,2,12,86,94,248,22,160,9, +23,194,1,248,80,159,40,8,33,39,197,86,94,249,22,130,7,247,22,167,5, +195,248,22,154,6,249,22,135,4,36,249,22,183,3,197,198,27,28,23,197,2, +86,95,23,196,1,23,195,1,23,197,1,86,94,23,197,1,27,248,22,160,15, +2,46,27,250,80,159,42,40,39,23,197,1,11,11,27,248,22,138,4,23,199, +1,27,28,23,194,2,23,194,1,86,94,23,194,1,36,27,248,22,138,4,23, +202,1,27,28,23,194,2,23,194,1,86,94,23,194,1,36,249,22,134,6,23, +199,1,20,20,95,88,163,8,36,36,48,11,9,224,4,2,33,124,23,195,1, +23,197,1,27,248,22,183,5,23,195,1,248,80,159,39,8,33,39,193,159,36, +20,113,159,36,16,1,11,16,0,20,26,144,9,2,1,2,1,29,11,11,11, +9,9,11,11,11,10,43,80,158,36,36,20,113,159,40,16,30,2,2,2,3, +2,4,2,5,2,6,2,7,2,8,2,9,2,10,2,11,2,12,2,13,2, +14,2,15,2,16,2,17,30,2,20,76,102,105,110,100,45,108,105,110,107,115, +45,112,97,116,104,33,11,4,30,2,21,1,20,112,97,114,97,109,101,116,101, +114,105,122,97,116,105,111,110,45,107,101,121,11,6,30,2,21,1,23,101,120, +116,101,110,100,45,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110, +11,3,2,22,2,23,2,24,30,2,20,1,21,101,120,99,101,112,116,105,111, +110,45,104,97,110,100,108,101,114,45,107,101,121,11,2,2,25,2,26,2,27, +2,28,2,29,2,30,2,31,16,0,37,39,36,16,0,36,16,13,2,9,2, +10,2,8,2,3,2,26,2,24,2,22,2,17,2,23,2,25,2,15,2,14, +2,16,49,11,11,11,16,13,2,13,2,11,2,31,2,12,2,6,2,30,2, +29,2,4,2,28,2,7,2,27,2,2,2,5,16,13,11,11,11,11,11,11, +11,11,11,11,11,11,11,16,13,2,13,2,11,2,31,2,12,2,6,2,30, +2,29,2,4,2,28,2,7,2,27,2,2,2,5,49,49,37,12,11,11,16, +0,16,0,16,0,36,36,11,12,11,11,16,0,16,0,16,0,36,36,16,30, +20,15,16,2,32,0,88,163,36,37,45,11,2,2,222,33,57,80,159,36,36, +37,20,15,16,2,249,22,144,7,7,92,7,92,80,159,36,37,37,20,15,16, +2,88,163,36,37,54,38,2,4,223,0,33,62,80,159,36,38,37,20,15,16, +2,88,163,36,38,58,38,2,5,223,0,33,64,80,159,36,39,37,20,15,16, +2,20,25,96,2,6,88,163,8,36,39,8,25,8,32,9,223,0,33,71,88, +163,36,38,47,52,9,223,0,33,72,88,163,36,37,46,52,9,223,0,33,73, +80,159,36,40,37,20,15,16,2,27,248,22,169,15,248,22,156,8,27,28,249, +22,152,9,247,22,164,8,2,34,6,1,1,59,6,1,1,58,250,22,190,7, +6,14,14,40,91,94,126,97,93,42,41,126,97,40,46,42,41,23,196,2,23, +196,1,88,163,8,36,38,48,11,2,7,223,0,33,77,80,159,36,41,37,20, +15,16,2,32,0,88,163,8,36,38,47,11,2,8,222,33,78,80,159,36,42, +37,20,15,16,2,32,0,88,163,8,36,39,48,11,2,9,222,33,80,80,159, +36,43,37,20,15,16,2,32,0,88,163,8,36,38,46,11,2,10,222,33,81, +80,159,36,44,37,20,15,16,2,88,163,45,39,49,8,128,16,2,11,223,0, +33,83,80,159,36,45,37,20,15,16,2,88,163,45,40,50,8,128,16,2,13, +223,0,33,85,80,159,36,47,37,20,15,16,2,248,22,160,15,70,108,105,110, +107,115,45,102,105,108,101,80,159,36,48,37,20,15,16,2,247,22,140,2,80, +158,36,49,20,15,16,2,2,86,80,158,36,50,20,15,16,2,248,80,159,37, +52,37,88,163,36,36,49,8,240,16,0,6,0,9,223,1,33,87,80,159,36, +51,37,20,15,16,2,247,22,140,2,80,158,36,55,20,15,16,2,2,86,80, +158,36,56,20,15,16,2,88,163,36,37,44,8,240,0,240,94,0,2,24,223, +0,33,98,80,159,36,57,37,20,15,16,2,88,163,36,38,56,8,240,0,0, +128,0,2,25,223,0,33,100,80,159,36,59,37,20,15,16,2,88,163,36,40, +59,8,240,0,128,160,0,2,12,223,0,33,111,80,159,36,46,37,20,15,16, +2,32,0,88,163,36,39,50,11,2,26,222,33,112,80,159,36,8,24,37,20, +15,16,2,32,0,88,163,36,38,53,11,2,27,222,33,113,80,159,36,8,25, +37,20,15,16,2,32,0,88,163,36,38,54,11,2,28,222,33,114,80,159,36, +8,26,37,20,15,16,2,20,27,158,32,0,88,163,36,37,44,11,2,29,222, +33,115,32,0,88,163,36,37,44,11,2,29,222,33,116,80,159,36,8,27,37, +20,15,16,2,88,163,8,36,37,51,16,2,52,8,240,0,64,0,0,2,41, +223,0,33,117,80,159,36,8,30,39,20,15,16,2,88,163,8,36,37,51,16, +2,52,8,240,0,128,0,0,2,41,223,0,33,118,80,159,36,8,31,39,20, +15,16,2,88,163,8,36,37,56,16,4,52,36,37,36,2,41,223,0,33,119, +80,159,36,8,32,39,20,15,16,2,20,25,96,2,30,88,163,36,36,53,16, +2,8,32,8,240,0,64,0,0,9,223,0,33,120,88,163,36,37,54,16,2, +8,32,8,240,0,128,0,0,9,223,0,33,121,88,163,36,38,55,16,4,8, +32,36,37,36,9,223,0,33,122,80,159,36,8,28,37,20,15,16,2,88,163, +8,36,37,55,16,4,36,42,38,36,2,41,223,0,33,123,80,159,36,8,33, +39,20,15,16,2,88,163,8,36,39,54,16,4,52,36,38,36,2,31,223,0, +33,125,80,159,36,8,29,37,95,29,94,2,18,68,35,37,107,101,114,110,101, +108,11,29,94,2,18,69,35,37,109,105,110,45,115,116,120,11,2,20,9,9, +9,36,0}; + EVAL_ONE_SIZED_STR((char *)expr, 10019); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,52,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,53,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,12,0,0,0,1,0,0,15,0,40,0, 57,0,75,0,97,0,120,0,140,0,162,0,169,0,176,0,183,0,0,0,179, 1,0,0,74,35,37,112,108,97,99,101,45,115,116,114,117,99,116,1,23,115, @@ -606,17 +608,17 @@ EVAL_ONE_SIZED_STR((char *)expr, 501); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,52,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,53,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,89,0,0,0,1,0,0,7,0,18,0, 45,0,51,0,60,0,67,0,89,0,102,0,128,0,145,0,167,0,175,0,187, 0,202,0,218,0,236,0,0,1,12,1,28,1,51,1,63,1,94,1,101,1, 106,1,111,1,129,1,135,1,140,1,145,1,154,1,159,1,163,1,178,1,185, 1,190,1,194,1,199,1,206,1,217,1,224,1,232,1,42,2,108,2,183,2, -2,3,105,3,126,3,229,3,250,3,88,4,109,4,203,4,224,4,117,12,135, -12,186,12,249,12,12,13,26,13,184,13,197,13,75,14,117,15,199,15,63,16, -120,16,128,16,137,16,160,17,166,17,194,17,207,17,113,18,120,18,174,18,196, -18,216,18,15,19,25,19,39,19,76,19,174,19,176,19,26,20,213,27,10,28, -34,28,58,28,0,0,56,32,0,0,66,35,37,98,111,111,116,70,100,108,108, +2,3,105,3,126,3,229,3,250,3,88,4,109,4,203,4,224,4,122,12,140, +12,191,12,254,12,17,13,31,13,189,13,202,13,89,14,140,15,222,15,87,16, +144,16,152,16,161,16,185,17,191,17,219,17,232,17,141,18,148,18,202,18,224, +18,244,18,43,19,53,19,67,19,104,19,203,19,205,19,55,20,7,28,60,28, +84,28,108,28,0,0,106,32,0,0,66,35,37,98,111,111,116,70,100,108,108, 45,115,117,102,102,105,120,1,25,100,101,102,97,117,108,116,45,108,111,97,100, 47,117,115,101,45,99,111,109,112,105,108,101,100,65,113,117,111,116,101,68,35, 37,112,97,114,97,109,122,29,94,2,4,2,5,11,1,20,112,97,114,97,109, @@ -680,340 +682,342 @@ 97,116,104,45,115,116,114,105,110,103,63,23,197,2,28,28,23,195,2,28,248, 22,64,23,196,2,10,28,248,22,88,23,196,2,28,249,22,129,4,248,22,92, 23,198,2,37,28,28,248,22,64,248,22,80,23,197,2,10,248,22,150,9,248, -22,80,23,197,2,249,22,4,22,64,248,22,81,23,198,2,11,11,11,10,12, -250,22,189,9,2,26,6,71,71,40,111,114,47,99,32,35,102,32,115,121,109, -98,111,108,63,32,40,99,111,110,115,47,99,32,40,111,114,47,99,32,35,102, -32,115,121,109,98,111,108,63,41,32,40,110,111,110,45,101,109,112,116,121,45, -108,105,115,116,111,102,32,115,121,109,98,111,108,63,41,41,41,23,197,2,27, -28,23,196,2,247,22,188,4,11,27,28,23,194,2,250,22,160,2,80,158,41, -41,248,22,134,16,247,22,159,13,11,11,27,28,23,194,2,250,22,160,2,248, -22,81,23,198,2,23,198,2,11,11,28,23,193,2,86,96,23,197,1,23,195, -1,23,194,1,20,13,159,80,159,39,38,37,250,80,159,42,39,37,249,22,33, -11,80,159,44,38,37,22,189,4,248,22,104,196,27,248,22,113,194,20,13,159, -80,159,40,38,37,250,80,159,43,39,37,249,22,33,11,80,159,45,38,37,22, -172,5,28,248,22,184,14,23,197,2,23,196,1,86,94,23,196,1,247,22,161, -15,249,247,22,170,5,248,22,80,196,200,86,94,23,193,1,90,159,47,11,89, -161,37,36,11,28,248,22,144,15,23,209,2,23,208,2,27,247,22,172,5,28, -23,193,2,249,22,145,15,23,211,2,23,195,1,23,209,2,89,161,39,37,11, -248,22,141,15,23,209,1,86,94,23,196,1,89,161,38,40,11,28,23,209,2, -27,248,22,189,14,23,197,2,27,248,22,136,8,23,195,2,28,28,249,22,131, -4,23,195,2,40,249,22,139,8,2,27,249,22,142,8,23,198,2,249,22,183, -3,23,199,2,40,11,249,22,7,23,199,2,248,22,129,15,249,22,143,8,250, -22,142,8,23,202,1,36,249,22,183,3,23,203,1,40,5,3,46,115,115,249, -22,7,23,199,2,11,249,22,7,23,197,2,11,89,161,37,42,11,28,249,22, -152,9,23,199,2,23,197,2,23,193,2,249,22,138,15,23,196,2,23,199,2, -89,161,37,43,11,28,23,198,2,28,249,22,152,9,23,200,2,23,197,1,23, -193,1,86,94,23,193,1,249,22,138,15,23,196,2,23,200,2,86,94,23,195, -1,11,89,161,37,44,11,28,249,22,152,9,23,196,2,68,114,101,108,97,116, -105,118,101,86,94,23,194,1,2,28,23,194,1,89,161,37,45,11,247,22,163, -15,89,161,37,46,11,247,22,164,15,27,250,22,155,15,23,203,2,11,32,0, -88,163,8,36,36,41,11,9,222,11,27,28,23,194,2,249,22,79,23,203,2, -23,196,1,86,94,23,194,1,11,27,28,23,203,2,28,23,194,2,11,27,250, -22,155,15,23,207,2,11,32,0,88,163,8,36,36,41,11,9,222,11,28,192, -249,22,79,23,206,2,194,11,11,27,28,23,195,2,23,195,2,23,194,2,27, -88,163,36,38,51,8,128,3,62,122,111,225,19,13,9,33,42,27,88,163,36, -38,51,8,128,3,66,97,108,116,45,122,111,225,20,14,11,33,43,27,88,163, -36,38,53,8,129,3,9,225,21,15,11,33,44,27,88,163,36,38,53,8,129, -3,9,225,22,16,13,33,45,27,28,23,200,2,23,200,2,248,22,150,9,23, -200,2,27,28,23,208,2,28,23,200,2,86,94,23,201,1,23,200,2,248,22, -150,9,23,202,1,11,27,28,23,195,2,28,23,197,1,27,249,22,5,88,163, -36,37,48,8,129,3,9,226,28,23,22,18,33,47,23,217,2,27,28,23,202, -2,11,193,28,192,192,28,193,28,23,202,2,28,249,22,131,4,248,22,81,196, -248,22,81,23,205,2,193,11,11,11,11,86,94,23,197,1,11,28,23,193,2, -86,108,23,217,1,23,216,1,23,214,1,23,213,1,23,211,1,23,210,1,23, -209,1,23,208,1,23,201,1,23,200,1,23,199,1,23,198,1,23,196,1,23, -195,1,23,194,1,20,13,159,80,159,8,25,38,37,250,80,159,8,28,39,37, -249,22,33,11,80,159,8,30,38,37,22,189,4,11,20,13,159,80,159,8,25, -38,37,250,80,159,8,28,39,37,249,22,33,11,80,159,8,30,38,37,22,172, -5,28,248,22,184,14,23,216,2,23,215,1,86,94,23,215,1,247,22,161,15, -249,247,22,168,15,248,22,80,195,23,29,86,94,23,193,1,27,28,23,195,2, -28,23,197,1,27,249,22,5,88,163,36,37,48,8,129,3,9,226,29,24,23, -20,33,49,23,218,2,27,28,23,204,2,11,193,28,192,192,28,193,28,203,28, -249,22,131,4,248,22,81,196,248,22,81,206,193,11,11,11,11,86,94,23,197, -1,11,28,23,193,2,86,105,23,218,1,23,217,1,23,215,1,23,214,1,23, -211,1,23,210,1,23,209,1,23,201,1,23,200,1,23,199,1,23,196,1,23, -195,1,20,13,159,80,159,8,26,38,37,250,80,159,8,29,39,37,249,22,33, -11,80,159,8,31,38,37,22,189,4,23,215,1,20,13,159,80,159,8,26,38, -37,250,80,159,8,29,39,37,249,22,33,11,80,159,8,31,38,37,22,172,5, -28,248,22,184,14,23,217,2,23,216,1,86,94,23,216,1,247,22,161,15,249, -247,22,168,15,248,22,80,195,23,30,86,94,23,193,1,27,28,23,197,2,28, -23,201,1,27,249,22,5,20,20,94,88,163,36,37,48,8,128,3,9,226,30, -25,24,20,33,51,23,213,1,23,219,2,27,28,23,204,2,11,193,28,192,192, -28,193,28,23,204,2,28,249,22,131,4,248,22,81,196,248,22,81,23,207,2, -193,11,11,11,86,94,23,210,1,11,86,94,23,201,1,11,28,23,193,2,86, -102,23,216,1,23,215,1,23,213,1,23,212,1,23,211,1,23,202,1,23,200, -1,23,197,1,23,196,1,86,94,27,248,22,80,194,28,23,219,2,250,22,158, -2,248,22,81,23,223,1,23,223,1,250,22,89,23,199,1,11,23,221,2,12, -20,13,159,80,159,8,27,38,37,250,80,159,8,30,39,37,249,22,33,11,80, -159,8,32,38,37,22,189,4,11,20,13,159,80,159,8,27,38,37,250,80,159, -8,30,39,37,249,22,33,11,80,159,8,32,38,37,22,172,5,28,248,22,184, -14,23,218,2,23,217,1,86,94,23,217,1,247,22,161,15,249,247,22,170,5, -248,22,80,195,23,31,86,94,23,193,1,27,28,23,197,1,28,23,201,1,27, -249,22,5,20,20,95,88,163,36,37,48,8,128,3,9,226,31,26,25,22,33, -53,23,215,1,23,219,1,23,220,1,27,28,23,205,2,11,193,28,192,192,28, -193,28,204,28,249,22,131,4,248,22,81,196,248,22,81,23,15,193,11,11,11, -86,96,23,217,1,23,216,1,23,212,1,11,86,94,23,201,1,11,28,23,193, -2,86,95,23,213,1,23,198,1,86,94,27,248,22,80,194,28,23,220,2,250, -22,158,2,248,22,81,23,224,32,0,0,0,1,23,224,32,0,0,0,1,250, -22,89,23,199,1,23,221,2,23,222,2,12,20,13,159,80,159,8,28,38,37, -250,80,159,8,31,39,37,249,22,33,11,80,159,8,33,38,37,22,189,4,23, -217,1,20,13,159,80,159,8,28,38,37,250,80,159,8,31,39,37,249,22,33, -11,80,159,8,33,38,37,22,172,5,28,248,22,184,14,23,219,2,23,218,1, -86,94,23,218,1,247,22,161,15,249,247,22,170,5,248,22,80,195,23,32,86, -94,23,193,1,28,28,248,22,77,23,224,32,0,0,0,2,248,22,80,23,224, -32,0,0,0,2,10,27,28,23,199,2,86,94,23,215,1,23,214,1,86,94, -23,214,1,23,215,1,28,28,248,22,77,23,224,33,0,0,0,2,248,22,150, -9,248,22,132,15,23,195,2,11,12,20,13,159,80,159,8,29,38,37,250,80, -159,8,32,39,37,249,22,33,11,80,159,8,34,38,37,22,189,4,28,23,34, -28,23,202,1,11,195,86,94,23,202,1,11,20,13,159,80,159,8,29,38,37, -250,80,159,8,32,39,37,249,22,33,11,80,159,8,34,38,37,22,172,5,28, -248,22,184,14,23,220,2,23,219,1,86,94,23,219,1,247,22,161,15,249,247, -22,170,5,194,23,33,12,28,193,250,22,158,2,248,22,81,197,195,250,22,89, -200,201,202,12,27,249,22,172,8,80,159,39,47,38,249,22,190,3,248,22,186, -3,248,22,173,2,200,8,128,8,27,28,193,248,22,176,2,194,11,28,192,27, -249,22,102,198,195,28,192,248,22,81,193,11,11,27,249,22,190,3,248,22,186, -3,248,22,173,2,198,8,128,8,27,249,22,172,8,80,159,40,47,38,195,27, -28,193,248,22,176,2,194,11,250,22,173,8,80,159,42,47,38,197,248,22,175, -2,249,22,79,249,22,79,204,205,28,198,198,9,0,17,35,114,120,34,94,40, -46,42,63,41,47,40,46,42,41,36,34,32,59,88,163,8,36,37,59,11,2, -31,222,33,60,27,249,22,173,15,2,58,23,196,2,28,23,193,2,86,94,23, -194,1,249,22,79,248,22,104,23,196,2,27,248,22,113,23,197,1,27,249,22, -173,15,2,58,23,196,2,28,23,193,2,86,94,23,194,1,249,22,79,248,22, -104,23,196,2,27,248,22,113,23,197,1,27,249,22,173,15,2,58,23,196,2, -28,23,193,2,86,94,23,194,1,249,22,79,248,22,104,23,196,2,27,248,22, -113,23,197,1,27,249,22,173,15,2,58,23,196,2,28,23,193,2,86,94,23, -194,1,249,22,79,248,22,104,23,196,2,248,2,59,248,22,113,23,197,1,248, -22,89,194,248,22,89,194,248,22,89,194,248,22,89,194,32,61,88,163,36,37, -55,11,2,31,222,33,62,28,248,22,87,248,22,81,23,195,2,249,22,7,9, -248,22,80,195,90,159,38,11,89,161,38,36,11,27,248,22,81,196,28,248,22, -87,248,22,81,23,195,2,249,22,7,9,248,22,80,195,90,159,38,11,89,161, -38,36,11,27,248,22,81,196,28,248,22,87,248,22,81,23,195,2,249,22,7, -9,248,22,80,195,90,159,38,11,89,161,38,36,11,248,2,61,248,22,81,196, -249,22,7,249,22,79,248,22,80,199,196,195,249,22,7,249,22,79,248,22,80, -199,196,195,249,22,7,249,22,79,248,22,80,199,196,195,27,27,249,22,173,15, -2,58,23,197,2,28,23,193,2,86,94,23,195,1,249,22,79,248,22,104,23, -196,2,27,248,22,113,23,197,1,27,249,22,173,15,2,58,23,196,2,28,23, +22,163,17,23,197,2,249,22,4,22,64,248,22,164,17,23,198,2,11,11,11, +10,12,250,22,189,9,2,26,6,71,71,40,111,114,47,99,32,35,102,32,115, +121,109,98,111,108,63,32,40,99,111,110,115,47,99,32,40,111,114,47,99,32, +35,102,32,115,121,109,98,111,108,63,41,32,40,110,111,110,45,101,109,112,116, +121,45,108,105,115,116,111,102,32,115,121,109,98,111,108,63,41,41,41,23,197, +2,27,28,23,196,2,247,22,188,4,11,27,28,23,194,2,250,22,160,2,80, +158,41,41,248,22,134,16,247,22,159,13,11,11,27,28,23,194,2,250,22,160, +2,248,22,81,23,198,2,23,198,2,11,11,28,23,193,2,86,96,23,197,1, +23,195,1,23,194,1,20,13,159,80,159,39,38,37,250,80,159,42,39,37,249, +22,33,11,80,159,44,38,37,22,189,4,248,22,104,196,27,248,22,113,194,20, +13,159,80,159,40,38,37,250,80,159,43,39,37,249,22,33,11,80,159,45,38, +37,22,172,5,28,248,22,184,14,23,197,2,23,196,1,86,94,23,196,1,247, +22,161,15,249,247,22,170,5,248,22,80,196,200,86,94,23,193,1,90,159,47, +11,89,161,37,36,11,28,248,22,144,15,23,209,2,23,208,2,27,247,22,172, +5,28,23,193,2,249,22,145,15,23,211,2,23,195,1,23,209,2,89,161,39, +37,11,248,22,141,15,23,209,1,86,94,23,196,1,89,161,38,40,11,28,23, +209,2,27,248,22,189,14,23,197,2,27,248,22,136,8,23,195,2,28,28,249, +22,131,4,23,195,2,40,249,22,139,8,2,27,249,22,142,8,23,198,2,249, +22,183,3,23,199,2,40,11,249,22,7,23,199,2,248,22,129,15,249,22,143, +8,250,22,142,8,23,202,1,36,249,22,183,3,23,203,1,40,5,3,46,115, +115,249,22,7,23,199,2,11,249,22,7,23,197,2,11,89,161,37,42,11,28, +249,22,152,9,23,199,2,23,197,2,23,193,2,249,22,138,15,23,196,2,23, +199,2,89,161,37,43,11,28,23,198,2,28,249,22,152,9,23,200,2,23,197, +1,23,193,1,86,94,23,193,1,249,22,138,15,23,196,2,23,200,2,86,94, +23,195,1,11,89,161,37,44,11,28,249,22,152,9,23,196,2,68,114,101,108, +97,116,105,118,101,86,94,23,194,1,2,28,23,194,1,89,161,37,45,11,247, +22,163,15,89,161,37,46,11,247,22,164,15,27,250,22,155,15,23,203,2,11, +32,0,88,163,8,36,36,41,11,9,222,11,27,28,23,194,2,249,22,79,23, +203,2,23,196,1,86,94,23,194,1,11,27,28,23,203,2,28,23,194,2,11, +27,250,22,155,15,23,207,2,11,32,0,88,163,8,36,36,41,11,9,222,11, +28,192,249,22,79,23,206,2,194,11,11,27,28,23,195,2,23,195,2,23,194, +2,27,88,163,36,38,51,8,128,3,62,122,111,225,19,13,9,33,42,27,88, +163,36,38,51,8,128,3,66,97,108,116,45,122,111,225,20,14,11,33,43,27, +88,163,36,38,53,8,129,3,9,225,21,15,11,33,44,27,88,163,36,38,53, +8,129,3,9,225,22,16,13,33,45,27,28,23,200,2,23,200,2,248,22,150, +9,23,200,2,27,28,23,208,2,28,23,200,2,86,94,23,201,1,23,200,2, +248,22,150,9,23,202,1,11,27,28,23,195,2,28,23,197,1,27,249,22,5, +88,163,36,37,48,8,129,3,9,226,28,23,22,18,33,47,23,217,2,27,28, +23,202,2,11,193,28,192,192,28,193,28,23,202,2,28,249,22,131,4,248,22, +81,196,248,22,81,23,205,2,193,11,11,11,11,86,94,23,197,1,11,28,23, +193,2,86,108,23,217,1,23,216,1,23,214,1,23,213,1,23,211,1,23,210, +1,23,209,1,23,208,1,23,201,1,23,200,1,23,199,1,23,198,1,23,196, +1,23,195,1,23,194,1,20,13,159,80,159,8,25,38,37,250,80,159,8,28, +39,37,249,22,33,11,80,159,8,30,38,37,22,189,4,11,20,13,159,80,159, +8,25,38,37,250,80,159,8,28,39,37,249,22,33,11,80,159,8,30,38,37, +22,172,5,28,248,22,184,14,23,216,2,23,215,1,86,94,23,215,1,247,22, +161,15,249,247,22,168,15,248,22,80,195,23,29,86,94,23,193,1,27,28,23, +195,2,28,23,197,1,27,249,22,5,88,163,36,37,48,8,129,3,9,226,29, +24,23,20,33,49,23,218,2,27,28,23,204,2,11,193,28,192,192,28,193,28, +203,28,249,22,131,4,248,22,81,196,248,22,81,206,193,11,11,11,11,86,94, +23,197,1,11,28,23,193,2,86,105,23,218,1,23,217,1,23,215,1,23,214, +1,23,211,1,23,210,1,23,209,1,23,201,1,23,200,1,23,199,1,23,196, +1,23,195,1,20,13,159,80,159,8,26,38,37,250,80,159,8,29,39,37,249, +22,33,11,80,159,8,31,38,37,22,189,4,23,215,1,20,13,159,80,159,8, +26,38,37,250,80,159,8,29,39,37,249,22,33,11,80,159,8,31,38,37,22, +172,5,28,248,22,184,14,23,217,2,23,216,1,86,94,23,216,1,247,22,161, +15,249,247,22,168,15,248,22,80,195,23,30,86,94,23,193,1,27,28,23,197, +2,28,23,201,1,27,249,22,5,20,20,94,88,163,36,37,48,8,128,3,9, +226,30,25,24,20,33,51,23,213,1,23,219,2,27,28,23,204,2,11,193,28, +192,192,28,193,28,23,204,2,28,249,22,131,4,248,22,81,196,248,22,81,23, +207,2,193,11,11,11,86,94,23,210,1,11,86,94,23,201,1,11,28,23,193, +2,86,102,23,216,1,23,215,1,23,213,1,23,212,1,23,211,1,23,202,1, +23,200,1,23,197,1,23,196,1,86,94,27,248,22,80,194,28,23,219,2,250, +22,158,2,248,22,81,23,223,1,23,223,1,250,22,89,23,199,1,11,23,221, +2,12,20,13,159,80,159,8,27,38,37,250,80,159,8,30,39,37,249,22,33, +11,80,159,8,32,38,37,22,189,4,11,20,13,159,80,159,8,27,38,37,250, +80,159,8,30,39,37,249,22,33,11,80,159,8,32,38,37,22,172,5,28,248, +22,184,14,23,218,2,23,217,1,86,94,23,217,1,247,22,161,15,249,247,22, +170,5,248,22,163,17,195,23,31,86,94,23,193,1,27,28,23,197,1,28,23, +201,1,27,249,22,5,20,20,95,88,163,36,37,48,8,128,3,9,226,31,26, +25,22,33,53,23,215,1,23,219,1,23,220,1,27,28,23,205,2,11,193,28, +192,192,28,193,28,204,28,249,22,131,4,248,22,81,196,248,22,81,23,15,193, +11,11,11,86,96,23,217,1,23,216,1,23,212,1,11,86,94,23,201,1,11, +28,23,193,2,86,95,23,213,1,23,198,1,86,94,27,248,22,80,194,28,23, +220,2,250,22,158,2,248,22,81,23,224,32,0,0,0,1,23,224,32,0,0, +0,1,250,22,89,23,199,1,23,221,2,23,222,2,12,20,13,159,80,159,8, +28,38,37,250,80,159,8,31,39,37,249,22,33,11,80,159,8,33,38,37,22, +189,4,23,217,1,20,13,159,80,159,8,28,38,37,250,80,159,8,31,39,37, +249,22,33,11,80,159,8,33,38,37,22,172,5,28,248,22,184,14,23,219,2, +23,218,1,86,94,23,218,1,247,22,161,15,249,247,22,170,5,248,22,163,17, +195,23,32,86,94,23,193,1,28,28,248,22,77,23,224,32,0,0,0,2,248, +22,163,17,23,224,32,0,0,0,2,10,27,28,23,199,2,86,94,23,215,1, +23,214,1,86,94,23,214,1,23,215,1,28,28,248,22,77,23,224,33,0,0, +0,2,248,22,150,9,248,22,132,15,23,195,2,11,12,20,13,159,80,159,8, +29,38,37,250,80,159,8,32,39,37,249,22,33,11,80,159,8,34,38,37,22, +189,4,28,23,34,28,23,202,1,11,195,86,94,23,202,1,11,20,13,159,80, +159,8,29,38,37,250,80,159,8,32,39,37,249,22,33,11,80,159,8,34,38, +37,22,172,5,28,248,22,184,14,23,220,2,23,219,1,86,94,23,219,1,247, +22,161,15,249,247,22,170,5,194,23,33,12,28,193,250,22,158,2,248,22,81, +197,195,250,22,89,200,201,202,12,27,249,22,172,8,80,159,39,47,38,249,22, +190,3,248,22,186,3,248,22,173,2,200,8,128,8,27,28,193,248,22,176,2, +194,11,28,192,27,249,22,102,198,195,28,192,248,22,81,193,11,11,27,249,22, +190,3,248,22,186,3,248,22,173,2,198,8,128,8,27,249,22,172,8,80,159, +40,47,38,195,27,28,193,248,22,176,2,194,11,250,22,173,8,80,159,42,47, +38,197,248,22,175,2,249,22,79,249,22,79,204,205,28,198,198,9,0,17,35, +114,120,34,94,40,46,42,63,41,47,40,46,42,41,36,34,32,59,88,163,8, +36,37,59,11,2,31,222,33,60,27,249,22,173,15,2,58,23,196,2,28,23, 193,2,86,94,23,194,1,249,22,79,248,22,104,23,196,2,27,248,22,113,23, 197,1,27,249,22,173,15,2,58,23,196,2,28,23,193,2,86,94,23,194,1, 249,22,79,248,22,104,23,196,2,27,248,22,113,23,197,1,27,249,22,173,15, 2,58,23,196,2,28,23,193,2,86,94,23,194,1,249,22,79,248,22,104,23, -196,2,248,2,59,248,22,113,23,197,1,248,22,89,194,248,22,89,194,248,22, -89,194,248,22,89,195,28,23,195,1,192,28,248,22,87,248,22,81,23,195,2, -249,22,7,9,248,22,80,195,27,248,22,81,194,90,159,38,11,89,161,38,36, -11,28,248,22,87,248,22,81,23,197,2,249,22,7,9,248,22,80,197,27,248, -22,81,196,90,159,38,11,89,161,38,36,11,28,248,22,87,248,22,81,23,197, -2,249,22,7,9,248,22,80,197,90,159,38,11,89,161,38,36,11,248,2,61, -248,22,81,198,249,22,7,249,22,79,248,22,80,201,196,195,249,22,7,249,22, -79,248,22,80,202,196,195,249,22,7,249,22,79,248,22,80,200,196,195,28,24, -194,2,12,20,13,159,80,159,36,57,37,80,158,36,55,89,161,37,37,10,249, -22,190,4,21,94,2,32,6,19,19,112,108,97,110,101,116,47,114,101,115,111, -108,118,101,114,46,114,107,116,1,27,112,108,97,110,101,116,45,109,111,100,117, -108,101,45,110,97,109,101,45,114,101,115,111,108,118,101,114,12,27,28,23,195, -2,28,249,22,152,9,23,197,2,80,158,39,52,86,94,23,195,1,80,158,37, -53,27,248,22,148,5,23,197,2,27,28,248,22,77,23,195,2,248,22,80,23, -195,1,23,194,1,28,248,22,184,14,23,194,2,90,159,39,11,89,161,39,36, -11,248,22,141,15,23,197,1,86,95,20,18,159,11,80,158,42,52,199,20,18, -159,11,80,158,42,53,192,192,11,11,28,23,193,2,192,86,94,23,193,1,27, -247,22,172,5,28,192,192,247,22,161,15,90,159,39,11,89,161,39,36,11,248, -22,141,15,197,86,95,23,195,1,23,193,1,28,249,22,173,15,0,11,35,114, -120,34,91,46,93,115,115,36,34,248,22,189,14,23,197,1,249,80,159,41,58, -39,198,2,27,196,249,80,159,38,54,39,195,10,249,22,14,195,80,159,38,51, -38,86,96,28,248,22,146,5,23,196,2,12,250,22,189,9,2,22,6,21,21, -114,101,115,111,108,118,101,100,45,109,111,100,117,108,101,45,112,97,116,104,63, -23,198,2,28,28,23,196,2,248,22,160,13,23,197,2,10,12,250,22,189,9, -2,22,6,20,20,40,111,114,47,99,32,35,102,32,110,97,109,101,115,112,97, -99,101,63,41,23,199,2,28,24,193,2,248,24,194,1,23,196,2,86,94,23, -193,1,12,27,250,22,160,2,80,159,41,41,38,248,22,134,16,247,22,159,13, -11,27,28,23,194,2,23,194,1,86,94,23,194,1,27,249,22,79,247,22,140, -2,247,22,140,2,86,94,250,22,158,2,80,159,43,41,38,248,22,134,16,247, -22,159,13,195,192,86,94,250,22,158,2,248,22,80,23,197,2,23,200,2,68, -100,101,99,108,97,114,101,100,28,23,198,2,27,28,248,22,77,248,22,148,5, -23,200,2,248,22,147,5,248,22,80,248,22,148,5,23,201,1,23,198,1,27, -250,22,160,2,80,159,44,41,38,248,22,134,16,23,204,1,11,28,23,193,2, -27,250,22,160,2,248,22,81,23,198,1,197,11,28,192,250,22,158,2,248,22, -81,199,197,195,12,12,12,251,211,197,198,199,10,32,71,88,163,36,38,47,11, -76,102,108,97,116,116,101,110,45,115,117,98,45,112,97,116,104,222,33,74,32, -72,88,163,36,40,54,11,2,31,222,33,73,28,248,22,87,23,197,2,28,248, -22,87,195,192,249,22,79,194,248,22,94,197,28,249,22,154,9,248,22,80,23, -199,2,2,35,28,248,22,87,23,196,2,86,95,23,196,1,23,195,1,250,22, -185,9,2,22,6,37,37,116,111,111,32,109,97,110,121,32,34,46,46,34,115, -32,105,110,32,115,117,98,109,111,100,117,108,101,32,112,97,116,104,58,32,126, -46,115,250,22,90,2,34,28,249,22,154,9,23,201,2,2,36,198,28,248,22, -184,14,199,198,249,22,89,28,248,22,64,201,2,4,2,37,200,199,251,2,72, -196,197,248,22,81,199,248,22,81,200,251,2,72,196,197,249,22,79,248,22,80, -202,200,248,22,81,200,251,2,72,196,197,9,197,27,249,22,165,7,6,31,31, -115,116,97,110,100,97,114,100,45,109,111,100,117,108,101,45,110,97,109,101,45, -114,101,115,111,108,118,101,114,58,32,196,28,193,250,22,187,9,11,195,196,248, -22,185,9,193,28,249,22,148,7,194,2,36,2,28,28,249,22,148,7,194,2, -35,62,117,112,192,32,77,88,163,8,36,37,50,11,67,115,115,45,62,114,107, -116,222,33,78,27,248,22,145,7,194,28,249,22,131,4,194,39,28,249,22,148, -7,6,3,3,46,115,115,249,22,164,7,197,249,22,183,3,198,39,249,22,165, -7,250,22,164,7,198,36,249,22,183,3,199,39,2,40,193,193,0,8,35,114, -120,34,91,46,93,34,32,80,88,163,8,36,37,47,11,2,31,222,33,81,28, -248,22,87,23,194,2,9,250,22,90,6,4,4,10,32,32,32,248,22,188,14, -248,22,105,23,198,2,248,2,80,248,22,81,23,198,1,28,249,22,154,9,248, -22,81,23,200,2,23,197,1,28,249,22,152,9,248,22,80,23,200,1,23,196, -1,251,22,185,9,2,22,6,41,41,99,121,99,108,101,32,105,110,32,108,111, -97,100,105,110,103,10,32,32,97,116,32,112,97,116,104,58,32,126,97,10,32, -32,112,97,116,104,115,58,126,97,23,200,1,249,22,1,22,165,7,248,2,80, -248,22,94,23,201,1,12,12,247,192,20,13,159,80,159,43,50,38,249,22,79, -249,22,79,248,22,134,16,247,22,159,13,23,201,1,23,195,1,20,13,159,80, -159,43,38,37,250,80,159,46,39,37,249,22,33,11,80,159,48,38,37,22,188, -4,23,198,2,249,247,22,171,5,23,200,1,27,248,22,67,248,22,188,14,23, -201,1,28,23,202,2,28,250,22,160,2,248,22,80,23,201,1,23,201,1,11, -249,22,79,11,203,249,22,79,194,203,192,86,94,28,248,22,156,5,23,196,2, -12,28,23,197,2,250,22,187,9,11,6,15,15,98,97,100,32,109,111,100,117, -108,101,32,112,97,116,104,23,200,2,250,22,189,9,2,22,2,33,23,198,2, -28,28,248,22,77,23,196,2,249,22,152,9,248,22,80,23,198,2,2,4,11, -248,22,147,5,248,22,104,196,28,28,248,22,77,23,196,2,28,249,22,152,9, -248,22,80,23,198,2,2,34,28,248,22,77,248,22,104,23,197,2,249,22,152, -9,248,22,108,23,198,2,2,4,11,11,11,86,97,23,198,1,23,197,1,23, -196,1,23,193,1,248,22,147,5,249,2,71,248,22,121,23,199,2,248,22,106, -23,199,1,28,28,248,22,77,23,196,2,28,249,22,152,9,248,22,80,23,198, -2,2,34,28,28,249,22,154,9,248,22,104,23,198,2,2,36,10,249,22,154, -9,248,22,104,23,198,2,2,35,28,23,196,2,27,248,22,148,5,23,198,2, -28,248,22,64,193,10,28,248,22,77,193,248,22,64,248,22,80,194,11,11,11, -11,11,86,96,23,198,1,23,197,1,23,193,1,27,248,22,148,5,23,198,1, -248,22,147,5,249,2,71,28,248,22,77,23,197,2,248,22,80,23,197,2,23, -196,2,27,28,249,22,154,9,248,22,104,23,203,2,2,35,248,22,81,200,248, -22,106,200,28,248,22,77,23,198,2,249,22,93,248,22,81,199,194,192,28,28, -248,22,77,23,196,2,249,22,152,9,248,22,80,23,198,2,2,38,11,86,94, -248,80,159,38,8,28,39,193,253,213,200,201,202,203,11,80,158,43,55,28,28, -248,22,77,23,196,2,28,249,22,152,9,248,22,80,23,198,2,2,34,28,248, -22,77,248,22,104,23,197,2,249,22,152,9,248,22,108,23,198,2,2,38,11, -11,11,86,94,248,80,159,38,8,28,39,193,253,213,248,22,104,201,201,202,203, -248,22,106,201,80,158,43,55,86,94,23,193,1,27,88,163,8,36,37,47,11, -79,115,104,111,119,45,99,111,108,108,101,99,116,105,111,110,45,101,114,114,223, -5,33,75,27,28,248,22,77,23,198,2,28,249,22,152,9,2,34,248,22,80, -23,200,2,27,248,22,104,23,199,2,28,28,249,22,154,9,23,195,2,2,36, -10,249,22,154,9,23,195,2,2,35,86,94,23,193,1,28,23,199,2,27,248, -22,148,5,23,201,2,28,248,22,77,193,248,22,80,193,192,250,22,185,9,2, -22,6,45,45,110,111,32,98,97,115,101,32,112,97,116,104,32,102,111,114,32, -114,101,108,97,116,105,118,101,32,115,117,98,109,111,100,117,108,101,32,112,97, -116,104,58,32,126,46,115,23,201,2,192,23,197,2,23,197,2,27,28,248,22, -77,23,199,2,28,249,22,152,9,2,34,248,22,80,23,201,2,27,28,28,28, -249,22,154,9,248,22,104,23,202,2,2,36,10,249,22,154,9,248,22,104,23, -202,2,2,35,23,200,2,11,27,248,22,148,5,23,202,2,27,28,249,22,154, -9,248,22,104,23,204,2,2,35,248,22,81,23,202,1,248,22,106,23,202,1, -28,248,22,77,23,195,2,249,2,71,248,22,80,23,197,2,249,22,93,248,22, -81,23,199,1,23,197,1,249,2,71,23,196,1,23,195,1,249,2,71,2,36, -28,249,22,154,9,248,22,104,23,204,2,2,35,248,22,81,23,202,1,248,22, -106,23,202,1,28,248,22,77,193,248,22,81,193,11,11,11,27,28,248,22,64, -23,196,2,27,248,80,159,43,48,39,249,22,79,23,199,2,247,22,162,15,28, -23,193,2,192,86,94,23,193,1,90,159,38,11,89,161,38,36,11,249,80,159, -46,54,39,248,22,70,23,201,2,11,27,28,248,22,87,23,195,2,2,39,249, -22,165,7,23,197,2,2,40,251,80,159,49,59,39,23,204,1,28,248,22,87, -23,199,2,23,199,1,86,94,23,199,1,248,22,80,23,199,2,28,248,22,87, -23,199,2,86,94,23,198,1,9,248,22,81,23,199,1,23,197,1,28,248,22, -142,7,23,196,2,86,94,23,196,1,27,248,80,159,43,8,29,39,23,202,2, -27,248,80,159,44,48,39,249,22,79,23,200,2,23,197,2,28,23,193,2,192, -86,94,23,193,1,90,159,38,11,89,161,38,36,11,249,80,159,47,54,39,23, -201,2,11,250,22,1,22,138,15,23,199,1,249,22,93,249,22,2,32,0,88, -163,8,36,37,44,11,9,222,33,76,23,200,1,248,22,89,248,2,77,23,201, -1,28,248,22,184,14,23,196,2,86,94,23,196,1,248,80,159,42,8,30,39, -248,22,147,15,28,248,22,144,15,23,198,2,23,197,2,249,22,145,15,23,199, -2,248,80,159,46,8,29,39,23,205,2,28,249,22,152,9,248,22,80,23,198, -2,2,32,27,248,80,159,43,48,39,249,22,79,23,199,2,247,22,162,15,28, -23,193,2,192,86,94,23,193,1,90,159,39,11,89,161,38,36,11,249,80,159, -47,54,39,248,22,104,23,202,2,11,89,161,37,38,11,28,248,22,87,248,22, -106,23,201,2,28,248,22,87,23,194,2,249,22,177,15,2,79,23,196,2,11, -10,27,28,23,196,2,248,2,77,23,196,2,28,248,22,87,23,195,2,2,39, -28,249,22,177,15,2,79,23,197,2,248,2,77,23,196,2,249,22,165,7,23, -197,2,2,40,27,28,23,197,1,86,94,23,196,1,249,22,93,28,248,22,87, -248,22,106,23,205,2,21,93,6,5,5,109,122,108,105,98,249,22,1,22,93, -249,22,2,80,159,53,8,31,39,248,22,106,23,208,2,23,197,1,28,248,22, -87,23,196,2,86,94,23,195,1,248,22,89,23,197,1,86,94,23,196,1,23, -195,1,251,80,159,51,59,39,23,206,1,248,22,80,23,198,2,248,22,81,23, -198,1,23,198,1,28,249,22,152,9,248,22,80,23,198,2,2,37,248,80,159, -42,8,30,39,248,22,147,15,249,22,145,15,248,22,149,15,248,22,104,23,201, -2,248,80,159,46,8,29,39,23,205,2,12,86,94,28,28,248,22,184,14,23, -194,2,10,248,22,167,8,23,194,2,86,94,23,201,1,12,28,23,201,2,250, -22,187,9,67,114,101,113,117,105,114,101,249,22,190,7,6,17,17,98,97,100, -32,109,111,100,117,108,101,32,112,97,116,104,126,97,28,23,198,2,248,22,80, -23,199,2,6,0,0,23,204,1,86,94,23,201,1,250,22,189,9,2,22,2, -33,23,198,2,27,28,248,22,167,8,23,195,2,249,22,172,8,23,196,2,36, -249,22,147,15,248,22,148,15,23,197,2,11,27,28,248,22,167,8,23,196,2, -249,22,172,8,23,197,2,37,248,80,159,44,8,24,39,23,195,2,90,159,39, -11,89,161,39,36,11,28,248,22,167,8,23,199,2,250,22,7,2,41,249,22, -172,8,23,203,2,38,2,41,248,22,141,15,23,198,2,86,95,23,195,1,23, -193,1,27,28,248,22,167,8,23,200,2,249,22,172,8,23,201,2,39,249,80, -159,49,58,39,23,197,2,5,0,27,28,248,22,167,8,23,201,2,249,22,172, -8,23,202,2,40,248,22,147,5,23,200,2,27,250,22,160,2,80,159,52,41, -38,248,22,134,16,247,22,159,13,11,27,28,23,194,2,23,194,1,86,94,23, -194,1,27,249,22,79,247,22,140,2,247,22,140,2,86,94,250,22,158,2,80, -159,54,41,38,248,22,134,16,247,22,159,13,195,192,27,28,23,204,2,248,22, -147,5,249,22,79,248,22,148,5,23,200,2,23,207,2,23,196,2,86,95,28, -23,212,1,27,250,22,160,2,248,22,80,23,199,2,196,11,28,23,193,1,12, -27,27,28,248,22,17,80,159,55,51,38,80,159,54,51,38,247,22,19,251,22, -33,11,80,159,58,50,38,9,23,197,1,27,248,22,134,16,247,22,159,13,86, -94,249,22,3,20,20,94,88,163,8,36,37,54,11,9,226,14,13,2,3,33, -82,23,195,1,23,196,2,248,28,248,22,17,80,159,56,51,38,32,0,88,163, -36,37,42,11,9,222,33,83,80,159,55,8,32,39,20,20,96,88,163,36,36, -56,8,240,12,64,0,0,9,230,19,15,13,12,8,7,5,2,33,84,23,195, -1,23,198,1,23,208,1,12,28,28,248,22,167,8,23,204,1,11,28,248,22, -142,7,23,206,2,10,28,248,22,64,23,206,2,10,28,248,22,77,23,206,2, -249,22,152,9,248,22,80,23,208,2,2,32,11,249,80,159,53,49,39,28,248, -22,142,7,23,208,2,249,22,79,23,209,1,248,80,159,56,8,29,39,23,215, -1,86,94,23,212,1,249,22,79,23,209,1,247,22,162,15,252,22,169,8,23, -209,1,23,208,1,23,206,1,23,204,1,23,203,1,12,192,86,96,20,18,159, -11,80,158,36,55,248,80,159,37,8,27,37,249,22,33,11,80,159,39,57,37, -248,22,187,4,80,159,37,56,38,248,22,171,5,80,159,37,37,39,248,22,153, -14,80,159,37,45,39,20,18,159,11,80,158,36,55,248,80,159,37,8,27,37, -249,22,33,11,80,159,39,57,37,20,18,159,11,80,158,36,55,248,80,159,37, -8,27,37,249,22,33,11,80,159,39,57,37,159,36,20,113,159,36,16,1,11, -16,0,20,26,144,9,2,1,2,1,29,11,11,11,9,9,11,11,11,10,38, -80,158,36,36,20,113,159,41,16,28,2,2,2,3,30,2,6,2,7,11,6, -30,2,6,1,23,101,120,116,101,110,100,45,112,97,114,97,109,101,116,101,114, -105,122,97,116,105,111,110,11,3,30,2,8,72,112,97,116,104,45,115,116,114, -105,110,103,63,38,196,11,2,9,30,2,8,71,114,101,114,111,111,116,45,112, -97,116,104,40,196,12,30,2,8,75,112,97,116,104,45,97,100,100,45,115,117, -102,102,105,120,40,196,8,2,10,2,11,2,12,2,13,2,14,2,15,2,16, -2,17,2,18,2,19,2,20,2,21,2,22,30,2,23,2,7,11,6,30,2, -8,79,112,97,116,104,45,114,101,112,108,97,99,101,45,115,117,102,102,105,120, -40,196,10,30,2,8,73,102,105,110,100,45,99,111,108,45,102,105,108,101,44, -196,3,30,2,8,76,110,111,114,109,97,108,45,99,97,115,101,45,112,97,116, -104,38,196,7,2,24,2,25,30,2,23,74,114,101,112,97,114,97,109,101,116, -101,114,105,122,101,11,7,16,0,37,39,36,16,0,36,16,15,2,16,2,17, -2,9,2,13,2,18,2,19,2,12,2,3,2,11,2,2,2,14,2,15,2, -10,2,20,2,22,51,11,11,11,16,3,2,24,2,21,2,25,16,3,11,11, -11,16,3,2,24,2,21,2,25,39,39,37,12,11,11,16,0,16,0,16,0, -36,36,11,12,11,11,16,0,16,0,16,0,36,36,16,23,20,15,16,2,248, -22,164,8,69,115,111,45,115,117,102,102,105,120,80,159,36,36,37,20,15,16, -2,88,163,36,38,8,43,8,189,3,2,3,223,0,33,54,80,159,36,37,37, -20,15,16,2,32,0,88,163,8,36,41,52,11,2,10,222,33,55,80,159,36, -44,37,20,15,16,2,20,27,158,32,0,88,163,8,36,37,42,11,2,11,222, -192,32,0,88,163,8,36,37,42,11,2,11,222,192,80,159,36,45,37,20,15, -16,2,247,22,143,2,80,159,36,41,37,20,15,16,2,8,128,8,80,159,36, -46,37,20,15,16,2,249,22,168,8,8,128,8,11,80,159,36,47,37,20,15, -16,2,88,163,8,36,37,50,8,128,32,2,14,223,0,33,56,80,159,36,48, -37,20,15,16,2,88,163,8,36,38,55,8,128,32,2,15,223,0,33,57,80, -159,36,49,37,20,15,16,2,247,22,75,80,159,36,50,37,20,15,16,2,248, -22,18,74,109,111,100,117,108,101,45,108,111,97,100,105,110,103,80,159,36,51, -37,20,15,16,2,11,80,158,36,52,20,15,16,2,11,80,158,36,53,20,15, -16,2,32,0,88,163,36,38,8,25,11,2,20,222,33,63,80,159,36,54,37, -20,15,16,2,11,80,158,36,55,20,15,16,2,88,164,8,34,37,45,8,240, -0,0,40,0,1,21,112,114,101,112,45,112,108,97,110,101,116,45,114,101,115, -111,108,118,101,114,33,37,224,1,0,33,64,80,159,36,8,28,39,20,15,16, -2,88,163,36,37,50,8,240,0,0,3,0,67,103,101,116,45,100,105,114,223, -0,33,65,80,159,36,8,29,39,20,15,16,2,88,163,36,37,49,8,240,0, -0,64,0,72,112,97,116,104,45,115,115,45,62,114,107,116,223,0,33,66,80, -159,36,8,30,39,20,15,16,2,88,163,8,36,37,45,8,240,0,0,4,0, -9,223,0,33,67,80,159,36,8,31,39,20,15,16,2,88,163,36,37,45,8, -240,0,128,0,0,9,223,0,33,68,80,159,36,8,32,39,20,15,16,2,27, -11,20,19,158,36,90,159,37,10,89,161,37,36,10,20,25,96,2,22,88,163, -8,36,38,54,8,32,9,224,2,1,33,69,88,163,36,39,49,11,9,223,0, -33,70,88,163,36,40,8,32,16,4,8,240,44,240,0,0,8,240,204,241,0, -0,37,36,9,224,2,1,33,85,207,80,159,36,56,37,20,15,16,2,88,163, -36,36,45,16,2,8,130,8,8,184,32,2,24,223,0,33,86,80,159,36,8, -25,37,20,15,16,2,20,27,158,88,163,8,36,36,45,16,2,36,8,168,32, -2,25,223,0,33,87,88,163,8,36,36,45,16,2,36,8,168,32,2,25,223, -0,33,88,80,159,36,8,26,37,96,29,94,2,4,68,35,37,107,101,114,110, -101,108,11,29,94,2,4,69,35,37,109,105,110,45,115,116,120,11,2,8,2, -23,9,9,9,36,0}; - EVAL_ONE_SIZED_STR((char *)expr, 8468); +196,2,27,248,22,113,23,197,1,27,249,22,173,15,2,58,23,196,2,28,23, +193,2,86,94,23,194,1,249,22,79,248,22,104,23,196,2,248,2,59,248,22, +113,23,197,1,248,22,89,194,248,22,89,194,248,22,89,194,248,22,89,194,32, +61,88,163,36,37,55,11,2,31,222,33,62,28,248,22,87,248,22,81,23,195, +2,249,22,7,9,248,22,163,17,195,90,159,38,11,89,161,38,36,11,27,248, +22,164,17,196,28,248,22,87,248,22,81,23,195,2,249,22,7,9,248,22,163, +17,195,90,159,38,11,89,161,38,36,11,27,248,22,164,17,196,28,248,22,87, +248,22,81,23,195,2,249,22,7,9,248,22,163,17,195,90,159,38,11,89,161, +38,36,11,248,2,61,248,22,164,17,196,249,22,7,249,22,79,248,22,163,17, +199,196,195,249,22,7,249,22,79,248,22,163,17,199,196,195,249,22,7,249,22, +79,248,22,163,17,199,196,195,27,27,249,22,173,15,2,58,23,197,2,28,23, +193,2,86,94,23,195,1,249,22,79,248,22,104,23,196,2,27,248,22,113,23, +197,1,27,249,22,173,15,2,58,23,196,2,28,23,193,2,86,94,23,194,1, +249,22,79,248,22,104,23,196,2,27,248,22,113,23,197,1,27,249,22,173,15, +2,58,23,196,2,28,23,193,2,86,94,23,194,1,249,22,79,248,22,104,23, +196,2,27,248,22,113,23,197,1,27,249,22,173,15,2,58,23,196,2,28,23, +193,2,86,94,23,194,1,249,22,79,248,22,104,23,196,2,248,2,59,248,22, +113,23,197,1,248,22,89,194,248,22,89,194,248,22,89,194,248,22,89,195,28, +23,195,1,192,28,248,22,87,248,22,81,23,195,2,249,22,7,9,248,22,163, +17,195,27,248,22,164,17,194,90,159,38,11,89,161,38,36,11,28,248,22,87, +248,22,81,23,197,2,249,22,7,9,248,22,163,17,197,27,248,22,164,17,196, +90,159,38,11,89,161,38,36,11,28,248,22,87,248,22,81,23,197,2,249,22, +7,9,248,22,163,17,197,90,159,38,11,89,161,38,36,11,248,2,61,248,22, +164,17,198,249,22,7,249,22,79,248,22,163,17,201,196,195,249,22,7,249,22, +79,248,22,163,17,202,196,195,249,22,7,249,22,79,248,22,163,17,200,196,195, +28,24,194,2,12,20,13,159,80,159,36,57,37,80,158,36,55,89,161,37,37, +10,249,22,190,4,21,94,2,32,6,19,19,112,108,97,110,101,116,47,114,101, +115,111,108,118,101,114,46,114,107,116,1,27,112,108,97,110,101,116,45,109,111, +100,117,108,101,45,110,97,109,101,45,114,101,115,111,108,118,101,114,12,27,28, +23,195,2,28,249,22,152,9,23,197,2,80,158,39,52,86,94,23,195,1,80, +158,37,53,27,248,22,148,5,23,197,2,27,28,248,22,77,23,195,2,248,22, +163,17,23,195,1,23,194,1,28,248,22,184,14,23,194,2,90,159,39,11,89, +161,39,36,11,248,22,141,15,23,197,1,86,95,20,18,159,11,80,158,42,52, +199,20,18,159,11,80,158,42,53,192,192,11,11,28,23,193,2,192,86,94,23, +193,1,27,247,22,172,5,28,192,192,247,22,161,15,90,159,39,11,89,161,39, +36,11,248,22,141,15,197,86,95,23,195,1,23,193,1,28,249,22,173,15,0, +11,35,114,120,34,91,46,93,115,115,36,34,248,22,189,14,23,197,1,249,80, +159,41,58,39,198,2,27,196,249,80,159,38,54,39,195,10,249,22,14,195,80, +159,38,51,38,86,96,28,248,22,146,5,23,196,2,12,250,22,189,9,2,22, +6,21,21,114,101,115,111,108,118,101,100,45,109,111,100,117,108,101,45,112,97, +116,104,63,23,198,2,28,28,23,196,2,248,22,160,13,23,197,2,10,12,250, +22,189,9,2,22,6,20,20,40,111,114,47,99,32,35,102,32,110,97,109,101, +115,112,97,99,101,63,41,23,199,2,28,24,193,2,248,24,194,1,23,196,2, +86,94,23,193,1,12,27,250,22,160,2,80,159,41,41,38,248,22,134,16,247, +22,159,13,11,27,28,23,194,2,23,194,1,86,94,23,194,1,27,249,22,79, +247,22,140,2,247,22,140,2,86,94,250,22,158,2,80,159,43,41,38,248,22, +134,16,247,22,159,13,195,192,86,94,250,22,158,2,248,22,80,23,197,2,23, +200,2,68,100,101,99,108,97,114,101,100,28,23,198,2,27,28,248,22,77,248, +22,148,5,23,200,2,248,22,147,5,248,22,80,248,22,148,5,23,201,1,23, +198,1,27,250,22,160,2,80,159,44,41,38,248,22,134,16,23,204,1,11,28, +23,193,2,27,250,22,160,2,248,22,81,23,198,1,197,11,28,192,250,22,158, +2,248,22,164,17,199,197,195,12,12,12,251,211,197,198,199,10,32,71,88,163, +36,38,47,11,76,102,108,97,116,116,101,110,45,115,117,98,45,112,97,116,104, +222,33,74,32,72,88,163,36,40,54,11,2,31,222,33,73,28,248,22,87,23, +197,2,28,248,22,87,195,192,249,22,79,194,248,22,94,197,28,249,22,154,9, +248,22,80,23,199,2,2,35,28,248,22,87,23,196,2,86,95,23,196,1,23, +195,1,250,22,185,9,2,22,6,37,37,116,111,111,32,109,97,110,121,32,34, +46,46,34,115,32,105,110,32,115,117,98,109,111,100,117,108,101,32,112,97,116, +104,58,32,126,46,115,250,22,90,2,34,28,249,22,154,9,23,201,2,2,36, +198,28,248,22,184,14,199,198,249,22,89,28,248,22,64,201,2,4,2,37,200, +199,251,2,72,196,197,248,22,81,199,248,22,164,17,200,251,2,72,196,197,249, +22,79,248,22,163,17,202,200,248,22,164,17,200,251,2,72,196,197,9,197,27, +249,22,165,7,6,31,31,115,116,97,110,100,97,114,100,45,109,111,100,117,108, +101,45,110,97,109,101,45,114,101,115,111,108,118,101,114,58,32,196,28,193,250, +22,187,9,11,195,196,248,22,185,9,193,28,249,22,148,7,194,2,36,2,28, +28,249,22,148,7,194,2,35,62,117,112,192,32,77,88,163,8,36,37,50,11, +67,115,115,45,62,114,107,116,222,33,78,27,248,22,145,7,194,28,249,22,131, +4,194,39,28,249,22,148,7,6,3,3,46,115,115,249,22,164,7,197,249,22, +183,3,198,39,249,22,165,7,250,22,164,7,198,36,249,22,183,3,199,39,2, +40,193,193,0,8,35,114,120,34,91,46,93,34,32,80,88,163,8,36,37,47, +11,2,31,222,33,81,28,248,22,87,23,194,2,9,250,22,90,6,4,4,10, +32,32,32,248,22,188,14,248,22,105,23,198,2,248,2,80,248,22,81,23,198, +1,28,249,22,154,9,248,22,81,23,200,2,23,197,1,28,249,22,152,9,248, +22,163,17,23,200,1,23,196,1,251,22,185,9,2,22,6,41,41,99,121,99, +108,101,32,105,110,32,108,111,97,100,105,110,103,10,32,32,97,116,32,112,97, +116,104,58,32,126,97,10,32,32,112,97,116,104,115,58,126,97,23,200,1,249, +22,1,22,165,7,248,2,80,248,22,94,23,201,1,12,12,247,192,20,13,159, +80,159,43,50,38,249,22,79,249,22,79,248,22,134,16,247,22,159,13,23,201, +1,23,195,1,20,13,159,80,159,43,38,37,250,80,159,46,39,37,249,22,33, +11,80,159,48,38,37,22,188,4,23,198,2,249,247,22,171,5,23,200,1,27, +248,22,67,248,22,188,14,23,201,1,28,23,202,2,28,250,22,160,2,248,22, +80,23,201,1,23,201,1,11,249,22,79,11,203,249,22,79,194,203,192,86,94, +28,248,22,156,5,23,196,2,12,28,23,197,2,250,22,187,9,11,6,15,15, +98,97,100,32,109,111,100,117,108,101,32,112,97,116,104,23,200,2,250,22,189, +9,2,22,2,33,23,198,2,28,28,248,22,77,23,196,2,249,22,152,9,248, +22,163,17,23,198,2,2,4,11,248,22,147,5,248,22,104,196,28,28,248,22, +77,23,196,2,28,249,22,152,9,248,22,163,17,23,198,2,2,34,28,248,22, +77,248,22,104,23,197,2,249,22,152,9,248,22,108,23,198,2,2,4,11,11, +11,86,97,23,198,1,23,197,1,23,196,1,23,193,1,248,22,147,5,249,2, +71,248,22,121,23,199,2,248,22,106,23,199,1,28,28,248,22,77,23,196,2, +28,249,22,152,9,248,22,163,17,23,198,2,2,34,28,28,249,22,154,9,248, +22,104,23,198,2,2,36,10,249,22,154,9,248,22,104,23,198,2,2,35,28, +23,196,2,27,248,22,148,5,23,198,2,28,248,22,64,193,10,28,248,22,77, +193,248,22,64,248,22,163,17,194,11,11,11,11,11,86,96,23,198,1,23,197, +1,23,193,1,27,248,22,148,5,23,198,1,248,22,147,5,249,2,71,28,248, +22,77,23,197,2,248,22,163,17,23,197,2,23,196,2,27,28,249,22,154,9, +248,22,104,23,203,2,2,35,248,22,164,17,200,248,22,106,200,28,248,22,77, +23,198,2,249,22,93,248,22,164,17,199,194,192,28,28,248,22,77,23,196,2, +249,22,152,9,248,22,163,17,23,198,2,2,38,11,86,94,248,80,159,38,8, +28,39,193,253,213,200,201,202,203,11,80,158,43,55,28,28,248,22,77,23,196, +2,28,249,22,152,9,248,22,163,17,23,198,2,2,34,28,248,22,77,248,22, +104,23,197,2,249,22,152,9,248,22,108,23,198,2,2,38,11,11,11,86,94, +248,80,159,38,8,28,39,193,253,213,248,22,104,201,201,202,203,248,22,106,201, +80,158,43,55,86,94,23,193,1,27,88,163,8,36,37,47,11,79,115,104,111, +119,45,99,111,108,108,101,99,116,105,111,110,45,101,114,114,223,5,33,75,27, +28,248,22,77,23,198,2,28,249,22,152,9,2,34,248,22,163,17,23,200,2, +27,248,22,104,23,199,2,28,28,249,22,154,9,23,195,2,2,36,10,249,22, +154,9,23,195,2,2,35,86,94,23,193,1,28,23,199,2,27,248,22,148,5, +23,201,2,28,248,22,77,193,248,22,163,17,193,192,250,22,185,9,2,22,6, +45,45,110,111,32,98,97,115,101,32,112,97,116,104,32,102,111,114,32,114,101, +108,97,116,105,118,101,32,115,117,98,109,111,100,117,108,101,32,112,97,116,104, +58,32,126,46,115,23,201,2,192,23,197,2,23,197,2,27,28,248,22,77,23, +199,2,28,249,22,152,9,2,34,248,22,163,17,23,201,2,27,28,28,28,249, +22,154,9,248,22,104,23,202,2,2,36,10,249,22,154,9,248,22,104,23,202, +2,2,35,23,200,2,11,27,248,22,148,5,23,202,2,27,28,249,22,154,9, +248,22,104,23,204,2,2,35,248,22,164,17,23,202,1,248,22,106,23,202,1, +28,248,22,77,23,195,2,249,2,71,248,22,163,17,23,197,2,249,22,93,248, +22,164,17,23,199,1,23,197,1,249,2,71,23,196,1,23,195,1,249,2,71, +2,36,28,249,22,154,9,248,22,104,23,204,2,2,35,248,22,164,17,23,202, +1,248,22,106,23,202,1,28,248,22,77,193,248,22,164,17,193,11,11,11,27, +28,248,22,64,23,196,2,27,248,80,159,43,48,39,249,22,79,23,199,2,247, +22,162,15,28,23,193,2,192,86,94,23,193,1,90,159,38,11,89,161,38,36, +11,249,80,159,46,54,39,248,22,70,23,201,2,11,27,28,248,22,87,23,195, +2,2,39,249,22,165,7,23,197,2,2,40,251,80,159,49,59,39,23,204,1, +28,248,22,87,23,199,2,23,199,1,86,94,23,199,1,248,22,80,23,199,2, +28,248,22,87,23,199,2,86,94,23,198,1,9,248,22,164,17,23,199,1,23, +197,1,28,248,22,142,7,23,196,2,86,94,23,196,1,27,248,80,159,43,8, +29,39,23,202,2,27,248,80,159,44,48,39,249,22,79,23,200,2,23,197,2, +28,23,193,2,192,86,94,23,193,1,90,159,38,11,89,161,38,36,11,249,80, +159,47,54,39,23,201,2,11,250,22,1,22,138,15,23,199,1,249,22,93,249, +22,2,32,0,88,163,8,36,37,44,11,9,222,33,76,23,200,1,248,22,89, +248,2,77,23,201,1,28,248,22,184,14,23,196,2,86,94,23,196,1,248,80, +159,42,8,30,39,248,22,147,15,28,248,22,144,15,23,198,2,23,197,2,249, +22,145,15,23,199,2,248,80,159,46,8,29,39,23,205,2,28,249,22,152,9, +248,22,80,23,198,2,2,32,27,248,80,159,43,48,39,249,22,79,23,199,2, +247,22,162,15,28,23,193,2,192,86,94,23,193,1,90,159,39,11,89,161,38, +36,11,249,80,159,47,54,39,248,22,104,23,202,2,11,89,161,37,38,11,28, +248,22,87,248,22,106,23,201,2,28,248,22,87,23,194,2,249,22,177,15,2, +79,23,196,2,11,10,27,28,23,196,2,248,2,77,23,196,2,28,248,22,87, +23,195,2,2,39,28,249,22,177,15,2,79,23,197,2,248,2,77,23,196,2, +249,22,165,7,23,197,2,2,40,27,28,23,197,1,86,94,23,196,1,249,22, +93,28,248,22,87,248,22,106,23,205,2,21,93,6,5,5,109,122,108,105,98, +249,22,1,22,93,249,22,2,80,159,53,8,31,39,248,22,106,23,208,2,23, +197,1,28,248,22,87,23,196,2,86,94,23,195,1,248,22,89,23,197,1,86, +94,23,196,1,23,195,1,251,80,159,51,59,39,23,206,1,248,22,80,23,198, +2,248,22,164,17,23,198,1,23,198,1,28,249,22,152,9,248,22,163,17,23, +198,2,2,37,248,80,159,42,8,30,39,248,22,147,15,249,22,145,15,248,22, +149,15,248,22,104,23,201,2,248,80,159,46,8,29,39,23,205,2,12,86,94, +28,28,248,22,184,14,23,194,2,10,248,22,167,8,23,194,2,86,94,23,201, +1,12,28,23,201,2,250,22,187,9,67,114,101,113,117,105,114,101,249,22,190, +7,6,17,17,98,97,100,32,109,111,100,117,108,101,32,112,97,116,104,126,97, +28,23,198,2,248,22,80,23,199,2,6,0,0,23,204,1,86,94,23,201,1, +250,22,189,9,2,22,2,33,23,198,2,27,28,248,22,167,8,23,195,2,249, +22,172,8,23,196,2,36,249,22,147,15,248,22,148,15,23,197,2,11,27,28, +248,22,167,8,23,196,2,249,22,172,8,23,197,2,37,248,80,159,44,8,24, +39,23,195,2,90,159,39,11,89,161,39,36,11,28,248,22,167,8,23,199,2, +250,22,7,2,41,249,22,172,8,23,203,2,38,2,41,248,22,141,15,23,198, +2,86,95,23,195,1,23,193,1,27,28,248,22,167,8,23,200,2,249,22,172, +8,23,201,2,39,249,80,159,49,58,39,23,197,2,5,0,27,28,248,22,167, +8,23,201,2,249,22,172,8,23,202,2,40,248,22,147,5,23,200,2,27,250, +22,160,2,80,159,52,41,38,248,22,134,16,247,22,159,13,11,27,28,23,194, +2,23,194,1,86,94,23,194,1,27,249,22,79,247,22,140,2,247,22,140,2, +86,94,250,22,158,2,80,159,54,41,38,248,22,134,16,247,22,159,13,195,192, +27,28,23,204,2,248,22,147,5,249,22,79,248,22,148,5,23,200,2,23,207, +2,23,196,2,86,95,28,23,212,1,27,250,22,160,2,248,22,80,23,199,2, +196,11,28,23,193,1,12,27,27,28,248,22,17,80,159,55,51,38,80,159,54, +51,38,247,22,19,251,22,33,11,80,159,58,50,38,9,23,197,1,27,248,22, +134,16,247,22,159,13,86,94,249,22,3,20,20,94,88,163,8,36,37,54,11, +9,226,14,13,2,3,33,82,23,195,1,23,196,2,248,28,248,22,17,80,159, +56,51,38,32,0,88,163,36,37,42,11,9,222,33,83,80,159,55,8,32,39, +20,20,96,88,163,36,36,56,8,240,12,64,0,0,9,230,19,15,13,12,8, +7,5,2,33,84,23,195,1,23,198,1,23,208,1,12,28,28,248,22,167,8, +23,204,1,11,28,248,22,142,7,23,206,2,10,28,248,22,64,23,206,2,10, +28,248,22,77,23,206,2,249,22,152,9,248,22,163,17,23,208,2,2,32,11, +249,80,159,53,49,39,28,248,22,142,7,23,208,2,249,22,79,23,209,1,248, +80,159,56,8,29,39,23,215,1,86,94,23,212,1,249,22,79,23,209,1,247, +22,162,15,252,22,169,8,23,209,1,23,208,1,23,206,1,23,204,1,23,203, +1,12,192,86,96,20,18,159,11,80,158,36,55,248,80,159,37,8,27,37,249, +22,33,11,80,159,39,57,37,248,22,187,4,80,159,37,56,38,248,22,171,5, +80,159,37,37,39,248,22,153,14,80,159,37,45,39,20,18,159,11,80,158,36, +55,248,80,159,37,8,27,37,249,22,33,11,80,159,39,57,37,20,18,159,11, +80,158,36,55,248,80,159,37,8,27,37,249,22,33,11,80,159,39,57,37,159, +36,20,113,159,36,16,1,11,16,0,20,26,144,9,2,1,2,1,29,11,11, +11,9,9,11,11,11,10,38,80,158,36,36,20,113,159,41,16,28,2,2,2, +3,30,2,6,2,7,11,6,30,2,6,1,23,101,120,116,101,110,100,45,112, +97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,11,3,30,2,8,72, +112,97,116,104,45,115,116,114,105,110,103,63,38,196,11,2,9,30,2,8,71, +114,101,114,111,111,116,45,112,97,116,104,40,196,12,30,2,8,75,112,97,116, +104,45,97,100,100,45,115,117,102,102,105,120,40,196,8,2,10,2,11,2,12, +2,13,2,14,2,15,2,16,2,17,2,18,2,19,2,20,2,21,2,22,30, +2,23,2,7,11,6,30,2,8,79,112,97,116,104,45,114,101,112,108,97,99, +101,45,115,117,102,102,105,120,40,196,10,30,2,8,73,102,105,110,100,45,99, +111,108,45,102,105,108,101,44,196,3,30,2,8,76,110,111,114,109,97,108,45, +99,97,115,101,45,112,97,116,104,38,196,7,2,24,2,25,30,2,23,74,114, +101,112,97,114,97,109,101,116,101,114,105,122,101,11,7,16,0,37,39,36,16, +0,36,16,15,2,16,2,17,2,9,2,13,2,18,2,19,2,12,2,3,2, +11,2,2,2,14,2,15,2,10,2,20,2,22,51,11,11,11,16,3,2,24, +2,21,2,25,16,3,11,11,11,16,3,2,24,2,21,2,25,39,39,37,12, +11,11,16,0,16,0,16,0,36,36,11,12,11,11,16,0,16,0,16,0,36, +36,16,23,20,15,16,2,248,22,164,8,69,115,111,45,115,117,102,102,105,120, +80,159,36,36,37,20,15,16,2,88,163,36,38,8,43,8,189,3,2,3,223, +0,33,54,80,159,36,37,37,20,15,16,2,32,0,88,163,8,36,41,52,11, +2,10,222,33,55,80,159,36,44,37,20,15,16,2,20,27,158,32,0,88,163, +8,36,37,42,11,2,11,222,192,32,0,88,163,8,36,37,42,11,2,11,222, +192,80,159,36,45,37,20,15,16,2,247,22,143,2,80,159,36,41,37,20,15, +16,2,8,128,8,80,159,36,46,37,20,15,16,2,249,22,168,8,8,128,8, +11,80,159,36,47,37,20,15,16,2,88,163,8,36,37,50,8,128,32,2,14, +223,0,33,56,80,159,36,48,37,20,15,16,2,88,163,8,36,38,55,8,128, +32,2,15,223,0,33,57,80,159,36,49,37,20,15,16,2,247,22,75,80,159, +36,50,37,20,15,16,2,248,22,18,74,109,111,100,117,108,101,45,108,111,97, +100,105,110,103,80,159,36,51,37,20,15,16,2,11,80,158,36,52,20,15,16, +2,11,80,158,36,53,20,15,16,2,32,0,88,163,36,38,8,25,11,2,20, +222,33,63,80,159,36,54,37,20,15,16,2,11,80,158,36,55,20,15,16,2, +88,164,8,34,37,45,8,240,0,0,40,0,1,21,112,114,101,112,45,112,108, +97,110,101,116,45,114,101,115,111,108,118,101,114,33,37,224,1,0,33,64,80, +159,36,8,28,39,20,15,16,2,88,163,36,37,50,8,240,0,0,3,0,67, +103,101,116,45,100,105,114,223,0,33,65,80,159,36,8,29,39,20,15,16,2, +88,163,36,37,49,8,240,0,0,64,0,72,112,97,116,104,45,115,115,45,62, +114,107,116,223,0,33,66,80,159,36,8,30,39,20,15,16,2,88,163,8,36, +37,45,8,240,0,0,4,0,9,223,0,33,67,80,159,36,8,31,39,20,15, +16,2,88,163,36,37,45,8,240,0,128,0,0,9,223,0,33,68,80,159,36, +8,32,39,20,15,16,2,27,11,20,19,158,36,90,159,37,10,89,161,37,36, +10,20,25,96,2,22,88,163,8,36,38,54,8,32,9,224,2,1,33,69,88, +163,36,39,49,11,9,223,0,33,70,88,163,36,40,8,32,16,4,8,240,44, +240,0,0,8,240,204,241,0,0,37,36,9,224,2,1,33,85,207,80,159,36, +56,37,20,15,16,2,88,163,36,36,45,16,2,8,130,8,8,184,32,2,24, +223,0,33,86,80,159,36,8,25,37,20,15,16,2,20,27,158,88,163,8,36, +36,45,16,2,36,8,168,32,2,25,223,0,33,87,88,163,8,36,36,45,16, +2,36,8,168,32,2,25,223,0,33,88,80,159,36,8,26,37,96,29,94,2, +4,68,35,37,107,101,114,110,101,108,11,29,94,2,4,69,35,37,109,105,110, +45,115,116,120,11,2,8,2,23,9,9,9,36,0}; + EVAL_ONE_SIZED_STR((char *)expr, 8518); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,52,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,51,46,49,46,53,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,11,0,0,0,1,0,0,10,0,16,0, 29,0,44,0,58,0,78,0,90,0,104,0,118,0,170,0,0,0,98,1,0, 0,69,35,37,98,117,105,108,116,105,110,65,113,117,111,116,101,29,94,2,2, diff --git a/src/racket/src/list.c b/src/racket/src/list.c index ffc4edc0e7..238998cf37 100644 --- a/src/racket/src/list.c +++ b/src/racket/src/list.c @@ -28,12 +28,20 @@ /* read only globals */ READ_ONLY Scheme_Object scheme_null[1]; +READ_ONLY Scheme_Object *scheme_pair_p_proc; +READ_ONLY Scheme_Object *scheme_mpair_p_proc; READ_ONLY Scheme_Object *scheme_cons_proc; READ_ONLY Scheme_Object *scheme_mcons_proc; READ_ONLY Scheme_Object *scheme_list_proc; READ_ONLY Scheme_Object *scheme_list_star_proc; READ_ONLY Scheme_Object *scheme_box_proc; +READ_ONLY Scheme_Object *scheme_box_p_proc; READ_ONLY Scheme_Object *scheme_hash_ref_proc; +READ_ONLY Scheme_Object *scheme_unsafe_car_proc; +READ_ONLY Scheme_Object *scheme_unsafe_cdr_proc; +READ_ONLY Scheme_Object *scheme_unsafe_mcar_proc; +READ_ONLY Scheme_Object *scheme_unsafe_mcdr_proc; +READ_ONLY Scheme_Object *scheme_unsafe_unbox_proc; /* read only locals */ ROSYM static Scheme_Object *weak_symbol; ROSYM static Scheme_Object *equal_symbol; @@ -177,15 +185,19 @@ scheme_init_list (Scheme_Env *env) scheme_add_global_constant ("null", scheme_null, env); + REGISTER_SO(scheme_pair_p_proc); p = scheme_make_folding_prim(pair_p_prim, "pair?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_OMITABLE); scheme_add_global_constant ("pair?", p, env); + scheme_pair_p_proc = p; + REGISTER_SO(scheme_mpair_p_proc); p = scheme_make_folding_prim(mpair_p_prim, "mpair?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_OMITABLE); scheme_add_global_constant ("mpair?", p, env); + scheme_mpair_p_proc = p; REGISTER_SO(scheme_cons_proc); p = scheme_make_immed_prim(cons_prim, "cons", 2, 2); @@ -436,10 +448,12 @@ scheme_init_list (Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_OMITABLE; scheme_add_global_constant("box-immutable", p, env); + REGISTER_SO(scheme_box_p_proc); p = scheme_make_folding_prim(box_p, BOXP, 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_OMITABLE); scheme_add_global_constant(BOXP, p, env); + scheme_box_p_proc = p; p = scheme_make_noncm_prim(unbox, UNBOX, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; @@ -738,15 +752,19 @@ scheme_init_unsafe_list (Scheme_Env *env) scheme_null->type = scheme_null_type; + REGISTER_SO(scheme_unsafe_car_proc); p = scheme_make_folding_prim(unsafe_car, "unsafe-car", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_add_global_constant ("unsafe-car", p, env); + scheme_unsafe_car_proc = p; + REGISTER_SO(scheme_unsafe_cdr_proc); p = scheme_make_folding_prim(unsafe_cdr, "unsafe-cdr", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_add_global_constant ("unsafe-cdr", p, env); + scheme_unsafe_cdr_proc = p; p = scheme_make_folding_prim(unsafe_list_ref, "unsafe-list-ref", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED @@ -758,17 +776,21 @@ scheme_init_unsafe_list (Scheme_Env *env) | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_add_global_constant ("unsafe-list-tail", p, env); + REGISTER_SO(scheme_unsafe_mcar_proc); p = scheme_make_immed_prim(unsafe_mcar, "unsafe-mcar", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE); scheme_add_global_constant ("unsafe-mcar", p, env); + scheme_unsafe_mcar_proc = p; + REGISTER_SO(scheme_unsafe_mcdr_proc); p = scheme_make_immed_prim(unsafe_mcdr, "unsafe-mcdr", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE); scheme_add_global_constant ("unsafe-mcdr", p, env); + scheme_unsafe_mcdr_proc = p; p = scheme_make_immed_prim(unsafe_set_mcar, "unsafe-set-mcar!", 2, 2); SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; @@ -778,11 +800,13 @@ scheme_init_unsafe_list (Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; scheme_add_global_constant ("unsafe-set-mcdr!", p, env); + REGISTER_SO(scheme_unsafe_unbox_proc); p = scheme_make_immed_prim(unsafe_unbox, "unsafe-unbox", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_OMITABLE | SCHEME_PRIM_IS_OMITABLE); scheme_add_global_constant("unsafe-unbox", p, env); + scheme_unsafe_unbox_proc = p; p = scheme_make_immed_prim(unsafe_unbox_star, "unsafe-unbox*", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED diff --git a/src/racket/src/mzmarksrc.c b/src/racket/src/mzmarksrc.c index 933eb7a714..9d6e841ac5 100644 --- a/src/racket/src/mzmarksrc.c +++ b/src/racket/src/mzmarksrc.c @@ -1310,6 +1310,7 @@ mark_optimize_info { gcMARK2(i->transitive_use_len, gc); gcMARK2(i->context, gc); gcMARK2(i->logger, gc); + gcMARK2(i->types, gc); size: gcBYTES_TO_WORDS(sizeof(Optimize_Info)); diff --git a/src/racket/src/optimize.c b/src/racket/src/optimize.c index bfa1eee813..c02fa123e2 100644 --- a/src/racket/src/optimize.c +++ b/src/racket/src/optimize.c @@ -74,6 +74,7 @@ struct Optimize_Info Scheme_Object *context; /* for logging */ Scheme_Logger *logger; + Scheme_Hash_Tree *types; /* maps position (from this frame) to predicate */ }; static char *get_closure_flonum_map(Scheme_Closure_Data *data, int arg_n, int *ok); @@ -91,6 +92,8 @@ static Scheme_Object *optimize_info_lookup(Optimize_Info *info, int pos, int *cl int once_used_ok, int context, int *potential_size, int *_mutated); static Scheme_Object *optimize_info_mutated_lookup(Optimize_Info *info, int pos, int *is_mutated); static void optimize_info_used_top(Optimize_Info *info); +static Scheme_Object *optimize_get_predicate(int pos, Optimize_Info *info); +static void add_type(Optimize_Info *info, int pos, Scheme_Object *pred); static void optimize_mutated(Optimize_Info *info, int pos); static void optimize_produces_flonum(Optimize_Info *info, int pos); @@ -2251,6 +2254,28 @@ static Scheme_Object *lookup_constant_proc(Optimize_Info *info, Scheme_Object *r return NULL; } +static void check_known2(Optimize_Info *info, Scheme_App2_Rec *app, const char *who, + Scheme_Object *expect_pred, Scheme_Object *unsafe) +/* Replace the rator with an unsafe version if we know that it's ok. Alternatively, + the rator implies a check, so add type information for subsequent expressions. */ +{ + if (IS_NAMED_PRIM(app->rator, who)) { + if (SAME_TYPE(SCHEME_TYPE(app->rand), scheme_local_type)) { + Scheme_Object *pred; + int pos = SCHEME_LOCAL_POS(app->rand); + + if (optimize_is_mutated(info, pos)) + return; + + pred = optimize_get_predicate(pos, info); + if (pred && SAME_OBJ(pred, expect_pred)) + app->rator = unsafe; + else + add_type(info, pos, expect_pred); + } + } +} + static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *info, int context) { Scheme_App2_Rec *app; @@ -2413,6 +2438,14 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz } } } + } else { + check_known2(info, app, "car", scheme_pair_p_proc, scheme_unsafe_car_proc); + check_known2(info, app, "cdr", scheme_pair_p_proc, scheme_unsafe_cdr_proc); + check_known2(info, app, "mcar", scheme_mpair_p_proc, scheme_unsafe_mcar_proc); + check_known2(info, app, "mcdr", scheme_mpair_p_proc, scheme_unsafe_mcdr_proc); + /* It's not clear that these are useful, since a chaperone check is needed anyway: */ + check_known2(info, app, "unbox", scheme_box_p_proc, scheme_unsafe_unbox_proc); + check_known2(info, app, "vector-length", scheme_vector_p_proc, scheme_unsafe_vector_length_proc); } if (alt) { @@ -2849,10 +2882,55 @@ static int equivalent_exprs(Scheme_Object *a, Scheme_Object *b) return 0; } +static void add_type(Optimize_Info *info, int pos, Scheme_Object *pred) +{ + Scheme_Hash_Tree *new_types; + new_types = info->types; + if (!new_types) + new_types = scheme_make_hash_tree(0); + new_types = scheme_hash_tree_set(new_types, + scheme_make_integer(pos), + pred); + info->types = new_types; +} + +static int relevant_predicate(Scheme_Object *pred) +{ + return (SAME_OBJ(pred, scheme_pair_p_proc) + || SAME_OBJ(pred, scheme_mpair_p_proc) + || SAME_OBJ(pred, scheme_box_p_proc) + || SAME_OBJ(pred, scheme_vector_p_proc)); +} + +static void add_types(Scheme_Object *t, Optimize_Info *info, int fuel) +{ + if (fuel < 0) + return; + + if (SAME_TYPE(SCHEME_TYPE(t), scheme_application2_type)) { + Scheme_App2_Rec *app = (Scheme_App2_Rec *)t; + if (SCHEME_PRIMP(app->rator) + && SAME_TYPE(SCHEME_TYPE(app->rand), scheme_local_type) + && relevant_predicate(app->rator)) { + /* Looks like a predicate on a local variable. Record that the + predicate succeeded, which may allow conversion of safe + operations to unsafe operations. */ + add_type(info, SCHEME_LOCAL_POS(app->rand), app->rator); + } + } else if (SAME_TYPE(SCHEME_TYPE(t), scheme_branch_type)) { + Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)t; + if (SCHEME_FALSEP(b->fbranch)) { + add_types(b->test, info, fuel-1); + add_types(b->tbranch, info, fuel-1); + } + } +} + static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int context) { Scheme_Branch_Rec *b; Scheme_Object *t, *tb, *fb; + Scheme_Hash_Tree *old_types; int preserves_marks = 1, single_result = 1; b = (Scheme_Branch_Rec *)o; @@ -2907,6 +2985,9 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int return scheme_optimize_expr(tb, info, scheme_optimize_tail_context(context)); } + old_types = info->types; + add_types(t, info, 5); + tb = scheme_optimize_expr(tb, info, scheme_optimize_tail_context(context)); if (!info->preserves_marks) @@ -2918,6 +2999,8 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int else if (info->single_result < 0) single_result = -1; + info->types = old_types; + fb = scheme_optimize_expr(fb, info, scheme_optimize_tail_context(context)); if (!info->preserves_marks) @@ -6347,7 +6430,7 @@ static int optimize_is_used(Optimize_Info *info, int pos) static int check_use(Optimize_Info *info, int pos, int flag) /* pos is in new-frame counts */ { - while (1) { + while (info) { if (pos < info->new_frame) break; pos -= info->new_frame; @@ -6556,6 +6639,25 @@ static Scheme_Object *optimize_info_mutated_lookup(Optimize_Info *info, int pos, return do_optimize_info_lookup(info, pos, 0, NULL, NULL, NULL, 0, 0, NULL, 0, is_mutated, 1); } +Scheme_Object *optimize_get_predicate(int pos, Optimize_Info *info) +{ + Scheme_Object *pred; + + while (info) { + if (info->types) { + pred = scheme_hash_tree_get(info->types, scheme_make_integer(pos)); + if (pred) + return pred; + } + pos -= info->new_frame; + if (pos < 0) + return NULL; + info = info->next; + } + + return NULL; +} + static Optimize_Info *optimize_info_add_frame(Optimize_Info *info, int orig, int current, int flags) { Optimize_Info *naya; diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index 9620c62046..fb9ecc3d4d 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -359,15 +359,25 @@ extern Scheme_Object *scheme_values_func; extern Scheme_Object *scheme_procedure_p_proc; extern Scheme_Object *scheme_procedure_arity_includes_proc; extern Scheme_Object *scheme_void_proc; +extern Scheme_Object *scheme_pair_p_proc; +extern Scheme_Object *scheme_mpair_p_proc; +extern Scheme_Object *scheme_unsafe_car_proc; +extern Scheme_Object *scheme_unsafe_cdr_proc; +extern Scheme_Object *scheme_unsafe_mcar_proc; +extern Scheme_Object *scheme_unsafe_mcdr_proc; +extern Scheme_Object *scheme_unsafe_unbox_proc; extern Scheme_Object *scheme_cons_proc; extern Scheme_Object *scheme_mcons_proc; extern Scheme_Object *scheme_list_proc; extern Scheme_Object *scheme_list_star_proc; extern Scheme_Object *scheme_vector_proc; +extern Scheme_Object *scheme_vector_p_proc; extern Scheme_Object *scheme_vector_immutable_proc; extern Scheme_Object *scheme_vector_ref_proc; extern Scheme_Object *scheme_vector_set_proc; +extern Scheme_Object *scheme_unsafe_vector_length_proc; extern Scheme_Object *scheme_hash_ref_proc; +extern Scheme_Object *scheme_box_p_proc; extern Scheme_Object *scheme_box_proc; extern Scheme_Object *scheme_call_with_values_proc; extern Scheme_Object *scheme_make_struct_type_proc; diff --git a/src/racket/src/schvers.h b/src/racket/src/schvers.h index 22d1890104..a094996869 100644 --- a/src/racket/src/schvers.h +++ b/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "5.3.1.4" +#define MZSCHEME_VERSION "5.3.1.5" #define MZSCHEME_VERSION_X 5 #define MZSCHEME_VERSION_Y 3 #define MZSCHEME_VERSION_Z 1 -#define MZSCHEME_VERSION_W 4 +#define MZSCHEME_VERSION_W 5 #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/vector.c b/src/racket/src/vector.c index 8a3faa3321..10b1833dde 100644 --- a/src/racket/src/vector.c +++ b/src/racket/src/vector.c @@ -28,9 +28,11 @@ /* globals */ READ_ONLY Scheme_Object *scheme_vector_proc; +READ_ONLY Scheme_Object *scheme_vector_p_proc; READ_ONLY Scheme_Object *scheme_vector_immutable_proc; READ_ONLY Scheme_Object *scheme_vector_ref_proc; READ_ONLY Scheme_Object *scheme_vector_set_proc; +READ_ONLY Scheme_Object *scheme_unsafe_vector_length_proc; /* locals */ static Scheme_Object *vector_p (int argc, Scheme_Object *argv[]); @@ -49,6 +51,7 @@ static Scheme_Object *impersonate_vector(int argc, Scheme_Object **argv); static Scheme_Object *unsafe_vector_len (int argc, Scheme_Object *argv[]); static Scheme_Object *unsafe_vector_ref (int argc, Scheme_Object *argv[]); +static Scheme_Object *unsafe_vector_ref_star (int argc, Scheme_Object *argv[]); static Scheme_Object *unsafe_vector_set (int argc, Scheme_Object *argv[]); static Scheme_Object *unsafe_vector_star_len (int argc, Scheme_Object *argv[]); static Scheme_Object *unsafe_vector_star_ref (int argc, Scheme_Object *argv[]); @@ -69,10 +72,12 @@ scheme_init_vector (Scheme_Env *env) { Scheme_Object *p; + REGISTER_SO(scheme_vector_p_proc); p = scheme_make_folding_prim(vector_p, "vector?", 1, 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_OMITABLE); scheme_add_global_constant("vector?", p, env); + scheme_vector_p_proc = p; scheme_add_global_constant("make-vector", scheme_make_immed_prim(make_vector, @@ -167,10 +172,12 @@ scheme_init_unsafe_vector (Scheme_Env *env) { Scheme_Object *p; + REGISTER_SO(scheme_unsafe_vector_length_proc); p = scheme_make_immed_prim(unsafe_vector_len, "unsafe-vector-length", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_add_global_constant("unsafe-vector-length", p, env); + scheme_unsafe_vector_length_proc = p; p = scheme_make_immed_prim(unsafe_vector_star_len, "unsafe-vector*-length", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED From ab5bbb5b3705a81ac2260c27fe3714f1c9787046 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 6 Nov 2012 18:47:37 -0700 Subject: [PATCH 198/221] flatten simple `define-values' within a module This flattening is useful for the definition of `assq', for example. --- collects/tests/racket/optimize.rktl | 33 ++++++ src/racket/src/optimize.c | 152 ++++++++++++++++++++++++++++ 2 files changed, 185 insertions(+) diff --git a/collects/tests/racket/optimize.rktl b/collects/tests/racket/optimize.rktl index 8bfffb6abc..3347adb1d8 100644 --- a/collects/tests/racket/optimize.rktl +++ b/collects/tests/racket/optimize.rktl @@ -1911,6 +1911,39 @@ (list (c? (c-q (c 1 2 3)))) 5))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Check splitting of definitions +(test-comp `(module m racket/base + (define-values (x y) (values 1 2))) + `(module m racket/base + (define x 1) + (define y 2))) +(test-comp `(module m racket/base + (define-values (x y z w) (values 1 2 4 5))) + `(module m racket/base + (define x 1) + (define y 2) + (define z 4) + (define w 5))) +(test-comp `(module m racket/base + (define-values (x y) + (let ([x (lambda (x) x)] + [y (lambda (x y) y)]) + (values x y)))) + `(module m racket/base + (define x (lambda (x) x)) + (define y (lambda (x y) y)))) +(test-comp `(module m racket/base + (define-values (x y z) + (let ([x (lambda (x) x)] + [y (lambda (x y) y)] + [z (lambda (x y z) z)]) + (values x y z)))) + `(module m racket/base + (define x (lambda (x) x)) + (define y (lambda (x y) y)) + (define z (lambda (x y z) z)))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Check bytecode verification of lifted functions diff --git a/src/racket/src/optimize.c b/src/racket/src/optimize.c index c02fa123e2..4faced20d1 100644 --- a/src/racket/src/optimize.c +++ b/src/racket/src/optimize.c @@ -5079,6 +5079,115 @@ static int is_general_compiled_proc(Scheme_Object *e, Optimize_Info *info) return 0; } +void install_definition(Scheme_Object *vec, int pos, Scheme_Object *var, Scheme_Object *rhs) +{ + Scheme_Object *def; + + var = scheme_make_pair(var, scheme_null); + def = scheme_make_vector(2, NULL); + SCHEME_VEC_ELS(def)[0] = var; + SCHEME_VEC_ELS(def)[1] = rhs; + def->type = scheme_define_values_type; + + SCHEME_VEC_ELS(vec)[pos] = def; +} + +int split_define_values(Scheme_Object *e, int n, Scheme_Object *vars, Scheme_Object *vec, int offset) +{ + if (SAME_TYPE(SCHEME_TYPE(e), scheme_compiled_let_void_type)) { + /* This is a tedious case to recognize the pattern + (let ([x rhs] ...) (values x ...)) + which might be the result of expansion that involved a local + macro to define the `x's */ + Scheme_Let_Header *lh = (Scheme_Let_Header *)e; + if ((lh->count == n) && (lh->num_clauses == n) + && !(SCHEME_LET_FLAGS(lh) & (SCHEME_LET_RECURSIVE | SCHEME_LET_STAR))) { + Scheme_Object *body = lh->body; + int i; + for (i = 0; i < n; i++) { + if (SAME_TYPE(SCHEME_TYPE(body), scheme_compiled_let_value_type)) { + Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)body; + if (lv->count == 1) { + if (!scheme_omittable_expr(lv->value, 1, 5, 0, NULL, NULL, n, 0)) + return 0; + body = lv->body; + } else + return 0; + } else + return 0; + } + if ((n == 2) && SAME_TYPE(SCHEME_TYPE(body), scheme_application3_type)) { + Scheme_App3_Rec *app = (Scheme_App3_Rec *)body; + if (SAME_OBJ(app->rator, scheme_values_func) + && SAME_TYPE(SCHEME_TYPE(app->rand1), scheme_local_type) + && (SCHEME_LOCAL_POS(app->rand1) == 0) + && SAME_TYPE(SCHEME_TYPE(app->rand2), scheme_local_type) + && (SCHEME_LOCAL_POS(app->rand2) == 1)) { + if (vars) { + Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body; + install_definition(vec, offset, SCHEME_CAR(vars), lv->value); + vars = SCHEME_CDR(vars); + lv = (Scheme_Compiled_Let_Value *)lv->body; + install_definition(vec, offset+1, SCHEME_CAR(vars), lv->value); + } + return 1; + } + } else if (SAME_TYPE(SCHEME_TYPE(body), scheme_application_type) + && ((Scheme_App_Rec *)body)->num_args == n) { + Scheme_App_Rec *app = (Scheme_App_Rec *)body; + if (SAME_OBJ(app->args[0], scheme_values_func)) { + for (i = 0; i < n; i++) { + if (!SAME_TYPE(SCHEME_TYPE(app->args[i+1]), scheme_local_type) + || SCHEME_LOCAL_POS(app->args[i+1]) != i) + return 0; + } + if (vars) { + body = lh->body; + for (i = 0; i < n; i++) { + Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)body; + install_definition(vec, offset+i, SCHEME_CAR(vars), lv->value); + vars = SCHEME_CDR(vars); + body = lv->body; + } + } + return 1; + } + } + } + } else if ((n == 2) && SAME_TYPE(SCHEME_TYPE(e), scheme_application3_type)) { + Scheme_App3_Rec *app = (Scheme_App3_Rec *)e; + if (SAME_OBJ(app->rator, scheme_values_func) + && scheme_omittable_expr(app->rand1, 1, 5, 0, NULL, NULL, 0, 0) + && scheme_omittable_expr(app->rand2, 1, 5, 0, NULL, NULL, 0, 0)) { + if (vars) { + install_definition(vec, offset, SCHEME_CAR(vars), app->rand1); + vars = SCHEME_CDR(vars); + install_definition(vec, offset+1, SCHEME_CAR(vars), app->rand2); + } + return 1; + } + } else if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type) + && ((Scheme_App_Rec *)e)->num_args == n) { + Scheme_App_Rec *app = (Scheme_App_Rec *)e; + if (SAME_OBJ(app->args[0], scheme_values_func)) { + int i; + for (i = 0; i < n; i++) { + if (!scheme_omittable_expr(app->args[i+1], 1, 5, 0, NULL, NULL, 0, 0)) + return 0; + } + if (vars) { + for (i = 0; i < n; i++) { + install_definition(vec, offset+i, SCHEME_CAR(vars), app->args[i+1]); + vars = SCHEME_CDR(vars); + } + } + return 1; + } + } + + return 0; +} + static Scheme_Object * module_optimize(Scheme_Object *data, Optimize_Info *info, int context) { @@ -5104,6 +5213,49 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) cnt = SCHEME_VEC_SIZE(m->bodies[0]); + /* First, flatten `(define-values (x ...) (values e ...))' + to `(define (x) e) ...' when possible. */ + { + int inc = 0; + for (i_m = 0; i_m < cnt; i_m++) { + e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; + if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { + int n; + vars = SCHEME_VEC_ELS(e)[0]; + n = scheme_list_length(vars); + if (n > 1) { + e = SCHEME_VEC_ELS(e)[1]; + if (split_define_values(e, n, NULL, NULL, 0)) + inc += (n - 1); + } + } + } + + if (inc > 0) { + Scheme_Object *new_vec; + int j = 0; + new_vec = scheme_make_vector(cnt+inc, NULL); + for (i_m = 0; i_m < cnt; i_m++) { + e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; + if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { + int n; + vars = SCHEME_VEC_ELS(e)[0]; + n = scheme_list_length(vars); + if (n > 1) { + if (split_define_values(SCHEME_VEC_ELS(e)[1], n, vars, new_vec, j)) { + j += n; + } else + SCHEME_VEC_ELS(new_vec)[j++] = e; + } else + SCHEME_VEC_ELS(new_vec)[j++] = e; + } else + SCHEME_VEC_ELS(new_vec)[j++] = e; + } + cnt += inc; + m->bodies[0] = new_vec; + } + } + if (OPT_ESTIMATE_FUTURE_SIZES) { if (info->enforce_const) { /* For each identifier bound to a procedure, register an initial From 891932074c3d2c022b6f070214fa4ff88920b2cd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 7 Nov 2012 05:47:08 -0700 Subject: [PATCH 199/221] adjust run length of short R5RS benchmarks --- collects/tests/racket/benchmarks/common/conform.sch | 2 +- collects/tests/racket/benchmarks/common/destruct.sch | 2 +- collects/tests/racket/benchmarks/common/peval.sch | 2 +- collects/tests/racket/benchmarks/common/scheme.sch | 2 +- collects/tests/racket/benchmarks/common/scheme2.sch | 2 +- 5 files changed, 5 insertions(+), 5 deletions(-) diff --git a/collects/tests/racket/benchmarks/common/conform.sch b/collects/tests/racket/benchmarks/common/conform.sch index dadcc5d91f..2545109c1e 100644 --- a/collects/tests/racket/benchmarks/common/conform.sch +++ b/collects/tests/racket/benchmarks/common/conform.sch @@ -612,7 +612,7 @@ ;(go) ;(exit) -(time (let loop ((n 10)) +(time (let loop ((n 100)) (if (zero? n) 'done (begin diff --git a/collects/tests/racket/benchmarks/common/destruct.sch b/collects/tests/racket/benchmarks/common/destruct.sch index bbc4473e81..1b59adaf30 100644 --- a/collects/tests/racket/benchmarks/common/destruct.sch +++ b/collects/tests/racket/benchmarks/common/destruct.sch @@ -62,7 +62,7 @@ ;;; call: (destructive 600 50) (let ((input (with-input-from-file "input.txt" read))) - (time (let loop ((n 10) (v 0)) + (time (let loop ((n 100) (v 0)) (if (zero? n) 'v (loop (- n 1) diff --git a/collects/tests/racket/benchmarks/common/peval.sch b/collects/tests/racket/benchmarks/common/peval.sch index 40d5047170..719315172e 100644 --- a/collects/tests/racket/benchmarks/common/peval.sch +++ b/collects/tests/racket/benchmarks/common/peval.sch @@ -627,7 +627,7 @@ (let ((input (with-input-from-file "input.txt" read))) (time - (let loop ((n 60) (v 0)) + (let loop ((n 600) (v 0)) (if (zero? n) v (loop (- n 1) (test (if input 0 17))))))) diff --git a/collects/tests/racket/benchmarks/common/scheme.sch b/collects/tests/racket/benchmarks/common/scheme.sch index ac891d530d..f464218ab3 100644 --- a/collects/tests/racket/benchmarks/common/scheme.sch +++ b/collects/tests/racket/benchmarks/common/scheme.sch @@ -1071,7 +1071,7 @@ (let ((input (with-input-from-file "input.txt" read))) (time - (let loop ((n 3000) (v 0)) + (let loop ((n 30000) (v 0)) (if (zero? n) v (loop (- n 1) (scheme-eval (if input expr1 '(+ 1 2)))))))) diff --git a/collects/tests/racket/benchmarks/common/scheme2.sch b/collects/tests/racket/benchmarks/common/scheme2.sch index 01322f7d06..87a611770f 100644 --- a/collects/tests/racket/benchmarks/common/scheme2.sch +++ b/collects/tests/racket/benchmarks/common/scheme2.sch @@ -1083,7 +1083,7 @@ (let ((input (with-input-from-file "input.txt" read))) (time - (let loop ((n 3000) (v 0)) + (let loop ((n 30000) (v 0)) (if (zero? n) v (loop (- n 1) (scheme-eval (if input expr1 '(+ 1 2)))))))) From d2256e23e01b8606aa6d7a59f742539ccd7fecc2 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 7 Nov 2012 09:43:57 -0500 Subject: [PATCH 200/221] Another email for Matthew. --- .mailmap | 1 + 1 file changed, 1 insertion(+) diff --git a/.mailmap b/.mailmap index ac4210bdd8..c5e6f1401e 100644 --- a/.mailmap +++ b/.mailmap @@ -11,6 +11,7 @@ Matthew Flatt Matthew Flatt Matthew Flatt Matthew Flatt +Matthew Flatt Kathy Gray Kathy Gray Matthias Felleisen From 672910f27b856549ad08d38832b6714edf226c8e Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 7 Nov 2012 10:42:42 -0500 Subject: [PATCH 201/221] Lots of bad TAB eliminations. I started from tabs that are not on the beginning of lines, and in several places I did further cleanings. If you're worried about knowing who wrote some code, for example, if you get to this commit in "git blame", then note that you can use the "-w" flag in many git commands to ignore whitespaces. For example, to see per-line authors, use "git blame -w ". Another example: to see the (*much* smaller) non-whitespace changes in this (or any other) commit, use "git log -p -w -1 ". --- collects/2htdp/private/design.txt | 22 +- collects/2htdp/uchat/chatter.rkt | 26 +- collects/2htdp/uchat/readme | 68 +- collects/browser/private/html.rkt | 2 +- collects/compiler/embed.rkt | 21 +- collects/db/private/odbc/ffi-constants.rkt | 2 +- collects/deinprogramm/DMdA.rkt | 2 +- collects/deinprogramm/run-dmda-code.rkt | 2 +- collects/deinprogramm/world.rkt | 4 +- collects/drracket/private/rep.rkt | 8 +- collects/drracket/private/text.rkt | 26 +- collects/dynext/link-unit.rkt | 4 +- collects/ffi/unsafe/atomic.rkt | 2 +- collects/ffi/unsafe/com.rkt | 520 ++++++------- collects/ffi/unsafe/objc.rkt | 4 +- collects/ffi/unsafe/private/win32.rkt | 74 +- collects/file/gunzip.rkt | 2 +- collects/file/sha1.rkt | 2 +- collects/framework/private/keymap.rkt | 4 +- collects/framework/private/racket.rkt | 2 +- collects/framework/test.rkt | 2 +- collects/games/cards/classes.rkt | 4 +- collects/games/gobblet/model.rkt | 2 +- collects/games/gobblet/test-model.rkt | 2 +- collects/games/jewel/shapes.scm | 4 +- collects/games/paint-by-numbers/solve.rkt | 700 +++++++++--------- collects/graphics/graphics-posn-less-unit.rkt | 4 +- collects/graphics/turtle-test.rkt | 2 +- collects/gui-debugger/TODO.txt | 8 +- collects/gui-debugger/debug-tool.rkt | 8 +- collects/htdp/hangman.rkt | 8 +- collects/htdp/matrix.txt | 36 +- collects/htdp/world.rkt | 4 +- collects/lang/htdp-beginner-abbr.rkt | 10 +- collects/lang/htdp-beginner.rkt | 10 +- collects/lang/htdp-intermediate-lambda.rkt | 10 +- collects/lang/htdp-intermediate.rkt | 10 +- collects/lang/private/advanced-funs.rkt | 140 ++-- .../lang/private/continuation-mark-key.rkt | 2 +- collects/lang/private/teach.rkt | 6 +- collects/mred/private/moredialogs.rkt | 2 +- collects/mred/private/mrcanvas.rkt | 7 +- collects/mred/private/wx/cocoa/agl.rkt | 12 +- collects/mred/private/wx/gtk/types.rkt | 22 +- collects/mred/private/wx/gtk/window.rkt | 264 +++---- collects/mred/private/wx/win32/types.rkt | 46 +- .../mrlib/scribblings/switchable-button.scrbl | 2 +- collects/mysterx/mysterx.rkt | 8 +- collects/mzscheme/installer.rkt | 2 +- collects/parser-tools/private-yacc/graph.rkt | 87 +-- collects/parser-tools/private-yacc/lalr.rkt | 84 +-- collects/parser-tools/private-yacc/lr0.rkt | 338 ++++----- .../picturing-programs.scrbl | 40 +- collects/planet/planet.scrbl | 4 +- collects/planet/private/util.scrbl | 46 +- collects/plot/common/date-time.rkt | 92 +-- collects/r6rs/private/records-explicit.rkt | 12 +- collects/racket/draw/unsafe/jpeg.rkt | 10 +- collects/racket/future.rkt | 10 +- collects/rackunit/scribblings/check.scrbl | 12 +- collects/redex/private/compiler/match.rkt | 10 +- collects/redex/scribblings/tut.scrbl | 2 +- collects/redex/tests/check-syntax-test.rkt | 18 +- collects/scribblings/framework/splash.scrbl | 2 +- .../guide/contracts-examples/ho-version3.rkt | 4 +- .../htdp-langs/beginner-abbr.scrbl | 2 +- collects/scribblings/reference/generic.scrbl | 4 +- collects/scribblings/tools/tools.scrbl | 16 +- collects/sgl/examples/alpha.rkt | 12 +- collects/sirmail/readr.rkt | 16 +- collects/srfi/14/char-set.rkt | 218 +++--- collects/srfi/19/time.rkt | 8 +- collects/srfi/2/and-let.rkt | 64 +- collects/srfi/25/array.rkt | 2 +- .../private/german-string-constants.rkt | 6 +- .../private/korean-string-constants.rkt | 4 +- .../2htdp/scribblings/universe.scrbl | 517 +++++++------ collects/test-engine/test-display.scm | 488 ++++++------ collects/tests/deinprogramm/image.rkt | 542 +++++++------- .../chapter3/lexaddr-lang/environments.rkt | 6 +- .../tests/eopl/chapter9/classes/tests.rkt | 2 +- collects/tests/gracket/mem.rkt | 319 ++++---- collects/tests/r6rs/test.sls | 6 +- collects/tests/racket/basic.rktl | 14 +- .../racket/benchmarks/shootout/nsievebits.rkt | 2 +- collects/tests/racket/contract-test.rktl | 2 +- collects/tests/racket/control.rktl | 26 +- collects/tests/racket/param.rktl | 2 +- collects/tests/racket/struct.rktl | 2 +- collects/tests/srfi/13/string-test.rkt | 40 +- collects/tests/srfi/2/and-let-test.rkt | 183 +++-- collects/tests/stepper/test-cases.rkt | 8 +- collects/texpict/private/texpict-extra.rkt | 4 +- collects/unstable/scribblings/syntax.scrbl | 10 +- .../scribblings/tutorial/continue.scrbl | 2 +- doc/release-notes/teachpack/HISTORY.txt | 286 ++++--- 96 files changed, 2847 insertions(+), 2871 deletions(-) diff --git a/collects/2htdp/private/design.txt b/collects/2htdp/private/design.txt index 838f645f01..a9d7c6b259 100644 --- a/collects/2htdp/private/design.txt +++ b/collects/2htdp/private/design.txt @@ -1,17 +1,15 @@ +Files for constructing universe.rkt: -Files for constructing universe.rkt: + world.rkt the old world + world% = (clock-mixin ...) -- the basic world + aworld% = (class world% ...) -- the world with recording - world.rkt the old world - world% = (clock-mixin ...) -- the basic world - aworld% = (class world% ...) -- the world with recording - - universe.rkt the universe server - universe% = (clock-mixin ...) -- the basic universe + universe.rkt the universe server + universe% = (clock-mixin ...) -- the basic universe timer.rkt the clock-mixin - check-aux.rkt common primitives - image.rkt the world image functions - clauses-spec-and-process.rkt syntactic auxiliaries - clauses-spec-aux.rkt auxiliaries to the syntactic auxiliaries - + check-aux.rkt common primitives + image.rkt the world image functions + clauses-spec-and-process.rkt syntactic auxiliaries + clauses-spec-aux.rkt auxiliaries to the syntactic auxiliaries diff --git a/collects/2htdp/uchat/chatter.rkt b/collects/2htdp/uchat/chatter.rkt index bfefc0a6a2..2ca1f4c1a8 100644 --- a/collects/2htdp/uchat/chatter.rkt +++ b/collects/2htdp/uchat/chatter.rkt @@ -8,15 +8,15 @@ #| +------------------------------------------------------------------+ - | from: text text text text text text | - | from*: text text text text text text | - | ... | - | ... | + | from: text text text text text text | + | from*: text text text text text text | + | ... | + | ... | +------------------------------------------------------------------+ - | to: text text text text text text | - | *: text text text text text text | - | to2: text blah text[] | - | ... | + | to: text text text text text text | + | *: text text text text text text | + | to2: text blah text[] | + | ... | +------------------------------------------------------------------+ Convention: the names of participants may not contain ":". @@ -88,11 +88,11 @@ ;; World -> Scene ;; render the world as a scene (define (render w) - (local ((define fr (line*-render (world-from w))) + (local [(define fr (line*-render (world-from w))) (define t1 (line*-render (world-to w))) (define last-to-line - (line-render-cursor (world-todraft w) (world-mmdraft w))) - (define tt (image-stack t1 last-to-line))) + (line-render-cursor (world-todraft w) (world-mmdraft w))) + (define tt (image-stack t1 last-to-line))] (place-image fr 1 1 (place-image tt 1 MID MT)))) ;; ----------------------------------------------------------------------------- @@ -355,7 +355,7 @@ [(too-wide? to-new mm) (send to "" from* to*)] [else (world-todraft! w to-new)]))] ; [(and (boolean? to) (string? mm)) (error 'react "can't happen")] - [else ; (and (string? to) (string? mm)) + [else ; (and (string? to) (string? mm)) ;; the key belongs into the message text (local ((define new-mm (string-append mm key))) (cond @@ -483,7 +483,7 @@ (on-receive receive) (check-with world?) (name n) - (state true) + (state true) (register LOCALHOST))) (define (run* _) diff --git a/collects/2htdp/uchat/readme b/collects/2htdp/uchat/readme index 1ab168baa9..ea76213edb 100644 --- a/collects/2htdp/uchat/readme +++ b/collects/2htdp/uchat/readme @@ -1,5 +1,5 @@ - Chit Chat - --------- + Chit Chat + --------- Design and implement a universe program that allows people to chat with each other, using short messages. @@ -11,13 +11,13 @@ A participant uses a chat space, which is a window divided into two spaces: The two halves display the messages in historical order, with the most recent message received/sent at the bottom. When either half is full of - messages, drop the least recent lines. + messages, drop the least recent lines. Each message is at most one line of text, which is the width of the window. Use 400 pixels for the width of a window, and use 11 point text - fonts to render lines. A line consists of two pieces: + fonts to render lines. A line consists of two pieces: - -- an address + -- an address -- a message where the address is separated from the message with a ":". The user sends @@ -28,29 +28,29 @@ Each message is at most one line of text, which is the width of the Editing is just entering keys. Ignore all those key strokes that aren't one-character strings and of the remaining strings ignore backspace and delete. (Of course, if you are ambitious you may wish to assign meaning to - some of those keys so that chatters can edit a bit.) + some of those keys so that chatters can edit a bit.) A message whose recipient is "*" is broadcast to every current participant. Otherwise a message is sent to the designated recipient, if the string is the valid name of a current participant; all other messages disappear in - the big empty void. + the big empty void. Each received message is displayed like those that are sent, with an sender followed by ":" and the text of the message. If the message went to all - participants, the sender's name is followed by an asterisk "*". + participants, the sender's name is followed by an asterisk "*". As you work on this project, you will encounter questions for which this problem statement doesn't provide enough information to make decisions. You -must make the decisions on your own, following this procedure: - -- do not opt for answers that render the project trivial - -- document all non-trivial answers and the answer you chose - -- provide a reason for your choice -Be concise. +must make the decisions on your own, following this procedure: + -- do not opt for answers that render the project trivial + -- document all non-trivial answers and the answer you chose + -- provide a reason for your choice +Be concise. ;; ----------------------------------------------------------------------------- protocol: -Sending and receiving message occur without any synchronization. +Sending and receiving message occur without any synchronization. Clients send messages of the form (list String String) to the server. The first string designates the recipient of the message, the second string @@ -63,24 +63,24 @@ The Chat Server swaps the name of the recipient of a message with that of current participants. - SERVER CLIENT (name1) CLIENT (name2) - | | | - | name1 | % name by which client is known | - | <-------------------- | | - | | | - | (list name2 txt) | | - | <-------------------- | | - | | | - | | (list name1 txt) | + SERVER CLIENT (name1) CLIENT (name2) + | | | + | name1 | % name by which client is known | + | <-------------------- | | + | | | + | (list name2 txt) | | + | <-------------------- | | + | | | + | | (list name1 txt) | | --------------------------------------------------------> | - | | | - | | | + | | | + | | | ;; Client2ServerMsg = (list String String) -;; interp. recipient followed by message text +;; interp. recipient followed by message text ;; Server2ClientMsg = (list String String) -;; interp. sender followed by message text. +;; interp. sender followed by message text. ;; ----------------------------------------------------------------------------- @@ -88,14 +88,14 @@ chat server: receive message, swap recipient for sender & send message(s) ;; ----------------------------------------------------------------------------- -chat world: +chat world: +------------------------------------------------------------------+ - | from: text text text text text text | - | from*: text text text text text text | - | ... | + | from: text text text text text text | + | from*: text text text text text text | + | ... | +------------------------------------------------------------------+ - | to: text text text text text text | - | *: text text text text text text | - | ... | + | to: text text text text text text | + | *: text text text text text text | + | ... | +------------------------------------------------------------------+ diff --git a/collects/browser/private/html.rkt b/collects/browser/private/html.rkt index b897eca2b0..a68a9efc4f 100644 --- a/collects/browser/private/html.rkt +++ b/collects/browser/private/html.rkt @@ -529,7 +529,7 @@ v))) (define html-convert - (lambda (a-port a-text) + (lambda (a-port a-text) (let ([content (parse-html a-port)]) (with-method ([a-text-insert (a-text insert)] [current-pos (a-text last-position)] diff --git a/collects/compiler/embed.rkt b/collects/compiler/embed.rkt index 0a5d9c04d4..f0f36b7181 100644 --- a/collects/compiler/embed.rkt +++ b/collects/compiler/embed.rkt @@ -36,25 +36,25 @@ (list/c (or/c symbol? #f #t) (or/c path? module-path?) (listof symbol?)))) - #:configure-via-first-module? any/c - #:literal-files (listof path-string?) - #:literal-expression any/c - #:literal-expressions (listof any/c) + #:configure-via-first-module? any/c + #:literal-files (listof path-string?) + #:literal-expression any/c + #:literal-expressions (listof any/c) #:cmdline (listof string?) #:gracket? any/c - #:mred? any/c - #:variant (or/c '3m 'cgc) + #:mred? any/c + #:variant (or/c '3m 'cgc) #:aux (listof (cons/c symbol? any/c)) #:collects-path (or/c #f path-string? (listof path-string?)) #:collects-dest (or/c #f path-string?) - #:launcher? any/c - #:verbose? any/c - #:compiler (-> any/c compiled-expression?) + #:launcher? any/c + #:verbose? any/c + #:compiler (-> any/c compiled-expression?) #:expand-namespace namespace? #:src-filter (-> path? any) - #:on-extension (or/c #f (-> path-string? boolean? any)) + #:on-extension (or/c #f (-> path-string? boolean? any)) #:get-extra-imports (-> path? compiled-module-expression? (listof module-path?))) void?)]) @@ -63,4 +63,3 @@ embedding-executable-is-actually-directory? embedding-executable-put-file-extension+style+filters embedding-executable-add-suffix) - diff --git a/collects/db/private/odbc/ffi-constants.rkt b/collects/db/private/odbc/ffi-constants.rkt index b7f96712be..0975e5c02c 100644 --- a/collects/db/private/odbc/ffi-constants.rkt +++ b/collects/db/private/odbc/ffi-constants.rkt @@ -24,7 +24,7 @@ (define SQL_ATTR_ODBC_VERSION 200) (define SQL_OV_ODBC2 2) -(define SQL_OV_ODBC3 3) +(define SQL_OV_ODBC3 3) (define SQL_SUCCESS 0) (define SQL_SUCCESS_WITH_INFO 1) diff --git a/collects/deinprogramm/DMdA.rkt b/collects/deinprogramm/DMdA.rkt index 4080de3245..36cc91fbfc 100644 --- a/collects/deinprogramm/DMdA.rkt +++ b/collects/deinprogramm/DMdA.rkt @@ -247,7 +247,7 @@ ((DMdA-cons cons) (%a (list-of %a) -> (list-of %a)) "erzeuge ein Paar aus Element und Liste") (pair? (any -> boolean) - "feststellen, ob ein Wert ein Paar ist") + "feststellen, ob ein Wert ein Paar ist") (cons? (any -> boolean) "feststellen, ob ein Wert ein Paar ist") (empty? (any -> boolean) diff --git a/collects/deinprogramm/run-dmda-code.rkt b/collects/deinprogramm/run-dmda-code.rkt index f0a958a91f..9bbb0825ad 100644 --- a/collects/deinprogramm/run-dmda-code.rkt +++ b/collects/deinprogramm/run-dmda-code.rkt @@ -41,7 +41,7 @@ (close-input-port p) (open-input-text-editor t 0 'end values filename))] [else p])]) - (port-count-lines! p) ; in case it's new + (port-count-lines! p) ; in case it's new (values p filename)))) (define (open-input-graphical-file/fixed filename) diff --git a/collects/deinprogramm/world.rkt b/collects/deinprogramm/world.rkt index d5be3eaea5..fb7ec97718 100644 --- a/collects/deinprogramm/world.rkt +++ b/collects/deinprogramm/world.rkt @@ -20,8 +20,8 @@ (provide (all-from-out "image.rkt")) (provide ;; forall(World): - big-bang ;; Number Number Number World -> true - end-of-time ;; String u Symbol -> World + big-bang ;; Number Number Number World -> true + end-of-time ;; String u Symbol -> World ) (provide-higher-order-primitive diff --git a/collects/drracket/private/rep.rkt b/collects/drracket/private/rep.rkt index 6d8ed96cb7..c15af7a6db 100644 --- a/collects/drracket/private/rep.rkt +++ b/collects/drracket/private/rep.rkt @@ -471,9 +471,9 @@ TODO (define/public (get-context) context) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;; ;;; + ;;; ;;; ;;; User -> Kernel ;;; - ;;; ;;; + ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; =User= (probably doesn't matter) @@ -774,8 +774,8 @@ TODO (unless inserting-prompt? (reset-highlighting)) (when (and prompt-position - (ormap (λ (start) (< start prompt-position)) - starts)) + (ormap (λ (start) (< start prompt-position)) + starts)) (set! prompt-position (get-unread-start-point)) (reset-regions (append (all-but-last (get-regions)) (list (list prompt-position 'end)))))) diff --git a/collects/drracket/private/text.rkt b/collects/drracket/private/text.rkt index 14b0baa0d1..a0bb52bf73 100644 --- a/collects/drracket/private/text.rkt +++ b/collects/drracket/private/text.rkt @@ -17,17 +17,17 @@ (define/public (is-printing-on?) printing?) (define/public (printing-on) (set! printing? #t)) (define/public (printing-off) (set! printing? #f)) - ; (rename [super-on-paint on-paint]) - ; (inherit get-filename) - ; (override - ; [on-paint - ; (λ (before? dc left top right bottom dx dy draw-caret) - ; (super-on-paint before? dc left top right bottom dx dy draw-caret) - ; (let ([str (string-append - ; (mzlib:date:date->string (seconds->date (current-seconds))) - ; " " - ; (if (string? (get-filename)) - ; (get-filename) - ; "Untitled"))]) - ; (send dc draw-text str dx dy)))]) + ; (rename [super-on-paint on-paint]) + ; (inherit get-filename) + ; (override + ; [on-paint + ; (λ (before? dc left top right bottom dx dy draw-caret) + ; (super-on-paint before? dc left top right bottom dx dy draw-caret) + ; (let ([str (string-append + ; (mzlib:date:date->string (seconds->date (current-seconds))) + ; " " + ; (if (string? (get-filename)) + ; (get-filename) + ; "Untitled"))]) + ; (send dc draw-text str dx dy)))]) (super-new))) diff --git a/collects/dynext/link-unit.rkt b/collects/dynext/link-unit.rkt index d06b4c9f67..85496ce7ae 100644 --- a/collects/dynext/link-unit.rkt +++ b/collects/dynext/link-unit.rkt @@ -195,7 +195,7 @@ (make-parameter (case (system-type) [(unix macosx) - (case (string->symbol (path->string (system-library-subpath #f))) + (case (string->symbol (path->string (system-library-subpath #f))) [(i386-cygwin) win-gcc-link-output-strings] [else (lambda (s) (list "-o" (path-string->string s)))])] [(windows) (cond @@ -239,7 +239,7 @@ (list (wrap-xxxxxxx dllfile (wrap-3m "libracket~a~~a.dll")) (wrap-xxxxxxx dllfile (drop-3m "libmzgc~a.dll")))) (list - (mzdyn-maybe (filethunk (wrap-3m "mzdyn~a.exp"))) + (mzdyn-maybe (filethunk (wrap-3m "mzdyn~a.exp"))) (mzdyn-maybe (filethunk (wrap-3m ;; mzdyn.o is for Unix build, mzdynw.o for Windows (format "mzdyn~a~~a.o" diff --git a/collects/ffi/unsafe/atomic.rkt b/collects/ffi/unsafe/atomic.rkt index 30144685cf..daef99fdb3 100644 --- a/collects/ffi/unsafe/atomic.rkt +++ b/collects/ffi/unsafe/atomic.rkt @@ -112,7 +112,7 @@ break-paramz (lambda () (dynamic-wind - (lambda () + (lambda () (set! monitor-owner #f) (set! extra-atomic-depth 0) (end-breakable-atomic) diff --git a/collects/ffi/unsafe/com.rkt b/collects/ffi/unsafe/com.rkt index 152aede0c5..d5d08b0722 100644 --- a/collects/ffi/unsafe/com.rkt +++ b/collects/ffi/unsafe/com.rkt @@ -1,12 +1,12 @@ #lang racket/base (require ffi/unsafe ffi/unsafe/alloc - ffi/winapi + ffi/winapi ffi/unsafe/atomic ffi/unsafe/custodian racket/date racket/runtime-path - racket/list + racket/list (for-syntax racket/base) "private/win32.rkt") @@ -126,15 +126,15 @@ (define (_system-string/utf-16 mode) (make-ctype _pointer - (lambda (s) - (and s + (lambda (s) + (and s (let ([c (string->pointer s)]) (register-cleanup! (lambda () (SysFreeString c))) c))) - (lambda (p) - (begin0 - (cast p _pointer _string/utf-16) - (when (memq 'out mode) (SysFreeString p)))))) + (lambda (p) + (begin0 + (cast p _pointer _string/utf-16) + (when (memq 'out mode) (SysFreeString p)))))) (define current-cleanup (make-parameter #f)) (define current-commit (make-parameter #f)) @@ -464,8 +464,8 @@ (define-com-interface (_IClassFactory _IUnknown) ([CreateInstance/factory (_hmfun _IUnknown-pointer/null _REFIID - (p : (_ptr o _ISink-pointer/null)) - -> CreateInstance p)] + (p : (_ptr o _ISink-pointer/null)) + -> CreateInstance p)] [LockServer _fpointer])) @@ -595,17 +595,17 @@ (bitwise-ior CLSCTX_LOCAL_SERVER CLSCTX_INPROC_SERVER) IID_IUnknown)] [else - (define cleanup (box null)) + (define cleanup (box null)) (define csi (parameterize ([current-cleanup cleanup]) - (make-COSERVERINFO 0 machine #f 0))) + (make-COSERVERINFO 0 machine #f 0))) (define mqi (make-MULTI_QI IID_IUnknown #f 0)) (define unknown - (dynamic-wind - void - (lambda () - (CoCreateInstanceEx clsid #f CLSCTX_REMOTE_SERVER (and machine csi) 1 mqi)) - (lambda () - (for ([proc (in-list (unbox cleanup))]) (proc))))) + (dynamic-wind + void + (lambda () + (CoCreateInstanceEx clsid #f CLSCTX_REMOTE_SERVER (and machine csi) 1 mqi)) + (lambda () + (for ([proc (in-list (unbox cleanup))]) (proc))))) (unless (and (zero? (MULTI_QI-hr mqi)) unknown) (error who "unable to obtain IUnknown interface for remote server")) @@ -643,7 +643,7 @@ (let ([mref (com-impl-mref impl)]) (when mref (set-com-impl-mref! impl #f) - (unregister-custodian-shutdown impl mref))) + (unregister-custodian-shutdown impl mref))) (release-type-types (com-impl-type-info impl)) (define (bye! sel st!) (when (sel impl) @@ -669,7 +669,7 @@ (when (zero? (type-ref-count type)) (when (positive? (hash-count (type-types type))) (for ([td (in-hash-values (type-types type))]) - (release-type-desc td)) + (release-type-desc td)) (set-type-types! type (make-hash))) (hash-remove! types type-info))))) @@ -736,23 +736,23 @@ dispatch))) (struct type (type-info [types #:mutable] - scheme-types - [ref-count #:mutable])) + scheme-types + [ref-count #:mutable])) (define types (make-weak-hash)) (define (intern-type-info type-info) ;; called in atomic mode (let ([ti-e (hash-ref types type-info #f)]) (if ti-e - (let* ([t (ephemeron-value ti-e)] - [ti (type-type-info t)]) - (set-type-ref-count! t (add1 (type-ref-count t))) - (Release type-info) - (AddRef ti) - t) - (let ([t (type type-info (make-hash) (make-hash) 1)]) - (hash-set! types type-info (make-ephemeron type-info t)) - t)))) + (let* ([t (ephemeron-value ti-e)] + [ti (type-type-info t)]) + (set-type-ref-count! t (add1 (type-ref-count t))) + (Release type-info) + (AddRef ti) + t) + (let ([t (type type-info (make-hash) (make-hash) 1)]) + (hash-set! types type-info (make-ephemeron type-info t)) + t)))) (define (type-info-type type-info) (ephemeron-value (hash-ref types type-info))) @@ -766,18 +766,18 @@ (error "COM object does not expose type information") #f) (let ([type-info (GetTypeInfo - dispatch - 0 - LOCALE_SYSTEM_DEFAULT)]) - (unless type-info - (error "Error getting COM type information")) - (let* ([type (intern-type-info type-info)] - [type-info (type-type-info type)] - [impl (com-object-impl obj)]) - (set-com-impl-type-info! impl type-info) - (set-com-impl-types! impl (type-types type)) - (set-com-impl-scheme-types! impl (type-scheme-types type)) - type-info)))))) + dispatch + 0 + LOCALE_SYSTEM_DEFAULT)]) + (unless type-info + (error "Error getting COM type information")) + (let* ([type (intern-type-info type-info)] + [type-info (type-type-info type)] + [impl (com-object-impl obj)]) + (set-com-impl-type-info! impl type-info) + (set-com-impl-types! impl (type-types type)) + (set-com-impl-scheme-types! impl (type-scheme-types type)) + type-info)))))) (define (com-object-type obj) (check-com-obj 'com-object-type obj) @@ -1003,7 +1003,7 @@ var-desc] [else (ReleaseVarDesc type-info var-desc) - #f]))) + #f]))) ;; search in inherited interfaces (for/or ([i (in-range (TYPEATTR-cImplTypes type-attr))]) (define ref-type (GetRefTypeOfImplType type-info i)) @@ -1084,20 +1084,20 @@ (event-type-info-from-com-object obj)] [else (type-info-from-com-object obj exn?)])]) - (and type-info + (and type-info (let ([mx-type-desc (type-desc-from-type-info name inv-kind type-info)]) (when mx-type-desc (hash-set! (com-object-types obj) (cons name inv-kind) mx-type-desc)) mx-type-desc))))) (define (get-var-type-from-elem-desc elem-desc - #:keep-safe-array? [keep-safe-array? #f]) + #:keep-safe-array? [keep-safe-array? #f]) ;; hack: allow elem-desc as a TYPEDESC (define param-desc (and (ELEMDESC? elem-desc) - (union-ref (ELEMDESC-u elem-desc) 1))) + (union-ref (ELEMDESC-u elem-desc) 1))) (define flags (if param-desc - (PARAMDESC-wParamFlags param-desc) - 0)) + (PARAMDESC-wParamFlags param-desc) + 0)) (define (fixup-vt vt) (cond [(= vt (bitwise-ior VT_USERDEFINED VT_BYREF)) @@ -1105,12 +1105,12 @@ [(= vt VT_USERDEFINED) VT_INT] [(and (= vt VT_SAFEARRAY) - (not keep-safe-array?)) + (not keep-safe-array?)) (bitwise-ior VT_ARRAY VT_VARIANT)] [else vt])) (define type-desc (if (ELEMDESC? elem-desc) - (ELEMDESC-tdesc elem-desc) - elem-desc)) + (ELEMDESC-tdesc elem-desc) + elem-desc)) (cond [(and (bit-and? flags PARAMFLAG_FOPT) (bit-and? flags PARAMFLAG_FHASDEFAULT)) @@ -1119,9 +1119,9 @@ [(= (TYPEDESC-vt type-desc) VT_PTR) (fixup-vt (bitwise-ior VT_BYREF - (TYPEDESC-vt (cast (union-ref (TYPEDESC-u type-desc) 0) - _pointer - _TYPEDESC-pointer))))] + (TYPEDESC-vt (cast (union-ref (TYPEDESC-u type-desc) 0) + _pointer + _TYPEDESC-pointer))))] [else (fixup-vt (TYPEDESC-vt type-desc))])) @@ -1145,7 +1145,7 @@ (define (elem-desc-to-scheme-type elem-desc ignore-by-ref? is-opt? internal?) (define vt (let ([vt (get-var-type-from-elem-desc elem-desc #:keep-safe-array? #t)]) (if (and ignore-by-ref? - (not (= vt (bitwise-ior VT_USERDEFINED VT_BYREF)))) + (not (= vt (bitwise-ior VT_USERDEFINED VT_BYREF)))) (- vt (bitwise-and vt VT_BYREF)) vt))) (cond @@ -1171,12 +1171,12 @@ [else (define as-iunk? (= vt (bitwise-ior VT_USERDEFINED VT_BYREF))) (define base (vt-to-scheme-type (if as-iunk? - vt - (- vt (bitwise-and vt VT_BYREF))))) + vt + (- vt (bitwise-and vt VT_BYREF))))) (define new-base (if (and (not as-iunk?) - (bit-and? vt VT_BYREF)) - `(box ,base) + (bit-and? vt VT_BYREF)) + `(box ,base) base)) (if is-opt? `(opt ,new-base) @@ -1232,12 +1232,12 @@ [(type-described? arg) (type-described-description arg)] [(vector? arg) `(array ,(vector-length arg) - ,(if (zero? (vector-length arg)) - 'int - (for/fold ([t (arg-to-type (vector-ref arg 0))]) ([v (in-vector arg)]) - (if (equal? t (arg-to-type v)) - t - 'any))))] + ,(if (zero? (vector-length arg)) + 'int + (for/fold ([t (arg-to-type (vector-ref arg 0))]) ([v (in-vector arg)]) + (if (equal? t (arg-to-type v)) + t + 'any))))] [(in-array . > . 1) 'any] [(boolean? arg) 'boolean] [(signed-int? arg 32) 'int] @@ -1282,25 +1282,25 @@ (call-as-atomic (lambda () (or (and (com-object? obj) - (hash-ref (com-object-scheme-types obj) (cons name inv-kind) #f)) - (let ([t (get-uncached-method-type who obj name inv-kind internal?)]) - (when (com-object? obj) - (hash-set! (com-object-scheme-types obj) (cons name inv-kind) t)) - t))))) + (hash-ref (com-object-scheme-types obj) (cons name inv-kind) #f)) + (let ([t (get-uncached-method-type who obj name inv-kind internal?)]) + (when (com-object? obj) + (hash-set! (com-object-scheme-types obj) (cons name inv-kind) t)) + t))))) (define (get-uncached-method-type who obj name inv-kind internal?) (define type-info (extract-type-info who obj (not internal?))) (when (and (= inv-kind INVOKE_FUNC) - (is-dispatch-name? name)) - (error who "IDispatch methods not available")) + (is-dispatch-name? name)) + (error who "IDispatch methods not available")) (define mx-type-desc (cond [(com-object? obj) (get-method-type obj name inv-kind (not internal?))] [else (define x-type-info - (if (= inv-kind INVOKE_EVENT) - (event-type-info-from-com-type obj) - type-info)) - (type-desc-from-type-info name inv-kind x-type-info)])) + (if (= inv-kind INVOKE_EVENT) + (event-type-info-from-com-type obj) + type-info)) + (type-desc-from-type-info name inv-kind x-type-info)])) (cond [(not mx-type-desc) ;; there is no type info @@ -1309,60 +1309,60 @@ (define-values (args ret) (cond [(function-type-desc? mx-type-desc) - (define func-desc (car (mx-com-type-desc-desc mx-type-desc))) - (define num-actual-params (FUNCDESC-cParams func-desc)) - (cond - [(= -1 (FUNCDESC-cParamsOpt func-desc)) - ;; all args > pFuncDesc->cParams - 1 get packaged into SAFEARRAY, - ;; but that is handled by COM automation; we just pass "any"s - (values - (append - (for/list ([i (in-range (sub1 num-actual-params))]) - (elem-desc-to-scheme-type (elem-desc-ref func-desc i) - #f - #f - internal?)) - '(any ...)) - (elem-desc-to-scheme-type (FUNCDESC-elemdescFunc func-desc) - #f - #f - internal?))] - [else - (define last-is-retval? - (is-last-param-retval? inv-kind func-desc)) - (define num-params (- num-actual-params (if last-is-retval? 1 0))) - ;; parameters that are optional with a default value in IDL are not - ;; counted in pFuncDesc->cParamsOpt, so look for default bit flag - (define num-opt-params (get-opt-param-count func-desc num-params)) - (define first-opt-arg (- num-params num-opt-params)) - (values - (for/list ([i (in-range num-params)]) - (elem-desc-to-scheme-type (elem-desc-ref func-desc i) - #f - (i . >= . first-opt-arg) - internal?)) - (elem-desc-to-scheme-type (if last-is-retval? - (elem-desc-ref func-desc num-params) - (FUNCDESC-elemdescFunc func-desc)) - #t - #f - internal?))])] + (define func-desc (car (mx-com-type-desc-desc mx-type-desc))) + (define num-actual-params (FUNCDESC-cParams func-desc)) + (cond + [(= -1 (FUNCDESC-cParamsOpt func-desc)) + ;; all args > pFuncDesc->cParams - 1 get packaged into SAFEARRAY, + ;; but that is handled by COM automation; we just pass "any"s + (values + (append + (for/list ([i (in-range (sub1 num-actual-params))]) + (elem-desc-to-scheme-type (elem-desc-ref func-desc i) + #f + #f + internal?)) + '(any ...)) + (elem-desc-to-scheme-type (FUNCDESC-elemdescFunc func-desc) + #f + #f + internal?))] + [else + (define last-is-retval? + (is-last-param-retval? inv-kind func-desc)) + (define num-params (- num-actual-params (if last-is-retval? 1 0))) + ;; parameters that are optional with a default value in IDL are not + ;; counted in pFuncDesc->cParamsOpt, so look for default bit flag + (define num-opt-params (get-opt-param-count func-desc num-params)) + (define first-opt-arg (- num-params num-opt-params)) + (values + (for/list ([i (in-range num-params)]) + (elem-desc-to-scheme-type (elem-desc-ref func-desc i) + #f + (i . >= . first-opt-arg) + internal?)) + (elem-desc-to-scheme-type (if last-is-retval? + (elem-desc-ref func-desc num-params) + (FUNCDESC-elemdescFunc func-desc)) + #t + #f + internal?))])] [(= inv-kind INVOKE_PROPERTYGET) - (define var-desc (mx-com-type-desc-desc mx-type-desc)) - (values null - (elem-desc-to-scheme-type (VARDESC-elemdescVar var-desc) - #f - #f - internal?))] + (define var-desc (mx-com-type-desc-desc mx-type-desc)) + (values null + (elem-desc-to-scheme-type (VARDESC-elemdescVar var-desc) + #f + #f + internal?))] [(= inv-kind INVOKE_PROPERTYPUT) - (define var-desc (mx-com-type-desc-desc mx-type-desc)) - (values (list (elem-desc-to-scheme-type (VARDESC-elemdescVar var-desc) - #f - #f - internal?)) - 'void)] + (define var-desc (mx-com-type-desc-desc mx-type-desc)) + (values (list (elem-desc-to-scheme-type (VARDESC-elemdescVar var-desc) + #f + #f + internal?)) + 'void)] [(= inv-kind INVOKE_EVENT) - (values null 'void)])) + (values null 'void)])) `(-> ,args ,ret)])) (define (com-method-type obj name) @@ -1506,8 +1506,8 @@ (ok-argument? (unbox arg) (cadr type)))] [(eq? 'array (car type)) (and (vector? arg) - (or (eq? (cadr type) '?) - (= (vector-length arg) (cadr type))) + (or (eq? (cadr type) '?) + (= (vector-length arg) (cadr type))) (for/and ([v (in-vector arg)]) (ok-argument? v (caddr type))))] [(eq? 'variant (car type)) @@ -1609,8 +1609,8 @@ (variant-set! var (to-ctype scheme-type #:mode mode) a)] [else (define use-scheme-type (if (any-type? scheme-type) - (arg-to-type a) - scheme-type)) + (arg-to-type a) + scheme-type)) (set-VARIANT-vt! var (to-vt use-scheme-type)) (variant-set! var (to-ctype use-scheme-type #:mode mode) a)])) @@ -1628,33 +1628,33 @@ (define (_box/permanent _t) (define (extract p) (if (eq? _t _VARIANT) - (variant-to-scheme (cast p _pointer _VARIANT-pointer) #:mode '(in out)) - (ptr-ref p _t))) + (variant-to-scheme (cast p _pointer _VARIANT-pointer) #:mode '(in out)) + (ptr-ref p _t))) (make-ctype _pointer (lambda (v) (define p (malloc 'raw 1 _t)) (if (eq? _t _VARIANT) - (let ([p (cast p _pointer _VARIANT-pointer)] - [v (unbox v)]) - (VariantInit p) - (scheme-to-variant! p v #f (arg-to-type v) #:mode '(in out))) - (ptr-set! p _t (unbox v))) - (register-cleanup! + (let ([p (cast p _pointer _VARIANT-pointer)] + [v (unbox v)]) + (VariantInit p) + (scheme-to-variant! p v #f (arg-to-type v) #:mode '(in out))) + (ptr-set! p _t (unbox v))) + (register-cleanup! (lambda () (set-box! v (extract p)) (free p))) p) (lambda (p) - ;; We box the value, but we don't support reflecting box - ;; changes back to changes of the original reference: + ;; We box the value, but we don't support reflecting box + ;; changes back to changes of the original reference: (box (extract p))))) (define (make-a-VARIANT [mode 'atomic-interior]) (define var (cast (malloc _VARIANT mode) - _pointer - (if (eq? mode 'raw) - _VARIANT-pointer - (_gcable _VARIANT-pointer)))) + _pointer + (if (eq? mode 'raw) + _VARIANT-pointer + (_gcable _VARIANT-pointer)))) (VariantInit var) var) @@ -1670,44 +1670,44 @@ (define (_safe-array/vectors given-dims base mode) (make-ctype _pointer - (lambda (v) - (define base-vt (to-vt base)) - (define dims (if (equal? given-dims '(?)) - (list (vector-length v)) - given-dims)) - (define sa (SafeArrayCreate base-vt - (length dims) - (for/list ([d (in-list dims)]) - (make-SAFEARRAYBOUND d 0)))) - (register-cleanup! - (lambda () (SafeArrayDestroy sa))) - (let loop ([v v] [index null] [dims dims]) - (for ([v (in-vector v)] - [i (in-naturals)]) - (define idx (cons i index)) - (if (null? (cdr dims)) - (let ([var (make-a-VARIANT)]) - (scheme-to-variant! var v #f base #:mode mode) - (SafeArrayPutElement sa (reverse idx) - (extract-variant-pointer var #f base-vt))) - (loop v idx (cdr dims))))) - sa) - (lambda (_sa) - (define sa (cast _sa _pointer _SAFEARRAY-pointer)) - (define dims (for/list ([i (in-range (SafeArrayGetDim sa))]) - (- (add1 (SafeArrayGetUBound sa (add1 i))) - (SafeArrayGetLBound sa (add1 i))))) - (define vt (SafeArrayGetVartype sa)) - (let loop ([dims dims] [level 1] [index null]) - (define lb (SafeArrayGetLBound sa level)) - (for/vector ([i (in-range (car dims))]) - (if (null? (cdr dims)) - (let ([var (make-a-VARIANT)]) - (set-VARIANT-vt! var vt) - (SafeArrayGetElement sa (reverse (cons i index)) - (extract-variant-pointer var #t)) - (variant-to-scheme var #:mode mode)) - (loop (cdr dims) (add1 level) (cons i index)))))))) + (lambda (v) + (define base-vt (to-vt base)) + (define dims (if (equal? given-dims '(?)) + (list (vector-length v)) + given-dims)) + (define sa (SafeArrayCreate base-vt + (length dims) + (for/list ([d (in-list dims)]) + (make-SAFEARRAYBOUND d 0)))) + (register-cleanup! + (lambda () (SafeArrayDestroy sa))) + (let loop ([v v] [index null] [dims dims]) + (for ([v (in-vector v)] + [i (in-naturals)]) + (define idx (cons i index)) + (if (null? (cdr dims)) + (let ([var (make-a-VARIANT)]) + (scheme-to-variant! var v #f base #:mode mode) + (SafeArrayPutElement sa (reverse idx) + (extract-variant-pointer var #f base-vt))) + (loop v idx (cdr dims))))) + sa) + (lambda (_sa) + (define sa (cast _sa _pointer _SAFEARRAY-pointer)) + (define dims (for/list ([i (in-range (SafeArrayGetDim sa))]) + (- (add1 (SafeArrayGetUBound sa (add1 i))) + (SafeArrayGetLBound sa (add1 i))))) + (define vt (SafeArrayGetVartype sa)) + (let loop ([dims dims] [level 1] [index null]) + (define lb (SafeArrayGetLBound sa level)) + (for/vector ([i (in-range (car dims))]) + (if (null? (cdr dims)) + (let ([var (make-a-VARIANT)]) + (set-VARIANT-vt! var vt) + (SafeArrayGetElement sa (reverse (cons i index)) + (extract-variant-pointer var #t)) + (variant-to-scheme var #:mode mode)) + (loop (cdr dims) (add1 level) (cons i index)))))))) (define (_IUnknown-pointer-or-com-object mode) (make-ctype @@ -1722,12 +1722,12 @@ p) (lambda (p) (if p - (begin - (if (memq 'out mode) - (((allocator Release) (lambda () p))) - (AddRef p)) - (make-com-object p #f)) - p)))) + (begin + (if (memq 'out mode) + (((allocator Release) (lambda () p))) + (AddRef p)) + (make-com-object p #f)) + p)))) (define (_com-object mode) (_IUnknown-pointer-or-com-object mode)) @@ -1766,14 +1766,14 @@ [(eq? 'array (car type)) (define-values (dims base) (let loop ([t type] [?-ok? #t]) - (cond - [(and (pair? t) (eq? 'array (car t)) (or ?-ok? (number? (cadr t)))) - (define-values (d b) (if (number? (cadr t)) + (cond + [(and (pair? t) (eq? 'array (car t)) (or ?-ok? (number? (cadr t)))) + (define-values (d b) (if (number? (cadr t)) (loop (caddr t) #f) (values null (cadr t)))) - (values (cons (cadr t) d) b)] - [else - (values null t)]))) + (values (cons (cadr t) d) b)] + [else + (values null t)]))) (_safe-array/vectors dims base mode)] [(eq? 'variant (car type)) (to-ctype (cadr type) #:mode mode)] @@ -1803,38 +1803,38 @@ [(com-enumeration) VT_INT] [else (case (and (pair? type) - (car type)) + (car type)) [(array) (bitwise-ior VT_ARRAY (to-vt (caddr type)))] [(opt) (to-vt (cadr type))] [(variant) VT_VARIANT] [(box) (bitwise-ior VT_BYREF (to-vt (cadr type)))] [else - (error 'to-vt "internal error: unsupported type ~s" type)])])) + (error 'to-vt "internal error: unsupported type ~s" type)])])) (define (build-method-arguments-using-function-desc func-desc scheme-types inv-kind args) (define lcid-index (and func-desc (get-lcid-param-index func-desc))) (define last-is-retval? (and func-desc (is-last-param-retval? inv-kind func-desc))) (define last-is-repeat-any? (and func-desc (= -1 (FUNCDESC-cParamsOpt func-desc)))) (define base-count (if func-desc - (- (FUNCDESC-cParams func-desc) - (if lcid-index 1 0) - (if last-is-retval? 1 0)) - (length scheme-types))) + (- (FUNCDESC-cParams func-desc) + (if lcid-index 1 0) + (if last-is-retval? 1 0)) + (length scheme-types))) (define count (if last-is-repeat-any? - (if (or lcid-index - last-is-retval?) - (error "cannot handle combination of `any ...' and lcid/retval") - (length scheme-types)) - base-count)) + (if (or lcid-index + last-is-retval?) + (error "cannot handle combination of `any ...' and lcid/retval") + (length scheme-types)) + base-count)) (build-method-arguments-from-desc count - (lambda (i) - (and func-desc - (or (not last-is-repeat-any?) - (i . < . (sub1 base-count))) - (elem-desc-ref func-desc i))) - scheme-types - inv-kind - args)) + (lambda (i) + (and func-desc + (or (not last-is-repeat-any?) + (i . < . (sub1 base-count))) + (elem-desc-ref func-desc i))) + scheme-types + inv-kind + args)) (define (build-method-arguments-from-desc count get-elem-desc scheme-types inv-kind args) (define vars (if (zero? count) @@ -1853,12 +1853,12 @@ (define var (ptr-ref vars _VARIANT (- count i 1))) ; reverse order (VariantInit var) (scheme-to-variant! var - a - (get-elem-desc i) - scheme-type))) + a + (get-elem-desc i) + scheme-type))) (define disp-params (cast (malloc _DISPPARAMS 'raw) - _pointer - _DISPPARAMS-pointer)) + _pointer + _DISPPARAMS-pointer)) (memcpy disp-params (make-DISPPARAMS vars (if (= inv-kind INVOKE_PROPERTYPUT) @@ -1868,21 +1868,21 @@ (if (= inv-kind INVOKE_PROPERTYPUT) count 0)) - (ctype-sizeof _DISPPARAMS)) + (ctype-sizeof _DISPPARAMS)) (values count - disp-params + disp-params (cons (lambda () (free disp-params)) (unbox cleanup)) (unbox commit))) (define (build-method-arguments-using-var-desc var-desc scheme-types inv-kind args) (build-method-arguments-from-desc (if (= inv-kind INVOKE_PROPERTYPUT) - 1 - 0) - (lambda (i) - (VARDESC-elemdescVar var-desc)) - scheme-types - inv-kind - args)) + 1 + 0) + (lambda (i) + (VARDESC-elemdescVar var-desc)) + scheme-types + inv-kind + args)) (define (variant-to-scheme var #:mode [mode '(out)]) (define _t (to-ctype (vt-to-scheme-type (VARIANT-vt var)) #:mode mode)) @@ -1902,8 +1902,8 @@ inv-kind args)] [else (build-method-arguments-using-var-desc (mx-com-type-desc-desc type-desc) - scheme-types - inv-kind args)])) + scheme-types + inv-kind args)])) (define (find-memid who obj name) (define-values (r memid) @@ -1919,29 +1919,29 @@ (define ta (cadr t)) (define len (length ta)) (if (and (len . >= . 2) - ((length args) . >= . (- len 2)) - (eq? '... (list-ref ta (sub1 len))) - (eq? 'any (list-ref ta (- len 2)))) + ((length args) . >= . (- len 2)) + (eq? '... (list-ref ta (sub1 len))) + (eq? 'any (list-ref ta (- len 2)))) ;; Replace `any ...' with the right number of `any's `(,(car t) ,(append (take ta (- len 2)) - (make-list (- (length args) (- len 2)) 'any)) - . ,(cddr t)) + (make-list (- (length args) (- len 2)) 'any)) + . ,(cddr t)) t)) (define (do-com-invoke who obj name args inv-kind) (check-com-obj who obj) (unless (string? name) (raise-type-error who "string" name)) (let* ([t (or (do-get-method-type who obj name inv-kind #t) - ;; wing it by inferring types from the arguments: - `(-> ,(map arg-to-type args) any))] - [t (adjust-any-... args t)]) + ;; wing it by inferring types from the arguments: + `(-> ,(map arg-to-type args) any))] + [t (adjust-any-... args t)]) (unless (<= (for/fold ([n 0]) ([v (in-list (cadr t))]) - (if (and (pair? v) (eq? (car v) 'opt)) - (add1 n) - n)) + (if (and (pair? v) (eq? (car v) 'opt)) + (add1 n) + n)) (length args) (length (cadr t))) - (error 'com-invoke "bad argument count for ~s" name)) + (error 'com-invoke "bad argument count for ~s" name)) (for ([arg (in-list args)] [type (in-list (cadr t))]) (check-argument 'com-invoke name arg type)) @@ -1968,26 +1968,26 @@ (variant-to-scheme (ptr-ref (DISPPARAMS-rgvarg method-arguments) _VARIANT i) - #:mode '()))))) - (define exn-info-ptr (malloc 'atomic-interior _EXCEPINFO)) + #:mode '()))))) + (define exn-info-ptr (malloc 'atomic-interior _EXCEPINFO)) (define-values (method-result cleanups) (if (= inv-kind INVOKE_PROPERTYPUT) (values #f arg-cleanups) (let ([r (make-a-VARIANT 'raw)]) - (values r (cons (lambda () (free r)) - arg-cleanups))))) + (values r (cons (lambda () (free r)) + arg-cleanups))))) (for ([proc (in-list commits)]) (proc)) (define hr - ;; Note that all arguments to `Invoke' should - ;; not be movable by a GC. A call to `Invoke' - ;; may use the Windows message queue, and other - ;; libraries (notably `racket/gui') may have - ;; callbacks triggered via messages. + ;; Note that all arguments to `Invoke' should + ;; not be movable by a GC. A call to `Invoke' + ;; may use the Windows message queue, and other + ;; libraries (notably `racket/gui') may have + ;; callbacks triggered via messages. (Invoke (com-object-get-dispatch obj) memid IID_NULL LOCALE_SYSTEM_DEFAULT inv-kind method-arguments method-result - exn-info-ptr error-index-ptr)) + exn-info-ptr error-index-ptr)) (cond [(zero? hr) (begin0 @@ -1997,7 +1997,7 @@ (for ([proc (in-list cleanups)]) (proc)))] [(= hr DISP_E_EXCEPTION) (for ([proc (in-list cleanups)]) (proc)) - (define exn-info (cast exn-info-ptr _pointer _EXCEPINFO-pointer)) + (define exn-info (cast exn-info-ptr _pointer _EXCEPINFO-pointer)) (define has-error-code? (positive? (EXCEPINFO-wCode exn-info))) (define desc (EXCEPINFO-bstrDescription exn-info)) (windows-error @@ -2174,8 +2174,8 @@ (define sink-factory (myssink-DllGetClassObject CLSID_Sink IID_IClassFactory)) (define sink-unknown - ;; This primitive method doesn't AddRef the object, - ;; so don't Release it: + ;; This primitive method doesn't AddRef the object, + ;; so don't Release it: (CreateInstance/factory sink-factory #f CLSID_Sink)) (define sink (QueryInterface sink-unknown IID_ISink _ISink-pointer)) (set_myssink_table sink myssink-table) @@ -2235,10 +2235,10 @@ ;; Initialize (define-ole CoInitialize (_wfun (_pointer = #f) -> (r : _HRESULT) - -> (cond - [(= r 0) (void)] ; ok - [(= r 1) (void)] ; already initialized - [else (windows-error (format "~a: failed" 'CoInitialize) r)]))) + -> (cond + [(= r 0) (void)] ; ok + [(= r 1) (void)] ; already initialized + [else (windows-error (format "~a: failed" 'CoInitialize) r)]))) (define inited? #f) (define (init!) diff --git a/collects/ffi/unsafe/objc.rkt b/collects/ffi/unsafe/objc.rkt index d47187de97..8eb3fd0295 100644 --- a/collects/ffi/unsafe/objc.rkt +++ b/collects/ffi/unsafe/objc.rkt @@ -93,8 +93,8 @@ [method_count _int] ; 1 [method _objc_method])) -(define CLS_CLASS #x1) -(define CLS_META #x2) +(define CLS_CLASS #x1) +(define CLS_META #x2) (define (strcpy s) (let* ([n (cast s _string _bytes)] diff --git a/collects/ffi/unsafe/private/win32.rkt b/collects/ffi/unsafe/private/win32.rkt index 548af4a2ab..5a5827428b 100644 --- a/collects/ffi/unsafe/private/win32.rkt +++ b/collects/ffi/unsafe/private/win32.rkt @@ -1,7 +1,7 @@ #lang racket/base (require ffi/unsafe ffi/unsafe/define - ffi/winapi) + ffi/winapi) (provide (protect-out (all-defined-out))) ;; Win32 type and structure declarations. @@ -25,14 +25,14 @@ #:default-make-fail make-not-available) ;; for functions that use the Windows stdcall ABI: -(define-syntax-rule (_wfun type ...) +(define-syntax-rule (_wfun type ...) (_fun #:abi winapi type ...)) ;; for functions that return HRESULTs (define-syntax _hfun (syntax-rules (->) [(_ type ... -> who res) - (_wfun type ... + (_wfun type ... -> (r : _HRESULT) -> (if (positive? r) (windows-error (format "~a: failed" 'who) r) @@ -108,7 +108,7 @@ (define _VVAL (_union _double _intptr ;; etc. - (_array _pointer 2) + (_array _pointer 2) )) (define-cstruct _VARIANT ([vt _VARTYPE] @@ -179,7 +179,7 @@ raw-scode)) (define len (FormatMessageW FORMAT_MESSAGE_FROM_SYSTEM #f scode 0 buf (quotient size 2))) (if (positive? len) - (error (format "~a (~x; ~a)" str scode (regexp-replace #rx"[\r\n]+$" + (error (format "~a (~x; ~a)" str scode (regexp-replace #rx"[\r\n]+$" (cast buf _pointer _string/utf-16) ""))) (error (format "~a (~x)" str scode)))))) @@ -222,18 +222,18 @@ (define FUNC_VIRTUAL 0) (define FUNC_PUREVIRTUAL 1) -(define FUNC_NONVIRTUAL 2) +(define FUNC_NONVIRTUAL 2) (define FUNC_STATIC 3) (define FUNC_DISPATCH 4) -(define PARAMFLAG_NONE 0) -(define PARAMFLAG_FIN #x1) -(define PARAMFLAG_FOUT #x2) -(define PARAMFLAG_FLCID #x4) -(define PARAMFLAG_FRETVAL #x8) -(define PARAMFLAG_FOPT #x10) -(define PARAMFLAG_FHASDEFAULT #x20) -(define PARAMFLAG_FHASCUSTDATA #x40) +(define PARAMFLAG_NONE 0) +(define PARAMFLAG_FIN #x1) +(define PARAMFLAG_FOUT #x2) +(define PARAMFLAG_FLCID #x4) +(define PARAMFLAG_FRETVAL #x8) +(define PARAMFLAG_FOPT #x10) +(define PARAMFLAG_FHASDEFAULT #x20) +(define PARAMFLAG_FHASCUSTDATA #x40) (define VT_EMPTY 0) (define VT_NULL 1) @@ -288,7 +288,7 @@ (define VT_ILLEGALMASKED #xfff) (define VT_TYPEMASK #xfff) -(define DISPID_PROPERTYPUT -3) +(define DISPID_PROPERTYPUT -3) (define DISP_E_PARAMNOTFOUND #x80020004) (define DISP_E_EXCEPTION #x80020009) @@ -307,13 +307,13 @@ (set-GUID-s2! guid (bitwise-and #xFFFF (arithmetic-shift n (* -8 8)))) (set-GUID-c! guid (for/list ([i (in-range 8)]) (bitwise-and #xFF (arithmetic-shift n (* (- -7 i))))))))) - + (define-ole StringFromIID(_hfun _GUID-pointer (p : (_ptr o _pointer)) -> StringFromIID p)) (define (string->guid s [stay-put? #f]) - (define guid + (define guid (if stay-put? (cast (malloc _GUID 'atomic-interior) _pointer (_gcable _GUID-pointer)) (make-GUID 0 0 0 (list 0 0 0 0 0 0 0 0)))) @@ -354,30 +354,30 @@ (define _SAFEARRAY-pointer (_cpointer 'SAFEARRAY)) -(define-oleaut SafeArrayCreate (_wfun _VARTYPE - _UINT - (dims : (_list i _SAFEARRAYBOUND)) - -> _SAFEARRAY-pointer)) +(define-oleaut SafeArrayCreate (_wfun _VARTYPE + _UINT + (dims : (_list i _SAFEARRAYBOUND)) + -> _SAFEARRAY-pointer)) (define-oleaut SafeArrayDestroy (_hfun _SAFEARRAY-pointer - -> SafeArrayDestroy (void))) + -> SafeArrayDestroy (void))) (define-oleaut SafeArrayGetVartype (_hfun _SAFEARRAY-pointer - (vt : (_ptr o _VARTYPE)) - -> SafeArrayGetVartype vt)) + (vt : (_ptr o _VARTYPE)) + -> SafeArrayGetVartype vt)) (define-oleaut SafeArrayGetLBound (_hfun _SAFEARRAY-pointer - _UINT - (v : (_ptr o _LONG)) - -> SafeArrayGetLBound v)) + _UINT + (v : (_ptr o _LONG)) + -> SafeArrayGetLBound v)) (define-oleaut SafeArrayGetUBound (_hfun _SAFEARRAY-pointer - _UINT - (v : (_ptr o _LONG)) - -> SafeArrayGetUBound v)) + _UINT + (v : (_ptr o _LONG)) + -> SafeArrayGetUBound v)) (define-oleaut SafeArrayPutElement (_hfun _SAFEARRAY-pointer - (_list i _LONG) - _pointer - -> SafeArrayPutElement (void))) + (_list i _LONG) + _pointer + -> SafeArrayPutElement (void))) (define-oleaut SafeArrayGetElement (_hfun _SAFEARRAY-pointer - (_list i _LONG) - _pointer - -> SafeArrayGetElement (void))) + (_list i _LONG) + _pointer + -> SafeArrayGetElement (void))) (define-oleaut SafeArrayGetDim (_wfun _SAFEARRAY-pointer - -> _UINT)) + -> _UINT)) diff --git a/collects/file/gunzip.rkt b/collects/file/gunzip.rkt index 5fa4b7aea8..396afe9fa3 100644 --- a/collects/file/gunzip.rkt +++ b/collects/file/gunzip.rkt @@ -927,5 +927,5 @@ (dynamic-wind void (lambda () (do-gunzip in #f name-filter)) - (lambda () (close-input-port in))))])) + (lambda () (close-input-port in))))])) diff --git a/collects/file/sha1.rkt b/collects/file/sha1.rkt index 0ee4bc636f..0e88822d2a 100644 --- a/collects/file/sha1.rkt +++ b/collects/file/sha1.rkt @@ -269,7 +269,7 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (define (hash-value->bytes int) (let* ((len (vector-length hash-as-bytes-masks)) - (bv (make-bytes len 0))) + (bv (make-bytes len 0))) (do ((i 0 (+ i 1))) ((>= i len) bv) (bytes-set! diff --git a/collects/framework/private/keymap.rkt b/collects/framework/private/keymap.rkt index 6556aa5fd0..21042cdac1 100644 --- a/collects/framework/private/keymap.rkt +++ b/collects/framework/private/keymap.rkt @@ -739,7 +739,7 @@ (send edit on-char event) (loop (sub1 n))))) (λ () - (send edit end-edit-sequence))))))) + (send edit end-edit-sequence))))))) #t)) (send km set-break-sequence-callback done) #t))] @@ -823,7 +823,7 @@ (λ (edit event) (when building-macro (set! current-macro (reverse building-macro)) - (set! build-protect? #f) + (set! build-protect? #f) (send build-macro-km break-sequence)) #t)] [delete-key diff --git a/collects/framework/private/racket.rkt b/collects/framework/private/racket.rkt index 92f1af6683..12bc13888f 100644 --- a/collects/framework/private/racket.rkt +++ b/collects/framework/private/racket.rkt @@ -538,7 +538,7 @@ #f)] [last-para (and last (position-paragraph last))]) - (letrec + (letrec ([find-offset (λ (start-pos) (define tab-char? #f) diff --git a/collects/framework/test.rkt b/collects/framework/test.rkt index 1f64b784c2..855cac0269 100644 --- a/collects/framework/test.rkt +++ b/collects/framework/test.rkt @@ -321,7 +321,7 @@ [else (update-control ctrl) (send ctrl command event) - (void)])))))) + (void)])))))) ;; ;; BUTTON diff --git a/collects/games/cards/classes.rkt b/collects/games/cards/classes.rkt index 0c36a37b8d..018cdc15d4 100644 --- a/collects/games/cards/classes.rkt +++ b/collects/games/cards/classes.rkt @@ -123,8 +123,8 @@ (public* [only-front-selected (lambda () - (let loop ([s (find-next-selected-snip #f)][ok (find-first-snip)]) - (when s + (let loop ([s (find-next-selected-snip #f)][ok (find-first-snip)]) + (when s (if (eq? s ok) (loop (find-next-selected-snip s) (send ok next)) diff --git a/collects/games/gobblet/model.rkt b/collects/games/gobblet/model.rkt index f6e7d8f4d5..32ff79717f 100644 --- a/collects/games/gobblet/model.rkt +++ b/collects/games/gobblet/model.rkt @@ -445,7 +445,7 @@ (let ([v (if who (compact-board board who) board)]) - ;; Find canonical mapping. + ;; Find canonical mapping. (hash-table-get memory v (lambda () diff --git a/collects/games/gobblet/test-model.rkt b/collects/games/gobblet/test-model.rkt index 03df53c5b8..f14fa6b109 100644 --- a/collects/games/gobblet/test-model.rkt +++ b/collects/games/gobblet/test-model.rkt @@ -193,7 +193,7 @@ (define-values/invoke-unit/sig model^ model-unit #f config^) (let ([c (let ([canonicalize (make-canonicalize)]) - (lambda (b who) + (lambda (b who) (canon-test 4 canonicalize b who fold-board board-ref move empty-board yellow-pieces red-pieces piece-color piece-size other diff --git a/collects/games/jewel/shapes.scm b/collects/games/jewel/shapes.scm index 13631dc00b..a8c4a57fc0 100644 --- a/collects/games/jewel/shapes.scm +++ b/collects/games/jewel/shapes.scm @@ -247,7 +247,7 @@ (glVertex3f sizex (- bsizey) sizez); (glVertex3f (- sizex) (- bsizey) sizez); -; setmaterial(blue); +; setmaterial(blue); (glNormal3f 0.0 sizey sizez); (glVertex3f (- sizex) bsizey sizez); @@ -323,7 +323,7 @@ (glEnd); -; setmaterial(red); +; setmaterial(red); (glBegin GL_TRIANGLES); (glNormal3f sizex sizey sizez); diff --git a/collects/games/paint-by-numbers/solve.rkt b/collects/games/paint-by-numbers/solve.rkt index 16c8298b96..9395b71652 100644 --- a/collects/games/paint-by-numbers/solve.rkt +++ b/collects/games/paint-by-numbers/solve.rkt @@ -1,5 +1,3 @@ - - (module solve mzscheme (require mzlib/list @@ -14,63 +12,63 @@ void)]) (define (solve row-info col-info set-entry setup-progress) - (local ( - (define (pause) '(sleep 1/16)) - - ; all test cases are commented out. - - ; to work on large lists, we must make filter tail-recursive. - ; this one reverses. + (local [ + (define (pause) '(sleep 1/16)) + + ; all test cases are commented out. + + ; to work on large lists, we must make filter tail-recursive. + ; this one reverses. ; filter-rev : returns a list of all elements in a-list which ; satisfy the predicate. If a precedes b in a-list, and both ; occur in the result, then b will precede a in the result. ; ((A -> boolean) (list-of A) -> (list-of A)) - (define (filter-rev fun a-list) - (foldl (lambda (elt built-list) - (if (fun elt) - (cons elt built-list) - built-list)) - null - a-list)) - - ;(equal? (filter-rev (lambda (x) (> x 13)) '(2 98 27 1 23 2 09)) - ; '(23 27 98)) - - - ; transpose : transposes a matrix represented as a list of lists - ; ((list-of (list-of T)) -> (list-of (list-of T))) - - (define (transpose list-list) - (apply map list list-list)) - - ;(equal? (transpose '((a b c d e) - ; (f g h i j) - ; (k l m n o))) - ; '((a f k) + (define (filter-rev fun a-list) + (foldl (lambda (elt built-list) + (if (fun elt) + (cons elt built-list) + built-list)) + null + a-list)) + + ;(equal? (filter-rev (lambda (x) (> x 13)) '(2 98 27 1 23 2 09)) + ; '(23 27 98)) + + + ; transpose : transposes a matrix represented as a list of lists + ; ((list-of (list-of T)) -> (list-of (list-of T))) + + (define (transpose list-list) + (apply map list list-list)) + + ;(equal? (transpose '((a b c d e) + ; (f g h i j) + ; (k l m n o))) + ; '((a f k) ; (b g l) - ; (c h m) - ; (d i n) - ; (e j o))) - + ; (c h m) + ; (d i n) + ; (e j o))) + ; TYPE-DECLARATIONS: ; there are three kinds of cell-list: the board-row-list, the tally-list, and the try-list. - ; + ; ; (type: board-row (list-of (union 'off 'on 'unknown))) ; (type: tally-row (list-of (union 'off 'on 'unknown 'maybe-off 'maybe-on 'mixed))) ; (type: try-row (list-of (union 'maybe-off 'maybe-on 'unknown))) (define try-row? (listof (symbols 'maybe-off 'maybe-on 'unknown))) (define try-batch? (listof (or/c number? (listof try-row?)))) - ; + ; ; (type: board (list-of board-row)) - ; board-ref : returns the board element in (col,row); + ; board-ref : returns the board element in (col,row); ; (board num num -> (union 'on 'off 'unknown)) - (define (board-ref board row col) + (define (board-ref board row col) (list-ref (list-ref board row) col)) ; board-width : returns the width of the board @@ -84,30 +82,30 @@ (define (board-height board) (length board)) - - ; extract-rows : returns the board as a list of rows + + ; extract-rows : returns the board as a list of rows ; (board -> board) - (define (extract-rows board) - board) - - ; extract-cols : returns the board as a list of columns + (define (extract-rows board) + board) + + ; extract-cols : returns the board as a list of columns ; (board -> board) - (define (extract-cols board) - (transpose board)) - + (define (extract-cols board) + (transpose board)) + ; reassemble-rows : turns a list of rows into a board ; (board -> board) - (define (reassemble-rows board-line-list) - board-line-list) - + (define (reassemble-rows board-line-list) + board-line-list) + ; reassemble-cols : turns a list of columns into a board ; (board -> board) - (define (reassemble-cols board-line-list) - (transpose board-line-list)) + (define (reassemble-cols board-line-list) + (transpose board-line-list)) ; entirely-unknown : does this row consist entirely of 'unknown? @@ -118,10 +116,10 @@ (define (finished? board) (not (ormap (lambda (row) (ormap (lambda (cell) (eq? cell 'unknown)) row)) board))) - + ; threshold info : the threshold is the limit at which - ; memoize-tries will simply give up. + ; memoize-tries will simply give up. (define initial-threshold 2000) @@ -153,48 +151,48 @@ ;(equal? (condensed->long-form '(((? !) u) (* () X O))) ; '(((maybe-on maybe-off) unknown) (mixed () off on))) - - ; check-changed : check whether a tally-row reveals new information to be added + + ; check-changed : check whether a tally-row reveals new information to be added ; to the grid ; (tally-row -> boolean) - (define (check-changed tally-list) - (ormap (lambda (cell) - (case cell - ((off on unknown mixed) #f) - ((maybe-off maybe-on) #t) - (else (error "unknown element found in check-changed: ~a" cell)))) - tally-list)) - + (define (check-changed tally-list) + (ormap (lambda (cell) + (case cell + ((off on unknown mixed) #f) + ((maybe-off maybe-on) #t) + (else (error "unknown element found in check-changed: ~a" cell)))) + tally-list)) + ;(and (equal? (check-changed '(off off on unknown mixed)) #f) - ; (equal? (check-changed '(off on maybe-off on mixed)) #t) + ; (equal? (check-changed '(off on maybe-off on mixed)) #t) ; (equal? (check-changed '(off maybe-on on on unknown)) #t)) - - ; rectify : transform a tally-row into a board row, by changing maybe-off + + ; rectify : transform a tally-row into a board row, by changing maybe-off ; to off and maybe-on to on. - ; (tally-row -> board-row) + ; (tally-row -> board-row) - (define (rectify tally-list) - (map (lambda (cell) - (case cell - ((off on unknown) cell) - ((maybe-off) 'off) - ((maybe-on) 'on) - ((mixed) 'unknown) - (else (error "unknown element in rectified row")))) - tally-list)) - - ;(equal? (rectify '(off on maybe-on mixed unknown maybe-off)) - ; '(off on on unknown unknown off)) - - ; make-row-formulator: - ; given a set of block lengths, create a function which accepts a - ; set of pads and formulates a try-row: - ; (num-list -> (num-list num -> (list-of (union 'maybe-off 'maybe-on 'unknown)))) - - (define (make-row-formulator blocks) - (lambda (pads) - (apply append + (define (rectify tally-list) + (map (lambda (cell) + (case cell + ((off on unknown) cell) + ((maybe-off) 'off) + ((maybe-on) 'on) + ((mixed) 'unknown) + (else (error "unknown element in rectified row")))) + tally-list)) + + ;(equal? (rectify '(off on maybe-on mixed unknown maybe-off)) + ; '(off on on unknown unknown off)) + + ; make-row-formulator: + ; given a set of block lengths, create a function which accepts a + ; set of pads and formulates a try-row: + ; (num-list -> (num-list num -> (list-of (union 'maybe-off 'maybe-on 'unknown)))) + + (define (make-row-formulator blocks) + (lambda (pads) + (apply append (let loop ([pads pads] [blocks blocks]) (cond [(null? (cdr pads)) @@ -205,12 +203,12 @@ (cons (build-list (car pads) (lambda (x) 'maybe-off)) (cons (build-list (car blocks) (lambda (x) 'maybe-on)) (loop (cdr pads) (cdr blocks))))]))))) - + #| - (equal? ((make-row-formulator '(3 1 1 5)) '(1 2 1 3 3)) - '(maybe-off maybe-on maybe-on maybe-on maybe-off maybe-off maybe-on maybe-off maybe-on - maybe-off maybe-off maybe-off maybe-on maybe-on maybe-on maybe-on maybe-on - maybe-off maybe-off maybe-off)) + (equal? ((make-row-formulator '(3 1 1 5)) '(1 2 1 3 3)) + '(maybe-off maybe-on maybe-on maybe-on maybe-off maybe-off maybe-on maybe-off maybe-on + maybe-off maybe-off maybe-off maybe-on maybe-on maybe-on maybe-on maybe-on + maybe-off maybe-off maybe-off)) (equal? ((make-row-formulator '(3 1 1 5)) '(2 4 4)) '(maybe-off maybe-off @@ -218,38 +216,38 @@ maybe-off maybe-off maybe-off maybe-off maybe-on unknown unknown unknown unknown unknown unknown unknown unknown unknown unknown)) - |# - - #| check-try : - see whether a try fits with the existing row information (curried) - (tally-row -> (try-row -> boolean)) - |# - - (define (check-try tally-list) - (lambda (try-list) - (andmap (lambda (tally try) + |# + + #| check-try : + see whether a try fits with the existing row information (curried) + (tally-row -> (try-row -> boolean)) + |# + + (define (check-try tally-list) + (lambda (try-list) + (andmap (lambda (tally try) (or (eq? try 'unknown) (case tally ((off) (eq? try 'maybe-off)) ((on) (eq? try 'maybe-on)) (else #t)))) - tally-list - try-list))) - - #| - (equal? ((check-try '(unknown off on unknown unknown unknown)) - '(maybe-on maybe-on maybe-on maybe-off maybe-off maybe-off)) - #f) - - (equal? ((check-try '(unknown off on unknown unknown unknown)) - '(maybe-off maybe-off maybe-on maybe-on maybe-on maybe-off)) - #t) + tally-list + try-list))) + + #| + (equal? ((check-try '(unknown off on unknown unknown unknown)) + '(maybe-on maybe-on maybe-on maybe-off maybe-off maybe-off)) + #f) + + (equal? ((check-try '(unknown off on unknown unknown unknown)) + '(maybe-off maybe-off maybe-on maybe-on maybe-on maybe-off)) + #t) (equal? ((check-try '(unknown off on unknown unknown unknown)) '(unknown unknown unknown unknown unknown unknown)) #t) - |# - + |# + #| choose : like math. as in, "9 choose 3" (num num -> num) |# @@ -295,17 +293,17 @@ (choose 29 4)) |# - #| build-possibles: - builds a list of the possible rows. given a number of spaces, and a number - of bins to put the spaces in, and a row-formulator, and a line-checker predicate, - build-possibles makes a list of every possible row which passes the predicate. + #| build-possibles: + builds a list of the possible rows. given a number of spaces, and a number + of bins to put the spaces in, and a row-formulator, and a line-checker predicate, + build-possibles makes a list of every possible row which passes the predicate. If the number of possibilities grows larger than the threshold, the search is aborted. - - (num num ((list-of num) -> try-row) (try-row -> bool) num -> (union (list-of try-row) #f)) - |# - - (define (build-possibles things total-bins row-formulator line-checker threshold) + + (num num ((list-of num) -> try-row) (try-row -> bool) num -> (union (list-of try-row) #f)) + |# + + (define (build-possibles things total-bins row-formulator line-checker threshold) (let/ec escape (let* ([built-list null] [list-length 0] @@ -335,9 +333,9 @@ (try-loop (+ in-this-bin 1)))))))) built-list))) - - #| - ;build-possibles test case + + #| + ;build-possibles test case (let* ([row-formulator-one (make-row-formulator '(2))] [line-checker (check-try '(unknown unknown unknown on unknown unknown))] [test-one (build-possibles 4 2 row-formulator-one line-checker 10000)] @@ -351,101 +349,101 @@ '((maybe-off maybe-off maybe-off maybe-on maybe-off maybe-on) (maybe-off maybe-on maybe-off maybe-on maybe-off maybe-off) (maybe-on maybe-off maybe-off maybe-on maybe-off maybe-off))))) - |# - - #| spare-spaces: - calculates the number of spare spaces in a line. In other words, - line-length - sum-of-all-blocks - - ((list-of num) num -> num) - |# - - (define (spare-spaces block-list line-length) - (let* ([black-spaces (apply + block-list)] - [spare-spaces (- line-length black-spaces)]) - spare-spaces)) - - ; first-pass: - ; generates the information about row contents which can be inferred directly - ; from the block info and nothing else (i.e., uses no information from an existing - ; board. - ; ((list-of (list-of num)) num -> (list-of (list-of (union 'on 'unknown)))) - - (define (first-pass info-list line-length) - (let ((row-pass - (lambda (block-list) - (let* ([spares (- (spare-spaces block-list line-length) (max 0 (- (length block-list) 1)))] - [shortened-blocks - (map (lambda (block-length) (- block-length spares)) - block-list)] - [all-but-start - (foldr append null - (let build-row-loop ([blocks-left shortened-blocks]) - (if (null? blocks-left) - null - (let ([extra-pad (if (null? (cdr blocks-left)) 0 1)]) - (if (> (car blocks-left) 0) - (cons (build-list (car blocks-left) (lambda (x) 'on)) - (cons (build-list (+ spares extra-pad) (lambda (x) 'unknown)) - (build-row-loop (cdr blocks-left)))) - (cons (build-list (+ spares extra-pad (car blocks-left)) - (lambda (x) 'unknown)) - (build-row-loop (cdr blocks-left))))))))] - [whole-row (append (build-list spares (lambda (x) 'unknown)) - all-but-start)]) - whole-row)))) - (map row-pass info-list))) - - #| - (let ([test-result (first-pass '((4 3) (5 1)) 10)]) - (equal? test-result '((unknown unknown on on unknown unknown unknown on unknown unknown) - (unknown unknown unknown on on unknown unknown unknown unknown unknown)))) - |# - - #| unify-passes: - unify the result of running first-pass on both the rows and the columns - (let ([BOARD (list-of (list-of (union 'unknown 'on)))]) - (BOARD BOARD -> BOARD)) - |# - - (define (unify-passes board-a board-b) - (let ([unify-rows - (lambda (row-a row-b) - (map (lambda (cell-a cell-b) - (case cell-a - ((on) 'on) - (else cell-b))) - row-a row-b))]) - (map unify-rows board-a board-b))) - - #| - (let* ([board-a '((unknown unknown on) (on unknown unknown))] - [board-b '((unknown on unknown) (on on unknown))] - [test-result (unify-passes board-a board-b)]) - (equal? test-result '((unknown on on) (on on unknown)))) - |# - - #| whole-first-pass: - take a set of row descriptions and the board dimensions and generate the - merged first-pass info - ((list-of (list-of num)) (list-of (list-of num)) num num -> - (list-of board-row)) - |# - - (define (whole-first-pass row-info col-info width height) - (unify-passes (first-pass row-info width) - (transpose (first-pass col-info height)))) - - #| memoize-tries: - given the black block widths and the line length and some initial board - and a progress-bar updater, calculate all possibilities for each row. + |# + + #| spare-spaces: + calculates the number of spare spaces in a line. In other words, + line-length - sum-of-all-blocks + + ((list-of num) num -> num) + |# + + (define (spare-spaces block-list line-length) + (let* ([black-spaces (apply + block-list)] + [spare-spaces (- line-length black-spaces)]) + spare-spaces)) + + ; first-pass: + ; generates the information about row contents which can be inferred directly + ; from the block info and nothing else (i.e., uses no information from an existing + ; board. + ; ((list-of (list-of num)) num -> (list-of (list-of (union 'on 'unknown)))) + + (define (first-pass info-list line-length) + (let ((row-pass + (lambda (block-list) + (let* ([spares (- (spare-spaces block-list line-length) (max 0 (- (length block-list) 1)))] + [shortened-blocks + (map (lambda (block-length) (- block-length spares)) + block-list)] + [all-but-start + (foldr append null + (let build-row-loop ([blocks-left shortened-blocks]) + (if (null? blocks-left) + null + (let ([extra-pad (if (null? (cdr blocks-left)) 0 1)]) + (if (> (car blocks-left) 0) + (cons (build-list (car blocks-left) (lambda (x) 'on)) + (cons (build-list (+ spares extra-pad) (lambda (x) 'unknown)) + (build-row-loop (cdr blocks-left)))) + (cons (build-list (+ spares extra-pad (car blocks-left)) + (lambda (x) 'unknown)) + (build-row-loop (cdr blocks-left))))))))] + [whole-row (append (build-list spares (lambda (x) 'unknown)) + all-but-start)]) + whole-row)))) + (map row-pass info-list))) + + #| + (let ([test-result (first-pass '((4 3) (5 1)) 10)]) + (equal? test-result '((unknown unknown on on unknown unknown unknown on unknown unknown) + (unknown unknown unknown on on unknown unknown unknown unknown unknown)))) + |# + + #| unify-passes: + unify the result of running first-pass on both the rows and the columns + (let ([BOARD (list-of (list-of (union 'unknown 'on)))]) + (BOARD BOARD -> BOARD)) + |# + + (define (unify-passes board-a board-b) + (let ([unify-rows + (lambda (row-a row-b) + (map (lambda (cell-a cell-b) + (case cell-a + ((on) 'on) + (else cell-b))) + row-a row-b))]) + (map unify-rows board-a board-b))) + + #| + (let* ([board-a '((unknown unknown on) (on unknown unknown))] + [board-b '((unknown on unknown) (on on unknown))] + [test-result (unify-passes board-a board-b)]) + (equal? test-result '((unknown on on) (on on unknown)))) + |# + + #| whole-first-pass: + take a set of row descriptions and the board dimensions and generate the + merged first-pass info + ((list-of (list-of num)) (list-of (list-of num)) num num -> + (list-of board-row)) + |# + + (define (whole-first-pass row-info col-info width height) + (unify-passes (first-pass row-info width) + (transpose (first-pass col-info height)))) + + #| memoize-tries: + given the black block widths and the line length and some initial board + and a progress-bar updater, calculate all possibilities for each row. If skip-unknowns is #t, rows whose content is entirely unknown will be skipped, and #f returned for that row. - effect: updates the progress bar - ((list-of (list-of num)) num (list-of board-row) (-> void) boolean -> (union (list-of try-row) #f)) - |# - - (define (memoize-tries info-list line-length board-rows old-tries threshold) + effect: updates the progress bar + ((list-of (list-of num)) num (list-of board-row) (-> void) boolean -> (union (list-of try-row) #f)) + |# + + (define (memoize-tries info-list line-length board-rows old-tries threshold) (let* ([unmemoized (filter number? old-tries)]) (if (null? unmemoized) old-tries @@ -464,133 +462,133 @@ old-tries info-list board-rows))))) - - #| - (equal? (memoize-tries '((4) (1 3)) - 6 - '((unknown on unknown unknown unknown unknown) - (unknown off unknown unknown unknown unknown)) - void) - '(((maybe-on maybe-on maybe-on maybe-on maybe-off maybe-off) - (maybe-off maybe-on maybe-on maybe-on maybe-on maybe-off)) - ((maybe-on maybe-off maybe-on maybe-on maybe-on maybe-off) - (maybe-on maybe-off maybe-off maybe-on maybe-on maybe-on)))) - |# - - #| batch-try: - take a board-line list and a list of possibles, and trim it down by - checking each try-list against the appropriate board-line - - ((list-of board-row) (list-of (union (list-of try-row) #f)) -> (list-of (union (list-of try-row) #f))) - |# - - (define (batch-try board-line-list try-list-list-list) - (map (lambda (line try-list-list) + + #| + (equal? (memoize-tries '((4) (1 3)) + 6 + '((unknown on unknown unknown unknown unknown) + (unknown off unknown unknown unknown unknown)) + void) + '(((maybe-on maybe-on maybe-on maybe-on maybe-off maybe-off) + (maybe-off maybe-on maybe-on maybe-on maybe-on maybe-off)) + ((maybe-on maybe-off maybe-on maybe-on maybe-on maybe-off) + (maybe-on maybe-off maybe-off maybe-on maybe-on maybe-on)))) + |# + + #| batch-try: + take a board-line list and a list of possibles, and trim it down by + checking each try-list against the appropriate board-line + + ((list-of board-row) (list-of (union (list-of try-row) #f)) -> (list-of (union (list-of try-row) #f))) + |# + + (define (batch-try board-line-list try-list-list-list) + (map (lambda (line try-list-list) (if (not (number? try-list-list)) (filter ; filter-rev (let ([f (check-try line)]) (lambda (try-list) (f try-list))) try-list-list) try-list-list)) - board-line-list - try-list-list-list)) - - #| - (equal? (batch-try '((unknown unknown unknown off) - (unknown on unknown unknown)) - '(((maybe-on maybe-on maybe-on maybe-off) - (maybe-off maybe-on maybe-on maybe-on)) - ((maybe-on maybe-on maybe-off maybe-off) - (maybe-off maybe-on maybe-on maybe-off) - (maybe-off maybe-off maybe-on maybe-on)))) - '(((maybe-on maybe-on maybe-on maybe-off)) - ((maybe-off maybe-on maybe-on maybe-off) - (maybe-on maybe-on maybe-off maybe-off)))) - |# - - ; tabulate-try : take one possibility, and merge it with the row possibles - ; (tally-list try-list) -> tally-list - - (define (tabulate-try tally-list try-list) - (map (lambda (tally try) - (case tally - ((off on mixed) tally) - ((unknown) try) - ((maybe-off maybe-on) (if (eq? try tally) - try - 'mixed)) - (else (error "unknown cell type during tabulate-try: ~a" tally)))) - tally-list - try-list)) - - - #| - (equal? (tabulate-try '(on off maybe-off maybe-off maybe-on maybe-on maybe-on) - '(on off mixed maybe-on maybe-on mixed maybe-off)) - '(on off mixed mixed maybe-on mixed mixed)) - |# - - ; batch-tabulate : take a board-line-list and a list of sets of tries which check with the board - ; and tabulate them all to produce a new board line list (before rectification) - ; (board-line-list try-list-list-opt-list) -> tally-list - (define (batch-tabulate board-line-list try-list-list-opt-list) - (map (lambda (board-line try-list-list-opt) + board-line-list + try-list-list-list)) + + #| + (equal? (batch-try '((unknown unknown unknown off) + (unknown on unknown unknown)) + '(((maybe-on maybe-on maybe-on maybe-off) + (maybe-off maybe-on maybe-on maybe-on)) + ((maybe-on maybe-on maybe-off maybe-off) + (maybe-off maybe-on maybe-on maybe-off) + (maybe-off maybe-off maybe-on maybe-on)))) + '(((maybe-on maybe-on maybe-on maybe-off)) + ((maybe-off maybe-on maybe-on maybe-off) + (maybe-on maybe-on maybe-off maybe-off)))) + |# + + ; tabulate-try : take one possibility, and merge it with the row possibles + ; (tally-list try-list) -> tally-list + + (define (tabulate-try tally-list try-list) + (map (lambda (tally try) + (case tally + ((off on mixed) tally) + ((unknown) try) + ((maybe-off maybe-on) (if (eq? try tally) + try + 'mixed)) + (else (error "unknown cell type during tabulate-try: ~a" tally)))) + tally-list + try-list)) + + + #| + (equal? (tabulate-try '(on off maybe-off maybe-off maybe-on maybe-on maybe-on) + '(on off mixed maybe-on maybe-on mixed maybe-off)) + '(on off mixed mixed maybe-on mixed mixed)) + |# + + ; batch-tabulate : take a board-line-list and a list of sets of tries which check with the board + ; and tabulate them all to produce a new board line list (before rectification) + ; (board-line-list try-list-list-opt-list) -> tally-list + (define (batch-tabulate board-line-list try-list-list-opt-list) + (map (lambda (board-line try-list-list-opt) (if (not (number? try-list-list-opt)) (foldl (lambda (x y) (tabulate-try y x)) board-line try-list-list-opt) board-line)) - board-line-list - try-list-list-opt-list)) - - - ; (equal? (batch-tabulate '((unknown unknown unknown off) - ; (unknown unknown on unknown)) - ; '(((maybe-on maybe-on maybe-off maybe-off) - ; (maybe-off maybe-on maybe-on maybe-off)) - ; ((maybe-off maybe-on maybe-on maybe-off) - ; (maybe-off maybe-off maybe-on maybe-on)))) - ; '((mixed maybe-on mixed off) - ; (maybe-off mixed on mixed))) - - (define (print-board board) - (for-each (lambda (row) - (for-each (lambda (cell) - (printf (case cell - ((off) " ") - ((unknown) ".") - ((on) "#")))) - row) - (printf "\n")) - (extract-rows board))) - - ; animate-changes takes a board and draws it on the main screen - (define (animate-changes board draw-thunk outer-size inner-size) - (let outer-loop ([outer-index 0]) - (if (= outer-index outer-size) - null - (let inner-loop ([inner-index 0]) - (if (= inner-index inner-size) - (begin - (pause) - (outer-loop (+ outer-index 1))) - (begin - (draw-thunk board outer-index inner-index) - (inner-loop (+ inner-index 1)))))))) - - (define (draw-rows-thunk board row col) - (set-entry col row (board-ref board row col))) - - (define (draw-cols-thunk board col row) - (set-entry col row (board-ref board row col))) - - ; (print-board '((on on unknown off) - ; (on on unknown unknown) - ; (unknown unknown on on) - ; (off unknown on on))) - - ; do-lines takes a board-line-list and a try-list-list-list and returns two things: a tally-list-list - ; and a new try-list-list-list - ; (board-line-list try-list-list-opt-list) -> (tally-list-list try-list-list-opt-list) - (define do-lines + board-line-list + try-list-list-opt-list)) + + + ; (equal? (batch-tabulate '((unknown unknown unknown off) + ; (unknown unknown on unknown)) + ; '(((maybe-on maybe-on maybe-off maybe-off) + ; (maybe-off maybe-on maybe-on maybe-off)) + ; ((maybe-off maybe-on maybe-on maybe-off) + ; (maybe-off maybe-off maybe-on maybe-on)))) + ; '((mixed maybe-on mixed off) + ; (maybe-off mixed on mixed))) + + (define (print-board board) + (for-each (lambda (row) + (for-each (lambda (cell) + (printf (case cell + ((off) " ") + ((unknown) ".") + ((on) "#")))) + row) + (printf "\n")) + (extract-rows board))) + + ; animate-changes takes a board and draws it on the main screen + (define (animate-changes board draw-thunk outer-size inner-size) + (let outer-loop ([outer-index 0]) + (if (= outer-index outer-size) + null + (let inner-loop ([inner-index 0]) + (if (= inner-index inner-size) + (begin + (pause) + (outer-loop (+ outer-index 1))) + (begin + (draw-thunk board outer-index inner-index) + (inner-loop (+ inner-index 1)))))))) + + (define (draw-rows-thunk board row col) + (set-entry col row (board-ref board row col))) + + (define (draw-cols-thunk board col row) + (set-entry col row (board-ref board row col))) + + ; (print-board '((on on unknown off) + ; (on on unknown unknown) + ; (unknown unknown on on) + ; (off unknown on on))) + + ; do-lines takes a board-line-list and a try-list-list-list and returns two things: a tally-list-list + ; and a new try-list-list-list + ; (board-line-list try-list-list-opt-list) -> (tally-list-list try-list-list-opt-list) + (define do-lines (contract (->* (any/c try-batch?) ((listof (listof any/c)) try-batch?)) @@ -600,10 +598,10 @@ new-tries))) 'do-lines 'caller)) - - ; full-set takes a board and a pair of try-list-list-lists and returns a new board, a new pair - ; of try-list-list-lists, and a boolean (whether it's changed) - (define full-set + + ; full-set takes a board and a pair of try-list-list-lists and returns a new board, a new pair + ; of try-list-list-lists, and a boolean (whether it's changed) + (define full-set (contract (->* (any/c try-batch? try-batch?) (any/c try-batch? try-batch? boolean?)) @@ -633,15 +631,15 @@ (values final-board new-row-tries new-col-tries (or row-changed col-changed)))) 'full-set 'caller)) - + ; on 2002-10-17, I wrapped another layer of looping around the inner loop. ; the purpose of this outer loop is to allow the solver to ignore rows (or ; columns) about which the solver knows nothing for as long as possible. - (define (local-solve row-info col-info) - (let* ([rows (length row-info)] - [cols (length col-info)] - [initial-board (whole-first-pass row-info col-info cols rows)] + (define (local-solve row-info col-info) + (let* ([rows (length row-info)] + [cols (length col-info)] + [initial-board (whole-first-pass row-info col-info cols rows)] [_ (animate-changes initial-board draw-cols-thunk (board-width initial-board) (board-height initial-board))]) @@ -668,7 +666,7 @@ (outer-loop board (next-threshold skip-threshold) row-tries col-tries) (outer-loop board skip-threshold row-tries col-tries))))))))) - ) + ] (local-solve row-info col-info) ))) diff --git a/collects/graphics/graphics-posn-less-unit.rkt b/collects/graphics/graphics-posn-less-unit.rkt index 7a04ac8a97..5ce087837d 100644 --- a/collects/graphics/graphics-posn-less-unit.rkt +++ b/collects/graphics/graphics-posn-less-unit.rkt @@ -206,8 +206,8 @@ (lambda () (set! the-world (with-handlers ([exn:break? break-handler] - [exn? exn-handler]) - (on-tick-proc the-world))))) + [exn? exn-handler]) + (on-tick-proc the-world))))) ;; World -> World (define on-tick-proc void) (define exn-handler diff --git a/collects/graphics/turtle-test.rkt b/collects/graphics/turtle-test.rkt index fd92389b34..d509bfd9c8 100644 --- a/collects/graphics/turtle-test.rkt +++ b/collects/graphics/turtle-test.rkt @@ -40,6 +40,6 @@ stretchable-width #t)) options) - (make-object grow-box-spacer-pane% frame) + (make-object grow-box-spacer-pane% frame) (send frame show #t)) diff --git a/collects/gui-debugger/TODO.txt b/collects/gui-debugger/TODO.txt index c2a6e9d15c..cab4f1f3a7 100644 --- a/collects/gui-debugger/TODO.txt +++ b/collects/gui-debugger/TODO.txt @@ -1,7 +1,7 @@ - Stack navigation from REPL - Automated tests -- Trace by function name - +- Trace by function name + CHANGES TO MAKE----------------------------------------------------------------------------- Ability to add named anchors into code using Special menu in DRS -- use those anchors as tracepoints. @@ -10,8 +10,8 @@ Demo monitoring DrRacket for Robby? Bind Stop button to kill-all. On the whole, I like the tool, although it'd be nice to have either - (a) an interactive pointy-clicky interface rather than figuring - out line/column co-ordinates, or + (a) an interactive pointy-clicky interface rather than figuring + out line/column co-ordinates, or Re-direct, or at least prefix, program output from the client so that it can be distinguished from the script diff --git a/collects/gui-debugger/debug-tool.rkt b/collects/gui-debugger/debug-tool.rkt index b0e2fb1dcb..bfa60c5f6b 100644 --- a/collects/gui-debugger/debug-tool.rkt +++ b/collects/gui-debugger/debug-tool.rkt @@ -61,8 +61,8 @@ debugger-language<%> (lambda (superclass) (class* superclass (debugger-language<%>) - (public debugger:supported?) - (define (debugger:supported?) #t) + (public debugger:supported?) + (define (debugger:supported?) #t) (super-instantiate ()))))) (define phase2 void) @@ -1392,8 +1392,8 @@ (bitmap debug-bitmap) (alternate-bitmap small-debug-bitmap) (parent (new vertical-pane% - [parent (get-button-panel)] - [alignment '(center center)])) + [parent (get-button-panel)] + [alignment '(center center)])) (callback (λ (button) (debug-callback))))) (inherit register-toolbar-button) (register-toolbar-button debug-button #:number 60) diff --git a/collects/htdp/hangman.rkt b/collects/htdp/hangman.rkt index ed5501c46b..c12d5684c9 100644 --- a/collects/htdp/hangman.rkt +++ b/collects/htdp/hangman.rkt @@ -104,7 +104,7 @@ xylaphon yellow zombie)) - WORDS)) + WORDS)) ;; ------------------------------------------------------------------------ ;; The GUI @@ -122,11 +122,11 @@ ------------------------------------------------ | | - | a ... z "Check" "Status" word | + | a ... z "Check" "Status" word | | choice% button% message% message% | - | | + | | | Welcome/Winner/Loser | - | message% | + | message% | ------------------------------------------------ |# diff --git a/collects/htdp/matrix.txt b/collects/htdp/matrix.txt index 1306be5607..b891322958 100644 --- a/collects/htdp/matrix.txt +++ b/collects/htdp/matrix.txt @@ -3,33 +3,33 @@ rectangle: a list of lists of equal length -files: - mrlib/matrix-snip.ss : the image snips for matrix +files: + mrlib/matrix-snip.ss : the image snips for matrix - works with matrices that implement matrix<%> - i.e., support a ->rectangle method + works with matrices that implement matrix<%> + i.e., support a ->rectangle method - it writes out a matrix as a rectangle and - reconstructs it as a rectangle + it writes out a matrix as a rectangle and + reconstructs it as a rectangle - the function visible-matrix may therefore yield a - rectangle or a matrix representation proper + the function visible-matrix may therefore yield a + rectangle or a matrix representation proper - drscheme/private/eval.ss : requires matrix-snip to share at module level + drscheme/private/eval.ss : requires matrix-snip to share at module level htdp/matrix.ss : uses snips to present matrices, requires matrix-snip htdp/matrix-invisible.ss : make matrices invisible - * they are created from two mutually recursive units: - * matrix-unit and a 'rendering' unit + * they are created from two mutually recursive units: + * matrix-unit and a 'rendering' unit - htdp/matrix-sig.ss : the functions that matrix-unit.ss provides - and that matrix-render.ss needs + htdp/matrix-sig.ss : the functions that matrix-unit.ss provides + and that matrix-render.ss needs - htdp/matrix-render-sig.ss: the functions that matrix-unit expects from the - rendering unit + htdp/matrix-render-sig.ss: the functions that matrix-unit expects from the + rendering unit - htdp/matrix-unit.ss : the matrix functionality + htdp/matrix-unit.ss : the matrix functionality - htdp/tests/matrix-test.ss: a textual test - htdp/tests/matrix-client.ss a test with embedded images + htdp/tests/matrix-test.ss: a textual test + htdp/tests/matrix-client.ss a test with embedded images diff --git a/collects/htdp/world.rkt b/collects/htdp/world.rkt index 8c8235bb4c..1333f9eeec 100644 --- a/collects/htdp/world.rkt +++ b/collects/htdp/world.rkt @@ -108,7 +108,7 @@ Matthew ;; world manipulation functions: ;; ============================= (provide ;; forall(World): - big-bang ;; Number Number Number World [Boolean] -> true + big-bang ;; Number Number Number World [Boolean] -> true ) (provide-higher-order-primitive @@ -849,7 +849,7 @@ Matthew (define y (- (send e get-y) INSET)) (define m (mouse-event->symbol e)) (when (and (<= 0 x WIDTH) (<= 0 y HEIGHT)) - (with-handlers ([exn:break? break-handler][exn? exn-handler]) + (with-handlers ([exn:break? break-handler][exn? exn-handler]) (let ([new-world (f the-world x y m)]) (unless (equal? new-world the-world) (set! the-world new-world) diff --git a/collects/lang/htdp-beginner-abbr.rkt b/collects/lang/htdp-beginner-abbr.rkt index a6bb01796a..bb494b704b 100644 --- a/collects/lang/htdp-beginner-abbr.rkt +++ b/collects/lang/htdp-beginner-abbr.rkt @@ -46,11 +46,11 @@ #%top-interaction empty - ; signature : -> mixed one-of predicate combined - ; Number Real Rational Integer Natural Boolean True False String Symbol Char Empty-list Any - ; cons-of - ; Property - ; check-property for-all ==> expect expect-within expect-member-of expect-range + ; signature : -> mixed one-of predicate combined + ; Number Real Rational Integer Natural Boolean True False String Symbol Char Empty-list Any + ; cons-of + ; Property + ; check-property for-all ==> expect expect-within expect-member-of expect-range ) ;; procedures: diff --git a/collects/lang/htdp-beginner.rkt b/collects/lang/htdp-beginner.rkt index 38d36f063a..071b18d647 100644 --- a/collects/lang/htdp-beginner.rkt +++ b/collects/lang/htdp-beginner.rkt @@ -51,11 +51,11 @@ #%top-interaction empty - ; signature : -> mixed one-of predicate combined - ; Number Real Rational Integer Natural Boolean True False String Symbol Char Empty-list Any - ; cons-of - ; Property - ; check-property for-all ==> expect expect-within expect-member-of expect-range + ; signature : -> mixed one-of predicate combined + ; Number Real Rational Integer Natural Boolean True False String Symbol Char Empty-list Any + ; cons-of + ; Property + ; check-property for-all ==> expect expect-within expect-member-of expect-range ) ;; procedures: diff --git a/collects/lang/htdp-intermediate-lambda.rkt b/collects/lang/htdp-intermediate-lambda.rkt index 26963134e4..55298bca69 100644 --- a/collects/lang/htdp-intermediate-lambda.rkt +++ b/collects/lang/htdp-intermediate-lambda.rkt @@ -51,11 +51,11 @@ #%top-interaction empty - ; signature : -> mixed one-of predicate combined - ; Number Real Rational Integer Natural Boolean True False String Symbol Char Empty-list Any - ; cons-of - ; Property - ; check-property for-all ==> expect expect-within expect-member-of expect-range + ; signature : -> mixed one-of predicate combined + ; Number Real Rational Integer Natural Boolean True False String Symbol Char Empty-list Any + ; cons-of + ; Property + ; check-property for-all ==> expect expect-within expect-member-of expect-range ) ;; procedures: diff --git a/collects/lang/htdp-intermediate.rkt b/collects/lang/htdp-intermediate.rkt index 11edaae542..b488cbfb39 100644 --- a/collects/lang/htdp-intermediate.rkt +++ b/collects/lang/htdp-intermediate.rkt @@ -52,11 +52,11 @@ #%top-interaction empty - ; signature : -> mixed one-of predicate combined - ; Number Real Rational Integer Natural Boolean True False String Symbol Char Empty-list Any - ; cons-of - ; Property - ; check-property for-all ==> expect expect-within expect-member-of expect-range + ; signature : -> mixed one-of predicate combined + ; Number Real Rational Integer Natural Boolean True False String Symbol Char Empty-list Any + ; cons-of + ; Property + ; check-property for-all ==> expect expect-within expect-member-of expect-range ) diff --git a/collects/lang/private/advanced-funs.rkt b/collects/lang/private/advanced-funs.rkt index 656483110d..dbf562e07c 100644 --- a/collects/lang/private/advanced-funs.rkt +++ b/collects/lang/private/advanced-funs.rkt @@ -69,43 +69,43 @@ } @defproc[(with-input-from-string [s string] [p (-> any)]) any]{ Turns @racket[s] into input for @racket[read] operations in @racket[p]. - @interaction[#:eval (asl) - (with-input-from-string "hello" read) - (string-length (symbol->string (with-input-from-string "hello" read)))] + @interaction[#:eval (asl) + (with-input-from-string "hello" read) + (string-length (symbol->string (with-input-from-string "hello" read)))] } @defproc[(with-output-to-string [p (-> any)]) any]{ Produces a string from all write/display/print operations in @racket[p]. @interaction[#:eval (asl) - (with-output-to-string (lambda () (display 10)))] + (with-output-to-string (lambda () (display 10)))] } @defproc[(print [x any]) void]{ Prints the argument as a value. @interaction[#:eval (asl) - (print 10) - (print "hello") - (print 'hello)] + (print 10) + (print "hello") + (print 'hello)] } @defproc[(display [x any]) void]{ Prints the argument to stdout (without quotes on symbols and strings, etc.). @interaction[#:eval (asl) - (display 10) - (display "hello") - (display 'hello)] + (display 10) + (display "hello") + (display 'hello)] } @defproc[(write [x any]) void]{ Prints the argument to stdout (in a traditional style that is somewhere between @racket[print] and @racket[display]). @interaction[#:eval (asl) - (write 10) - (write "hello") - (write 'hello)] + (write 10) + (write "hello") + (write 'hello)] } @defproc[((pp pretty-print) [x any]) void]{ Pretty prints S-expressions (like @racket[write]). @interaction[#:eval (asl) - (pretty-print '((1 2 3) ((a) ("hello world" true) (((false "good bye")))))) - (pretty-print (build-list 10 (lambda (i) (build-list 10 (lambda (j) (= i j)))))) - ] + (pretty-print '((1 2 3) ((a) ("hello world" true) (((false "good bye")))))) + (pretty-print (build-list 10 (lambda (i) (build-list 10 (lambda (j) (= i j)))))) + ] } @defproc[(printf [f string] [x any] ...) void]{ @@ -189,7 +189,7 @@ @defproc[(build-vector [n nat] [f (nat -> X)]) (vectorof X)]{ Constructs a vector by applying @racket[f] to the numbers @racket[0] through @racket[(- n 1)]. @interaction[#:eval (asl) (build-vector 5 add1)] - } + } @defproc[(vector-ref [v (vector X)] [n nat]) X]{ Extracts the @racket[n]th element from @racket[v]. @interaction[#:eval (asl) v (vector-ref v 3)] @@ -197,7 +197,7 @@ @defproc[(vector-length [v (vector X)]) nat]{ Determines the length of @racket[v]. @interaction[#:eval (asl) v (vector-length v)] - } + } @defproc[(vector-set! [v (vectorof X)][n nat][x X]) void]{ Updates @racket[v] at position @racket[n] to be @racket[x]. @interaction[#:eval (asl) v (vector-set! v 3 77) v] @@ -238,49 +238,49 @@ Constructs a mutable hash table from an optional list of mappings that uses equal? for comparisions. @interaction[#:eval (asl) - (make-hash) - (make-hash '((b 69) (e 61) (i 999))) - ] + (make-hash) + (make-hash '((b 69) (e 61) (i 999))) + ] } @defproc[((advanced-make-hasheq make-hasheq)) (hash X Y)]{ Constructs a mutable hash table from an optional list of mappings that uses eq? for comparisions. @interaction[#:eval (asl) - (make-hasheq) - (make-hasheq '((b 69) (e 61) (i 999))) - ] + (make-hasheq) + (make-hasheq '((b 69) (e 61) (i 999))) + ] } @defproc[((advanced-make-hasheqv make-hasheqv)) (hash X Y)]{ Constructs a mutable hash table from an optional list of mappings that uses eqv? for comparisions. @interaction[#:eval (asl) - (make-hasheqv) - (make-hasheqv '((b 69) (e 61) (i 999))) - ] + (make-hasheqv) + (make-hasheqv '((b 69) (e 61) (i 999))) + ] } @defproc[((advanced-make-immutable-hash make-immutable-hash)) (hash X Y)]{ Constructs an immutable hash table from an optional list of mappings that uses equal? for comparisions. @interaction[#:eval (asl) - (make-immutable-hash) - (make-immutable-hash '((b 69) (e 61) (i 999))) - ] + (make-immutable-hash) + (make-immutable-hash '((b 69) (e 61) (i 999))) + ] } @defproc[((advanced-make-immutable-hasheq make-immutable-hasheq)) (hash X Y)]{ Constructs an immutable hash table from an optional list of mappings that uses eq? for comparisions. @interaction[#:eval (asl) - (make-immutable-hasheq) - (make-immutable-hasheq '((b 69) (e 61) (i 999))) - ] + (make-immutable-hasheq) + (make-immutable-hasheq '((b 69) (e 61) (i 999))) + ] } @defproc[((advanced-make-immutable-hasheqv make-immutable-hasheqv)) (hash X Y)]{ Constructs an immutable hash table from an optional list of mappings that uses eqv? for comparisions. @interaction[#:eval (asl) - (make-immutable-hasheqv) - (make-immutable-hasheqv '((b 69) (e 61) (i 999))) - ] + (make-immutable-hasheqv) + (make-immutable-hasheqv '((b 69) (e 61) (i 999))) + ] } @defproc[(hash-set! [h (hash X Y)] [k X] [v Y]) void?]{ Updates a mutable hash table with a new mapping. @@ -318,44 +318,44 @@ @defproc[(hash-has-key? [h (hash X Y)] [x X]) boolean]{ Determines if a key is associated with a value in a hash table. @interaction[#:eval (asl) - ish - (hash-has-key? ish 'b) - hsh - (hash-has-key? hsh 'd)] + ish + (hash-has-key? ish 'b) + hsh + (hash-has-key? hsh 'd)] } @defproc[(hash-remove! [h (hash X Y)] [x X]) void]{ Removes an mapping from a mutable hash table. @interaction[#:eval (asl) - hsh - (hash-remove! hsh 'r) - hsh] + hsh + (hash-remove! hsh 'r) + hsh] } @defproc[(hash-remove [h (hash X Y)] [k X]) (hash X Y)]{ Constructs an immutable hash table with one less mapping than an existing immutable hash table. @interaction[#:eval (asl) - ish - (hash-remove ish 'b)] + ish + (hash-remove ish 'b)] } @defproc[(hash-map [h (hash X Y)] [f (X Y -> Z)]) (listof Z)]{ Constructs a new list by applying a function to each mapping of a hash table. @interaction[#:eval (asl) - ish - (hash-map ish list)] + ish + (hash-map ish list)] } @defproc[(hash-for-each [h (hash X Y)] [f (X Y -> any)]) void?]{ Applies a function to each mapping of a hash table for effect only. @interaction[#:eval (asl) - hsh - (hash-for-each hsh (lambda (ky vl) (hash-set! hsh ky (+ vl 1)))) - hsh] + hsh + (hash-for-each hsh (lambda (ky vl) (hash-set! hsh ky (+ vl 1)))) + hsh] } @defproc[(hash-count [h hash]) integer]{ Determines the number of keys mapped by a hash table. @interaction[#:eval (asl) - ish - (hash-count ish)] + ish + (hash-count ish)] } @defproc[(hash-copy [h hash]) hash]{ Copies a hash table. @@ -363,36 +363,36 @@ @defproc[(hash? [x any]) boolean]{ Determines if a value is a hash table. @interaction[#:eval (asl) - ish - (hash? ish) - (hash? 42)] + ish + (hash? ish) + (hash? 42)] } @defproc[(hash-equal? [h hash?]) boolean]{ Determines if a hash table uses equal? for comparisons. @interaction[#:eval (asl) - ish - (hash-equal? ish) - ieq - (hash-equal? ieq) - ] + ish + (hash-equal? ish) + ieq + (hash-equal? ieq) + ] } @defproc[(hash-eq? [h hash]) boolean]{ Determines if a hash table uses eq? for comparisons. @interaction[#:eval (asl) - hsh - (hash-eq? hsh) - heq - (hash-eq? heq) - ] + hsh + (hash-eq? hsh) + heq + (hash-eq? heq) + ] } @defproc[(hash-eqv? [h hash]) boolean]{ Determines if a hash table uses eqv? for comparisons. @interaction[#:eval (asl) - heq - (hash-eqv? heq) - heqv - (hash-eqv? heqv) - ] + heq + (hash-eqv? heq) + heqv + (hash-eqv? heqv) + ] })) #| diff --git a/collects/lang/private/continuation-mark-key.rkt b/collects/lang/private/continuation-mark-key.rkt index 4646862d79..ff3ec8a942 100644 --- a/collects/lang/private/continuation-mark-key.rkt +++ b/collects/lang/private/continuation-mark-key.rkt @@ -5,5 +5,5 @@ ; The test code also needs access to this. ;; cm-key : symbol -;; the key used to put information on the continuation +;; the key used to put information on the continuation (define teaching-languages-continuation-mark-key (gensym 'teaching-languages-continuation-mark-key)) diff --git a/collects/lang/private/teach.rkt b/collects/lang/private/teach.rkt index 0d51932a11..f434efff45 100644 --- a/collects/lang/private/teach.rkt +++ b/collects/lang/private/teach.rkt @@ -948,7 +948,7 @@ raw-predicate sigs #'name_))) - (let ((arbs (map signature-arbitrary sigs))) + (let ((arbs (map signature-arbitrary sigs))) (when (andmap values arbs) (set-signature-arbitrary! sig @@ -1914,7 +1914,7 @@ (let ([bindings (syntax->list (syntax (binding ...)))]) (for-each (lambda (binding) (syntax-case binding () - [(something . exprs) + [(something . exprs) (not (identifier/non-kw? (syntax something))) (teach-syntax-error who @@ -2445,7 +2445,7 @@ who stx #'q - "expected a question and an answer, but found only one part")] + "expected a question and an answer, but found only one part")] [(_ q a) (with-syntax ([who who] [target target-stx]) diff --git a/collects/mred/private/moredialogs.rkt b/collects/mred/private/moredialogs.rkt index bec55f36ee..d3bc8c06c8 100644 --- a/collects/mred/private/moredialogs.rkt +++ b/collects/mred/private/moredialogs.rkt @@ -329,7 +329,7 @@ (send blue get-value)))] [install-color (lambda (color) - (send red set-value (send color red)) + (send red set-value (send color red)) (send green set-value (send color green)) (send blue set-value (send color blue)) (send canvas refresh))]) diff --git a/collects/mred/private/mrcanvas.rkt b/collects/mred/private/mrcanvas.rkt index 627f831dbf..462e654cf7 100644 --- a/collects/mred/private/mrcanvas.rkt +++ b/collects/mred/private/mrcanvas.rkt @@ -19,9 +19,10 @@ (define canvas-default-size 20) ; a default size for canvases tht fits borders without losing client sizes (define canvas-scroll-size 10) -(define canvas-control-border-extra (case (system-type) - [(windows) 2] - [else 0])) +(define canvas-control-border-extra + (case (system-type) + [(windows) 2] + [else 0])) (define canvas<%> (interface (subwindow<%>) diff --git a/collects/mred/private/wx/cocoa/agl.rkt b/collects/mred/private/wx/cocoa/agl.rkt index 796661f65e..aca1f8e50d 100644 --- a/collects/mred/private/wx/cocoa/agl.rkt +++ b/collects/mred/private/wx/cocoa/agl.rkt @@ -54,12 +54,12 @@ (define AGL_PIXEL_SIZE 50) (define AGL_OFFSCREEN 53) (define AGL_SAMPLE_BUFFERS_ARB 55) -(define AGL_SAMPLES_ARB 56) -(define AGL_AUX_DEPTH_STENCIL 57) -(define AGL_COLOR_FLOAT 58) -(define AGL_MULTISAMPLE 59) -(define AGL_SUPERSAMPLE 60) -(define AGL_SAMPLE_ALPHA 61) +(define AGL_SAMPLES_ARB 56) +(define AGL_AUX_DEPTH_STENCIL 57) +(define AGL_COLOR_FLOAT 58) +(define AGL_MULTISAMPLE 59) +(define AGL_SUPERSAMPLE 60) +(define AGL_SAMPLE_ALPHA 61) (define dummy-agl #f) (define current-agl #f) diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt index 59aea507d6..15841e0799 100644 --- a/collects/mred/private/wx/gtk/types.rkt +++ b/collects/mred/private/wx/gtk/types.rkt @@ -8,8 +8,8 @@ _GdkScreen _gpointer _GType - _GdkEventType - _GdkAtom + _GdkEventType + _GdkAtom _fnpointer _gboolean @@ -31,9 +31,9 @@ (struct-out GdkEventExpose) _GdkEventFocus _GdkEventFocus-pointer (struct-out GdkEventFocus) - _GdkEventSelection _GdkEventSelection-pointer + _GdkEventSelection _GdkEventSelection-pointer (struct-out GdkEventSelection) - _GdkRectangle _GdkRectangle-pointer + _GdkRectangle _GdkRectangle-pointer (struct-out GdkRectangle) _GdkColor _GdkColor-pointer (struct-out GdkColor))) @@ -135,11 +135,11 @@ (define-cstruct _GdkEventSelection ([type _GdkEventType] [window _GdkWindow] [send_event _byte] - [selection _GdkAtom] - [target _GdkAtom] - [property _GdkAtom] - [time _uint32] - [requestor _pointer])) + [selection _GdkAtom] + [target _GdkAtom] + [property _GdkAtom] + [time _uint32] + [requestor _pointer])) (define-cstruct _GdkRectangle ([x _int] [y _int] @@ -155,8 +155,8 @@ (define-cstruct _GdkEventFocus ([type _GdkEventType] [window _GdkWindow] - [send_event _byte] - [in _short])) + [send_event _byte] + [in _short])) (define-cstruct _GdkColor ([pixel _uint32] [red _uint16] diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 216d54612a..8ee9903361 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -1,7 +1,7 @@ #lang racket/base (require ffi/unsafe racket/class - net/uri-codec + net/uri-codec ffi/unsafe/atomic "../../syntax.rkt" "../../lock.rkt" @@ -18,7 +18,7 @@ "const.rkt" "types.rkt" "widget.rkt" - "clipboard.rkt") + "clipboard.rkt") (provide (protect-out window% @@ -35,7 +35,7 @@ connect-focus connect-key-and-mouse - connect-enter-and-leave + connect-enter-and-leave do-button-event (struct-out GtkRequisition) _GtkRequisition-pointer @@ -54,9 +54,9 @@ request-flush-delay cancel-flush-delay - win-box-valid? - window->win-box - unrealize-win-box) + win-box-valid? + window->win-box + unrealize-win-box) gtk->wx gtk_widget_show gtk_widget_hide) @@ -92,15 +92,15 @@ (define the-accelerator-group (gtk_accel_group_new)) (define-cstruct _GtkWidgetT ([obj _GtkObject] - [private_flags _uint16] - [state _byte] - [saved_state _byte] - [name _pointer] - [style _pointer] - [req _GtkRequisition] - [alloc _GtkAllocation] - [window _GdkWindow] - [parent _GtkWidget])) + [private_flags _uint16] + [state _byte] + [saved_state _byte] + [name _pointer] + [style _pointer] + [req _GtkRequisition] + [alloc _GtkAllocation] + [window _GdkWindow] + [parent _GtkWidget])) (define (widget-window gtk) (GtkWidgetT-window (cast gtk _GtkWidget _GtkWidgetT-pointer))) @@ -123,20 +123,20 @@ (lambda (gtk context x y data info time) (let ([wx (gtk->wx gtk)]) (when wx - (let ([bstr (scheme_make_sized_byte_string - (gtk_selection_data_get_data data) - (gtk_selection_data_get_length data) - 1)]) - (cond - [(regexp-match #rx#"^file://(.*)\r\n$" bstr) - => (lambda (m) - (queue-window-event wx - (lambda () - (let ([path - (string->path - (uri-decode - (bytes->string/utf-8 (cadr m))))]) - (send wx on-drop-file path)))))])))))) + (let ([bstr (scheme_make_sized_byte_string + (gtk_selection_data_get_data data) + (gtk_selection_data_get_length data) + 1)]) + (cond + [(regexp-match #rx#"^file://(.*)\r\n$" bstr) + => (lambda (m) + (queue-window-event wx + (lambda () + (let ([path + (string->path + (uri-decode + (bytes->string/utf-8 (cadr m))))]) + (send wx on-drop-file path)))))])))))) ;; ---------------------------------------- @@ -147,7 +147,7 @@ (when wx (send wx focus-change #t) (when (send wx on-focus? #t) - (queue-window-event wx (lambda () (send wx on-set-focus))))) + (queue-window-event wx (lambda () (send wx on-set-focus))))) #f))) (define-signal-handler connect-focus-out "focus-out-event" (_fun _GtkWidget _GdkEventFocus-pointer -> _gboolean) @@ -195,72 +195,72 @@ (and wx (let ([im-str (if scroll? - 'none - ;; Result from `filter-key-event' is one of - ;; - #f => drop the event - ;; - 'none => no replacement; handle as usual - ;; - a string => use as the keycode - (send wx filter-key-event event))]) + 'none + ;; Result from `filter-key-event' is one of + ;; - #f => drop the event + ;; - 'none => no replacement; handle as usual + ;; - a string => use as the keycode + (send wx filter-key-event event))]) (when im-str - (let* ([modifiers (if scroll? - (GdkEventScroll-state event) - (GdkEventKey-state event))] - [bit? (lambda (m v) (positive? (bitwise-and m v)))] - [keyval->code (lambda (kv) - (or - (map-key-code kv) - (integer->char (gdk_keyval_to_unicode kv))))] - [key-code (if scroll? - (let ([dir (GdkEventScroll-direction event)]) + (let* ([modifiers (if scroll? + (GdkEventScroll-state event) + (GdkEventKey-state event))] + [bit? (lambda (m v) (positive? (bitwise-and m v)))] + [keyval->code (lambda (kv) + (or + (map-key-code kv) + (integer->char (gdk_keyval_to_unicode kv))))] + [key-code (if scroll? + (let ([dir (GdkEventScroll-direction event)]) (cond [(= dir GDK_SCROLL_UP) 'wheel-up] [(= dir GDK_SCROLL_DOWN) 'wheel-down] [(= dir GDK_SCROLL_LEFT) 'wheel-left] [(= dir GDK_SCROLL_RIGHT) 'wheel-right])) - (keyval->code (GdkEventKey-keyval event)))] - [k (new key-event% - [key-code (if (and (string? im-str) - (= 1 (string-length im-str))) - (string-ref im-str 0) - key-code)] - [shift-down (bit? modifiers GDK_SHIFT_MASK)] - [control-down (bit? modifiers GDK_CONTROL_MASK)] - [meta-down (bit? modifiers GDK_MOD1_MASK)] - [alt-down (bit? modifiers GDK_META_MASK)] - [x 0] - [y 0] - [time-stamp (if scroll? - (GdkEventScroll-time event) - (GdkEventKey-time event))] - [caps-down (bit? modifiers GDK_LOCK_MASK)])]) - (when (or (and (not scroll?) - (let-values ([(s ag sag cl) (get-alts event)] - [(keyval->code*) (lambda (v) - (and v - (let ([c (keyval->code v)]) - (and (not (equal? #\u0000 c)) - c))))]) - (let ([s (keyval->code* s)] - [ag (keyval->code* ag)] - [sag (keyval->code* sag)] - [cl (keyval->code* cl)]) - (when s (send k set-other-shift-key-code s)) - (when ag (send k set-other-altgr-key-code ag)) - (when sag (send k set-other-shift-altgr-key-code sag)) - (when cl (send k set-other-caps-key-code cl)) - (or s ag sag cl)))) - (not (equal? #\u0000 key-code))) - (unless (or scroll? 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 handles-events? gtk) - (begin - (queue-window-event wx (lambda () (send wx dispatch-on-char k #f))) - #t) - (constrained-reply (send wx get-eventspace) - (lambda () (send wx dispatch-on-char k #t)) - #t))))))))) + (keyval->code (GdkEventKey-keyval event)))] + [k (new key-event% + [key-code (if (and (string? im-str) + (= 1 (string-length im-str))) + (string-ref im-str 0) + key-code)] + [shift-down (bit? modifiers GDK_SHIFT_MASK)] + [control-down (bit? modifiers GDK_CONTROL_MASK)] + [meta-down (bit? modifiers GDK_MOD1_MASK)] + [alt-down (bit? modifiers GDK_META_MASK)] + [x 0] + [y 0] + [time-stamp (if scroll? + (GdkEventScroll-time event) + (GdkEventKey-time event))] + [caps-down (bit? modifiers GDK_LOCK_MASK)])]) + (when (or (and (not scroll?) + (let-values ([(s ag sag cl) (get-alts event)] + [(keyval->code*) (lambda (v) + (and v + (let ([c (keyval->code v)]) + (and (not (equal? #\u0000 c)) + c))))]) + (let ([s (keyval->code* s)] + [ag (keyval->code* ag)] + [sag (keyval->code* sag)] + [cl (keyval->code* cl)]) + (when s (send k set-other-shift-key-code s)) + (when ag (send k set-other-altgr-key-code ag)) + (when sag (send k set-other-shift-altgr-key-code sag)) + (when cl (send k set-other-caps-key-code cl)) + (or s ag sag cl)))) + (not (equal? #\u0000 key-code))) + (unless (or scroll? 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 handles-events? gtk) + (begin + (queue-window-event wx (lambda () (send wx dispatch-on-char k #f))) + #t) + (constrained-reply (send wx get-eventspace) + (lambda () (send wx dispatch-on-char k #t)) + #t))))))))) (define-signal-handler connect-button-press "button-press-event" (_fun _GtkWidget _GdkEventButton-pointer -> _gboolean) @@ -317,11 +317,11 @@ (and wx (if (or (= type GDK_2BUTTON_PRESS) - (= type GDK_3BUTTON_PRESS) - (and (or (= type GDK_ENTER_NOTIFY) - (= type GDK_LEAVE_NOTIFY)) - (send wx skip-enter-leave-events))) - #t + (= type GDK_3BUTTON_PRESS) + (and (or (= type GDK_ENTER_NOTIFY) + (= type GDK_LEAVE_NOTIFY)) + (send wx skip-enter-leave-events))) + #t (let* ([modifiers (if motion? (GdkEventMotion-state event) (if crossing? @@ -345,7 +345,7 @@ [(1) 'left-up] [(3) 'right-up] [else 'middle-up])])] - [m (let-values ([(x y) (send wx + [m (let-values ([(x y) (send wx adjust-event-position (->long ((if motion? GdkEventMotion-x @@ -378,24 +378,24 @@ (if crossing? GdkEventCrossing-time GdkEventButton-time)) event)] [caps-down (bit? modifiers GDK_LOCK_MASK)]))]) - (if (send wx handles-events? gtk) - (begin - (queue-window-event wx (lambda () - (send wx dispatch-on-event m #f))) - #t) - (constrained-reply (send wx get-eventspace) - (lambda () (or (send wx dispatch-on-event m #t) - (send wx internal-pre-on-event gtk m))) - #t - #:fail-result - ;; an enter event is synthesized when a button is - ;; enabled and the mouse is over the button, and the - ;; event is not dispatched via the eventspace; leave - ;; events are perhaps similarly synthesized, so allow - ;; them, too - (if (or (eq? type 'enter) (eq? type 'leave)) - #f - #t))))))))) + (if (send wx handles-events? gtk) + (begin + (queue-window-event wx (lambda () + (send wx dispatch-on-event m #f))) + #t) + (constrained-reply (send wx get-eventspace) + (lambda () (or (send wx dispatch-on-event m #t) + (send wx internal-pre-on-event gtk m))) + #t + #:fail-result + ;; an enter event is synthesized when a button is + ;; enabled and the mouse is over the button, and the + ;; event is not dispatched via the eventspace; leave + ;; events are perhaps similarly synthesized, so allow + ;; them, too + (if (or (eq? type 'enter) (eq? type 'leave)) + #f + #t))))))))) ;; ---------------------------------------- @@ -592,13 +592,13 @@ (define drag-connected? #f) (define/public (drag-accept-files on?) (if on? - (begin - (unless drag-connected? - (connect-drag-data-received gtk) - (set! drag-connected? #t)) - (gtk_drag_dest_set gtk GTK_DEST_DEFAULT_ALL GDK_ACTION_COPY) - (gtk_drag_dest_add_uri_targets gtk)) - (gtk_drag_dest_unset gtk))) + (begin + (unless drag-connected? + (connect-drag-data-received gtk) + (set! drag-connected? #t)) + (gtk_drag_dest_set gtk GTK_DEST_DEFAULT_ALL GDK_ACTION_COPY) + (gtk_drag_dest_add_uri_targets gtk)) + (gtk_drag_dest_unset gtk))) (define/public (set-focus) (gtk_widget_grab_focus (get-client-gtk))) @@ -761,7 +761,7 @@ (when win (set-mcar! win-box #f) (for ([i (in-range (mcdr win-box))]) - (gdk_window_thaw_updates win))))) + (gdk_window_thaw_updates win))))) (define (request-flush-delay win-box) (do-request-flush-delay @@ -769,15 +769,15 @@ (lambda (win-box) (let ([win (mcar win-box)]) (and win - ;; The freeze/thaw state is actually with the window's - ;; implementation, so force a native implementation of the - ;; window to try to avoid it changing out from underneath - ;; us between the freeze and thaw actions. - (gdk_window_ensure_native win) - (begin - (gdk_window_freeze_updates win) - (set-mcdr! win-box (add1 (mcdr win-box))) - #t)))) + ;; The freeze/thaw state is actually with the window's + ;; implementation, so force a native implementation of the + ;; window to try to avoid it changing out from underneath + ;; us between the freeze and thaw actions. + (gdk_window_ensure_native win) + (begin + (gdk_window_freeze_updates win) + (set-mcdr! win-box (add1 (mcdr win-box))) + #t)))) (lambda (win-box) (let ([win (mcar win-box)]) (when win @@ -791,5 +791,5 @@ (lambda (win-box) (let ([win (mcar win-box)]) (when win - (gdk_window_thaw_updates win) + (gdk_window_thaw_updates win) (set-mcdr! win-box (sub1 (mcdr win-box))))))))) diff --git a/collects/mred/private/wx/win32/types.rkt b/collects/mred/private/wx/win32/types.rkt index d446fedc5f..6fbfee9712 100644 --- a/collects/mred/private/wx/win32/types.rkt +++ b/collects/mred/private/wx/win32/types.rkt @@ -1,13 +1,13 @@ #lang racket/base (require ffi/unsafe - ffi/winapi) + ffi/winapi) (provide (protect-out _wfun - _WORD - _DWORD - _UDWORD + _WORD + _DWORD + _UDWORD _ATOM _WPARAM _LPARAM @@ -95,35 +95,35 @@ (define _permanent-string/utf-16 (make-ctype _pointer - (lambda (s) - (and s - (let ([v (malloc _gcpointer)]) - (ptr-set! v _string/utf-16 s) - (let ([p (ptr-ref v _gcpointer)]) - (let ([len (+ 1 (utf-16-length s))]) - (let ([c (malloc len _uint16 'raw)]) - (memcpy c p len _uint16) - c)))))) - (lambda (p) p))) + (lambda (s) + (and s + (let ([v (malloc _gcpointer)]) + (ptr-set! v _string/utf-16 s) + (let ([p (ptr-ref v _gcpointer)]) + (let ([len (+ 1 (utf-16-length s))]) + (let ([c (malloc len _uint16 'raw)]) + (memcpy c p len _uint16) + c)))))) + (lambda (p) p))) (define _LONG _long) (define _ULONG _ulong) (define _SHORT _short) (define-cstruct _POINT ([x _LONG] - [y _LONG])) + [y _LONG])) (define-cstruct _RECT ([left _LONG] - [top _LONG] - [right _LONG] - [bottom _LONG])) + [top _LONG] + [right _LONG] + [bottom _LONG])) (define-cstruct _MSG ([hwnd _HWND] - [message _UINT] - [wParam _WPARAM] - [lParam _LPARAM] - [time _DWORD] - [pt _POINT])) + [message _UINT] + [wParam _WPARAM] + [lParam _LPARAM] + [time _DWORD] + [pt _POINT])) (define (short v) (if (zero? (bitwise-and #x8000 v)) diff --git a/collects/mrlib/scribblings/switchable-button.scrbl b/collects/mrlib/scribblings/switchable-button.scrbl index df25e4cb15..74d040a265 100644 --- a/collects/mrlib/scribblings/switchable-button.scrbl +++ b/collects/mrlib/scribblings/switchable-button.scrbl @@ -15,7 +15,7 @@ @defconstructor/auto-super[([label string?] [callback (-> (is-a?/c switchable-button%) any/c)] [bitmap (is-a?/c bitmap%)] - [alternate-bitmap (is-a?/c bitmap%) bitmap] + [alternate-bitmap (is-a?/c bitmap%) bitmap] [vertical-tight? boolean? #f])]{ The @racket[callback] is called when the button is pressed. The @racket[string] and @racket[bitmap] are diff --git a/collects/mysterx/mysterx.rkt b/collects/mysterx/mysterx.rkt index 049b92fae1..f29183955a 100644 --- a/collects/mysterx/mysterx.rkt +++ b/collects/mysterx/mysterx.rkt @@ -12,7 +12,7 @@ cocreate-instance-from-progid cci/progid - get-active-object-from-coclass + get-active-object-from-coclass gao/coclass coclass @@ -26,11 +26,11 @@ com-invoke com-get-properties - (rename-out [mx:com-get-property-type com-get-property-type]) + (rename-out [mx:com-get-property-type com-get-property-type]) com-get-property com-set-properties - (rename-out [mx:com-set-property-type com-set-property-type]) + (rename-out [mx:com-set-property-type com-set-property-type]) com-set-property! com-help @@ -143,7 +143,7 @@ (define (reorder t) (if (and (pair? t) - (eq? (car t) '->)) + (eq? (car t) '->)) (append (cadr t) (list '-> (caddr t))) t)) diff --git a/collects/mzscheme/installer.rkt b/collects/mzscheme/installer.rkt index d3c8c3453d..4d9934c32a 100644 --- a/collects/mzscheme/installer.rkt +++ b/collects/mzscheme/installer.rkt @@ -7,7 +7,7 @@ (define variants (available-mzscheme-variants)) (for ([v (in-list variants)]) (parameterize ([current-launcher-variant v]) - (create-embedding-executable + (create-embedding-executable (mzscheme-program-launcher-path "MzScheme") #:variant v #:cmdline '("-I" "scheme/init") diff --git a/collects/parser-tools/private-yacc/graph.rkt b/collects/parser-tools/private-yacc/graph.rkt index 02e28df58f..958acc10ad 100644 --- a/collects/parser-tools/private-yacc/graph.rkt +++ b/collects/parser-tools/private-yacc/graph.rkt @@ -12,55 +12,50 @@ ;; We use a hash-table to represent the result function 'a -> 'b set, so ;; the values of type 'a must be comparable with eq?. (define (digraph nodes edges f- union fail) - (letrec ( - ;; Will map elements of 'a to 'b sets - (results (make-hash-table)) - (f (lambda (x) (hash-table-get results x fail))) - - ;; Maps elements of 'a to integers. - (N (make-hash-table)) - (get-N (lambda (x) (hash-table-get N x zero-thunk))) - (set-N (lambda (x d) (hash-table-put! N x d))) - - (stack null) - (push (lambda (x) - (set! stack (cons x stack)))) - (pop (lambda () + (letrec [ + ;; Will map elements of 'a to 'b sets + (results (make-hash-table)) + (f (lambda (x) (hash-table-get results x fail))) + + ;; Maps elements of 'a to integers. + (N (make-hash-table)) + (get-N (lambda (x) (hash-table-get N x zero-thunk))) + (set-N (lambda (x d) (hash-table-put! N x d))) + + (stack null) + (push (lambda (x) + (set! stack (cons x stack)))) + (pop (lambda () (begin0 - (car stack) - (set! stack (cdr stack))))) - (depth (lambda () (length stack))) + (car stack) + (set! stack (cdr stack))))) + (depth (lambda () (length stack))) - ;; traverse: 'a -> - (traverse - (lambda (x) - (push x) - (let ((d (depth))) - (set-N x d) - (hash-table-put! results x (f- x)) - (for-each (lambda (y) - (if (= 0 (get-N y)) - (traverse y)) - (hash-table-put! results - x - (union (f x) (f y))) - (set-N x (min (get-N x) (get-N y)))) - (edges x)) - (if (= d (get-N x)) - (let loop ((p (pop))) - (set-N p +inf.0) - (hash-table-put! results p (f x)) - (if (not (eq? x p)) - (loop (pop))))))))) + ;; traverse: 'a -> + (traverse + (lambda (x) + (push x) + (let ((d (depth))) + (set-N x d) + (hash-table-put! results x (f- x)) + (for-each (lambda (y) + (if (= 0 (get-N y)) + (traverse y)) + (hash-table-put! results + x + (union (f x) (f y))) + (set-N x (min (get-N x) (get-N y)))) + (edges x)) + (if (= d (get-N x)) + (let loop ((p (pop))) + (set-N p +inf.0) + (hash-table-put! results p (f x)) + (if (not (eq? x p)) + (loop (pop))))))))] (for-each (lambda (x) - (if (= 0 (get-N x)) - (traverse x))) - nodes) + (if (= 0 (get-N x)) + (traverse x))) + nodes) f)) ) - - - - - diff --git a/collects/parser-tools/private-yacc/lalr.rkt b/collects/parser-tools/private-yacc/lalr.rkt index 3fb195334a..e9b4d3b738 100644 --- a/collects/parser-tools/private-yacc/lalr.rkt +++ b/collects/parser-tools/private-yacc/lalr.rkt @@ -38,7 +38,7 @@ ;; output term set is represented in bit-vector form (define (compute-read a g) (let* ((dr (compute-DR a g)) - (reads (compute-reads a g))) + (reads (compute-reads a g))) (digraph-tk->terml (send a get-mapped-non-term-keys) reads dr @@ -127,13 +127,12 @@ ;; output term set is represented in bit-vector form (define (compute-LA a g) (let* ((includes (compute-includes a g)) - (lookback (compute-lookback a g)) - (follow (compute-follow a g includes))) + (lookback (compute-lookback a g)) + (follow (compute-follow a g includes))) (lambda (k p) - (let* ((l (lookback k p)) - (f (map follow l))) - (apply bitwise-ior (cons 0 f)))))) - + (let* ((l (lookback k p)) + (f (map follow l))) + (apply bitwise-ior (cons 0 f)))))) (define (print-DR dr a g) (print-input-st-sym dr "DR" a g print-output-terms)) @@ -192,8 +191,8 @@ (map (lambda (p) (list - (kernel-index (trans-key-st p)) - (gram-sym-symbol (trans-key-gs p)))) + (kernel-index (trans-key-st p)) + (gram-sym-symbol (trans-key-gs p)))) r)) ;; init-tk-map : int -> (vectorof hashtable?) @@ -230,52 +229,49 @@ ;; Computes (f x) = (f- x) union Union{(f y) | y in (edges x)} ;; A specialization of digraph in the file graph.rkt (define (digraph-tk->terml nodes edges f- num-states) - (letrec ( - ;; Will map elements of trans-key to term sets represented as bit vectors - (results (init-tk-map num-states)) + (letrec [ + ;; Will map elements of trans-key to term sets represented as bit vectors + (results (init-tk-map num-states)) - ;; Maps elements of trans-keys to integers. - (N (init-tk-map num-states)) + ;; Maps elements of trans-keys to integers. + (N (init-tk-map num-states)) (get-N (lookup-tk-map N)) - (set-N (add-tk-map N)) - (get-f (lookup-tk-map results)) - (set-f (add-tk-map results)) - - (stack null) - (push (lambda (x) - (set! stack (cons x stack)))) - (pop (lambda () + (set-N (add-tk-map N)) + (get-f (lookup-tk-map results)) + (set-f (add-tk-map results)) + + (stack null) + (push (lambda (x) + (set! stack (cons x stack)))) + (pop (lambda () (begin0 - (car stack) - (set! stack (cdr stack))))) - (depth (lambda () (length stack))) + (car stack) + (set! stack (cdr stack))))) + (depth (lambda () (length stack))) - ;; traverse: 'a -> - (traverse - (lambda (x) - (push x) - (let ((d (depth))) - (set-N x d) - (set-f x (f- x)) - (for-each (lambda (y) - (when (= 0 (get-N y)) + ;; traverse: 'a -> + (traverse + (lambda (x) + (push x) + (let ((d (depth))) + (set-N x d) + (set-f x (f- x)) + (for-each (lambda (y) + (when (= 0 (get-N y)) (traverse y)) - (set-f x (bitwise-ior (get-f x) (get-f y))) - (set-N x (min (get-N x) (get-N y)))) - (edges x)) - (when (= d (get-N x)) + (set-f x (bitwise-ior (get-f x) (get-f y))) + (set-N x (min (get-N x) (get-N y)))) + (edges x)) + (when (= d (get-N x)) (let loop ((p (pop))) (set-N p +inf.0) (set-f p (get-f x)) (unless (equal? x p) - (loop (pop))))))))) + (loop (pop))))))))] (for-each (lambda (x) - (when (= 0 (get-N x)) + (when (= 0 (get-N x)) (traverse x))) - nodes) + nodes) get-f)) ) - - - diff --git a/collects/parser-tools/private-yacc/lr0.rkt b/collects/parser-tools/private-yacc/lr0.rkt index ac359ac912..eb0b2dafa7 100644 --- a/collects/parser-tools/private-yacc/lr0.rkt +++ b/collects/parser-tools/private-yacc/lr0.rkt @@ -62,9 +62,9 @@ ;; (listof (cons/c trans-key? (listof kernel?))) (define (reverse-assoc assoc) (let ((reverse-hash (make-hash-table 'equal)) - (hash-table-add! - (lambda (ht k v) - (hash-table-put! ht k (cons v (hash-table-get ht k (lambda () null))))))) + (hash-table-add! + (lambda (ht k v) + (hash-table-put! ht k (cons v (hash-table-get ht k (lambda () null))))))) (for-each (lambda (trans-key/kernel) (let ((tk (car trans-key/kernel))) @@ -99,13 +99,13 @@ (define mapped-non-terms (map car non-term-assoc)) (define/public (get-mapped-non-term-keys) - mapped-non-terms) + mapped-non-terms) (define/public (get-num-states) (vector-length states)) (define/public (get-epsilon-trans) - epsilons) + epsilons) (define/public (get-transitions) (append term-assoc non-term-assoc)) @@ -113,12 +113,12 @@ ;; for-each-state : (state ->) -> ;; Iteration over the states in an automaton (define/public (for-each-state f) - (let ((num-states (vector-length states))) - (let loop ((i 0)) - (if (< i num-states) - (begin - (f (vector-ref states i)) - (loop (add1 i))))))) + (let ((num-states (vector-length states))) + (let loop ((i 0)) + (if (< i num-states) + (begin + (f (vector-ref states i)) + (loop (add1 i))))))) ;; run-automaton: kernel? gram-sym? -> (union kernel #f) ;; returns the state reached from state k on input s, or #f when k @@ -131,28 +131,28 @@ ;; run-automaton-back : (listof kernel?) gram-sym? -> (listof kernel) ;; returns the list of states that can reach k by transitioning on s. (define/public (run-automaton-back k s) - (apply append + (apply append (map (lambda (k) (hash-table-get (vector-ref reverse-transitions (kernel-index k)) (gram-sym-symbol s) (lambda () null))) k))))) - + (define (union comp (eq? a b) (define (kernel->string k) (apply string-append - `("{" ,@(map (lambda (i) (string-append (item->string i) ", ")) - (kernel-items k)) - "}"))) + `("{" ,@(map (lambda (i) (string-append (item->string i) ", ")) + (kernel-items k)) + "}"))) ;; build-LR0-automaton: grammar -> LR0-automaton ;; Constructs the kernels of the sets of LR(0) items of g (define (build-lr0-automaton grammar) ; (printf "LR(0) automaton:\n") (letrec ( - (epsilons (make-hash-table 'equal)) - (grammar-symbols (append (send grammar get-non-terms) + (epsilons (make-hash-table 'equal)) + (grammar-symbols (append (send grammar get-non-terms) (send grammar get-terms))) - ;; first-non-term: non-term -> non-term list - ;; given a non-terminal symbol C, return those non-terminal - ;; symbols A s.t. C -> An for some string of terminals and - ;; non-terminals n where -> means a rightmost derivation in many - ;; steps. Assumes that each non-term can be reduced to a string - ;; of terms. - (first-non-term - (digraph (send grammar get-non-terms) - (lambda (nt) - (filter non-term? - (map (lambda (prod) - (sym-at-dot (make-item prod 0))) - (send grammar get-prods-for-non-term nt)))) - (lambda (nt) (list nt)) - (union non-term non-term list + ;; given a non-terminal symbol C, return those non-terminal + ;; symbols A s.t. C -> An for some string of terminals and + ;; non-terminals n where -> means a rightmost derivation in many + ;; steps. Assumes that each non-term can be reduced to a string + ;; of terms. + (first-non-term + (digraph (send grammar get-non-terms) + (lambda (nt) + (filter non-term? + (map (lambda (prod) + (sym-at-dot (make-item prod 0))) + (send grammar get-prods-for-non-term nt)))) + (lambda (nt) (list nt)) + (union non-term LR1-item list - ;; Creates a set of items containing i s.t. if A -> n.Xm is in it, - ;; X -> .o is in it too. - (LR0-closure - (lambda (i) - (cond - ((null? i) null) - (else - (let ((next-gsym (sym-at-dot (car i)))) - (cond - ((non-term? next-gsym) - (cons (car i) - (append - (apply append - (map (lambda (non-term) - (map (lambda (x) - (make-item x 0)) - (send grammar + ;; closure: LR1-item list -> LR1-item list + ;; Creates a set of items containing i s.t. if A -> n.Xm is in it, + ;; X -> .o is in it too. + (LR0-closure + (lambda (i) + (cond + ((null? i) null) + (else + (let ((next-gsym (sym-at-dot (car i)))) + (cond + ((non-term? next-gsym) + (cons (car i) + (append + (apply append + (map (lambda (non-term) + (map (lambda (x) + (make-item x 0)) + (send grammar get-prods-for-non-term non-term))) - (first-non-term next-gsym))) - (LR0-closure (cdr i))))) - (else - (cons (car i) (LR0-closure (cdr i)))))))))) + (first-non-term next-gsym))) + (LR0-closure (cdr i))))) + (else + (cons (car i) (LR0-closure (cdr i)))))))))) - ;; maps trans-keys to kernels - (automaton-term null) + ;; maps trans-keys to kernels + (automaton-term null) (automaton-non-term null) - - ;; keeps the kernels we have seen, so we can have a unique - ;; list for each kernel - (kernels (make-hash-table 'equal)) + + ;; keeps the kernels we have seen, so we can have a unique + ;; list for each kernel + (kernels (make-hash-table 'equal)) - (counter 0) - - ;; goto: LR1-item list -> LR1-item list list - ;; creates new kernels by moving the dot in each item in the - ;; LR0-closure of kernel to the right, and grouping them by - ;; the term/non-term moved over. Returns the kernels not - ;; yet seen, and places the trans-keys into automaton - (goto - (lambda (kernel) - (let ( - ;; maps a gram-syms to a list of items - (table (make-hash-table)) + (counter 0) + + ;; goto: LR1-item list -> LR1-item list list + ;; creates new kernels by moving the dot in each item in the + ;; LR0-closure of kernel to the right, and grouping them by + ;; the term/non-term moved over. Returns the kernels not + ;; yet seen, and places the trans-keys into automaton + (goto + (lambda (kernel) + (let ( + ;; maps a gram-syms to a list of items + (table (make-hash-table)) - ;; add-item!: - ;; (symbol (listof item) hashtable) item? -> - ;; adds i into the table grouped with the grammar - ;; symbol following its dot - (add-item! - (lambda (table i) - (let ((gs (sym-at-dot i))) - (cond - (gs - (let ((already + ;; add-item!: + ;; (symbol (listof item) hashtable) item? -> + ;; adds i into the table grouped with the grammar + ;; symbol following its dot + (add-item! + (lambda (table i) + (let ((gs (sym-at-dot i))) + (cond + (gs + (let ((already (hash-table-get table (gram-sym-symbol gs) (lambda () null)))) - (unless (member i already) + (unless (member i already) (hash-table-put! table (gram-sym-symbol gs) (cons i already))))) - ((= 0 (vector-length (prod-rhs (item-prod i)))) - (let ((current (hash-table-get epsilons - kernel - (lambda () null)))) - (hash-table-put! epsilons - kernel - (cons i current))))))))) - - ;; Group the items of the LR0 closure of the kernel - ;; by the character after the dot - (for-each (lambda (item) - (add-item! table item)) - (LR0-closure (kernel-items kernel))) - - ;; each group is a new kernel, with the dot advanced. - ;; sorts the items in a kernel so kernels can be compared - ;; with equal? for using the table kernels to make sure - ;; only one representitive of each kernel is created - (filter - (lambda (x) x) - (map - (lambda (i) - (let* ((gs (car i)) - (items (cadr i)) - (new #f) - (new-kernel (sort - (filter (lambda (x) x) - (map move-dot-right items)) - item ~a on ~a\n" - (kernel->string kernel) - (kernel->string unique-kernel) - (gram-sym-symbol gs)) - (if new - unique-kernel - #f))) - (let loop ((gsyms grammar-symbols)) - (cond + (kernel->string kernel) + (kernel->string unique-kernel) + (gram-sym-symbol gs)) + (if new + unique-kernel + #f))) + (let loop ((gsyms grammar-symbols)) + (cond ((null? gsyms) null) (else (let ((items (hash-table-get table @@ -323,33 +323,33 @@ (else (cons (list (car gsyms) items) (loop (cdr gsyms)))))))))))))) - + (starts (map (lambda (init-prod) (list (make-item init-prod 0))) (send grammar get-init-prods))) - (startk + (startk (map (lambda (start) (let ((k (make-kernel start counter))) (hash-table-put! kernels start k) (set! counter (add1 counter)) k)) starts)) - (new-kernels (make-queue))) + (new-kernels (make-queue))) (let loop ((old-kernels startk) - (seen-kernels null)) - (cond - ((and (empty-queue? new-kernels) (null? old-kernels)) - (make-object lr0% - automaton-term - automaton-non-term - (list->vector (reverse seen-kernels)) - epsilons)) - ((null? old-kernels) - (loop (deq! new-kernels) seen-kernels)) - (else - (enq! new-kernels (goto (car old-kernels))) - (loop (cdr old-kernels) (cons (car old-kernels) seen-kernels))))))) + (seen-kernels null)) + (cond + ((and (empty-queue? new-kernels) (null? old-kernels)) + (make-object lr0% + automaton-term + automaton-non-term + (list->vector (reverse seen-kernels)) + epsilons)) + ((null? old-kernels) + (loop (deq! new-kernels) seen-kernels)) + (else + (enq! new-kernels (goto (car old-kernels))) + (loop (cdr old-kernels) (cons (car old-kernels) seen-kernels))))))) (define-struct q (f l) (make-inspector)) (define (empty-queue? q) @@ -358,12 +358,12 @@ (make-q null null)) (define (enq! q i) (if (empty-queue? q) - (let ((i (mcons i null))) - (set-q-l! q i) - (set-q-f! q i)) - (begin - (set-mcdr! (q-l q) (mcons i null)) - (set-q-l! q (mcdr (q-l q)))))) + (let ((i (mcons i null))) + (set-q-l! q i) + (set-q-f! q i)) + (begin + (set-mcdr! (q-l q) (mcons i null)) + (set-q-l! q (mcdr (q-l q)))))) (define (deq! q) (begin0 (mcar (q-f q)) diff --git a/collects/picturing-programs/picturing-programs.scrbl b/collects/picturing-programs/picturing-programs.scrbl index b8cc4c5f3f..d44dd6ea25 100644 --- a/collects/picturing-programs/picturing-programs.scrbl +++ b/collects/picturing-programs/picturing-programs.scrbl @@ -4,9 +4,9 @@ (for-label racket picturing-programs/main ;picturing-programs/io-stuff - ;picturing-programs/tiles + ;picturing-programs/tiles ;picturing-programs/dummy - ; picturing-programs/map-image + ; picturing-programs/map-image 2htdp/image teachpack/2htdp/universe (only-in lang/htdp-beginner check-expect) @@ -93,12 +93,12 @@ model is exactly what should be displayed in the animation window: image?]{Chops off the specified number of pixels from the right side of the image.} @defproc[(flip-main [img image?]) - image?]{Reflects an image across the line x=y, moving the pixel + image?]{Reflects an image across the line x=y, moving the pixel at coordinates (x,y) to (y,x). The top-right corner becomes the bottom-left corner, and vice versa. Width and height are swapped.} @defproc[(flip-other [img image?]) - image?]{Reflects an image by moving the pixel at coordinates + image?]{Reflects an image by moving the pixel at coordinates (x,y) to (h-y, w-x). The top-left corner becomes the bottom-right corner, and vice versa. Width and height are swapped.} @@ -109,11 +109,11 @@ corner, and vice versa. Width and height are swapped.} image?]{The same as @racket[flip-horizontal]; retained for compatibility.} @defproc[(reflect-main-diag [img image?]) - image?]{The same as @racket[flip-main]; retained for + image?]{The same as @racket[flip-main]; retained for compatibility.} @defproc[(reflect-other-diag [img image?]) - image?]{The same as @racket[flip-other]; retained for + image?]{The same as @racket[flip-other]; retained for compatibility.} @section{Variables} @@ -173,14 +173,14 @@ color struct, showing the red, green, blue, and alpha components. If the name i recognized, returns @racket[false].} @defproc[(colorize [thing (or/c color? string? symbol? false/c)]) - (or/c color? false/c)]{ + (or/c color? false/c)]{ Similar to @racket[name->color], but accepts colors and @racket[false] as well: colors produce themselves, while @racket[false] produces a transparent color.} @defproc[(color=? [c1 (or/c color? string? symbol? false/c)] - [c2 (or/c color? string? symbol? false/c)]) - boolean?]{ + [c2 (or/c color? string? symbol? false/c)]) + boolean?]{ Compares two colors for equality. As with @racket[colorize], treats @racket[false] as a transparent color (i.e. with an alpha-component of 0). All colors with alpha=0 are considered equal to one another, even if they have @@ -241,12 +241,12 @@ For example, the above @racket[fuzz] example could also be written as } @defproc[(build4-image [width natural-number/c] [height natural-number/c] - [red-function (-> natural-number/c natural-number/c natural-number/c)] - [green-function (-> natural-number/c natural-number/c natural-number/c)] - [blue-function (-> natural-number/c natural-number/c natural-number/c)] - [alpha-function (-> natural-number/c natural-number/c + [red-function (-> natural-number/c natural-number/c natural-number/c)] + [green-function (-> natural-number/c natural-number/c natural-number/c)] + [blue-function (-> natural-number/c natural-number/c natural-number/c)] + [alpha-function (-> natural-number/c natural-number/c natural-number/c)]) - image?]{ + image?]{ A version of @racket[build-image] for students who don't know about structs yet. Each of the four functions takes in the x and y coordinates of a pixel, and should return an integer from 0 through 255 to determine that color component.} @@ -300,7 +300,7 @@ replacing the red component with a smooth color gradient increasing from left to right, but with the green and blue components unchanged.} @defproc*[([(map-image/extra [f (-> color? any/c color?)] [img image?] [extra any/c]) image?] - [(map-image/extra [f (-> natural-number/c natural-number/c color? any/c color?)] [img image?] [extra any/c]) image?])]{ + [(map-image/extra [f (-> natural-number/c natural-number/c color? any/c color?)] [img image?] [extra any/c]) image?])]{ Passes the @racket[extra] argument in as an additional argument in each call to @racket[f]. This allows students who haven't learned closures yet to do pixel-by-pixel image manipulations inside a function depending on a parameter of that function. @@ -309,13 +309,13 @@ For example, @codeblock|{ ; clip-color : color number -> color (check-expect (clip-color (make-color 30 60 90) 100) - (make-color 30 60 90)) + (make-color 30 60 90)) (check-expect (clip-color (make-color 30 60 90) 50) - (make-color 30 50 50)) + (make-color 30 50 50)) (define (clip-color c limit) (make-color (min limit (color-red c)) - (min limit (color-green c)) - (min limit (color-blue c)))) + (min limit (color-green c)) + (min limit (color-blue c)))) ; clip-picture-colors : number(limit) image -> image (define (clip-picture-colors limit pic) @@ -443,7 +443,7 @@ enabling you to compute the average color, or a histogram of colors, etc. } @defproc*[([(fold-image/extra [f (-> color? any/c any/c any/c)] [init any/c] [img image?] [extra any/c]) any/c] - [(fold-image/extra [f (-> natural-number/c natural-number/c color? any/c any/c any/c)] [init any/c] [img image?] [extra any/c]) any/c])]{ + [(fold-image/extra [f (-> natural-number/c natural-number/c color? any/c any/c any/c)] [init any/c] [img image?] [extra any/c]) any/c])]{ Like @racket[fold-image], but passes the @racket[extra] argument in as an additional argument in each call to @racket[f]. This allows students who haven't learned closures yet to call @racket[fold-image] on an operation that depends on a parameter to a containing function. diff --git a/collects/planet/planet.scrbl b/collects/planet/planet.scrbl index cc1a53d63c..11c5d70115 100644 --- a/collects/planet/planet.scrbl +++ b/collects/planet/planet.scrbl @@ -151,8 +151,8 @@ run @tt{raco planet show}. You should see output like this packages have been updated since this was written): @verbatim{ Normally-installed packages: - cce scheme.plt 4 1 - plai plai.plt 1 1 + cce scheme.plt 4 1 + plai plai.plt 1 1 }} ] diff --git a/collects/planet/private/util.scrbl b/collects/planet/private/util.scrbl index 97092894d9..e9f1f2d72c 100644 --- a/collects/planet/private/util.scrbl +++ b/collects/planet/private/util.scrbl @@ -265,9 +265,9 @@ functionality exposed by @seclink["cmdline"]{the @exec{raco planet} command-line also available programmatically through this library. @defproc[(download/install-pkg [owner string?] - [pkg (and/c string? #rx"[.]plt$")] - [maj natural-number/c] - [min natural-number/c]) + [pkg (and/c string? #rx"[.]plt$")] + [maj natural-number/c] + [min natural-number/c]) (or/c pkg? #f)]{ Downloads and installs the package specifed by the given owner name, package name, major and minor version number. Returns false if no such @@ -393,16 +393,16 @@ See also @racket[build-scribble-docs?] and @racket[force-package-building?] } @defproc[(unpack-planet-archive [plt-file (or/c path? path-string?)] - [output-dir (or/c path? path-string?)]) - any]{ + [output-dir (or/c path? path-string?)]) + any]{ Unpacks the PLaneT archive with the given filename, placing its contents into the given directory (creating that path if necessary).} @defproc[(remove-pkg [owner string?] - [pkg (and/c string? #rx"[.]plt$")] - [maj natural-number/c] - [min natural-number/c]) - any]{ + [pkg (and/c string? #rx"[.]plt$")] + [maj natural-number/c] + [min natural-number/c]) + any]{ Removes the specified package from the local planet cache, deleting the installed files. } @@ -410,20 +410,20 @@ Removes the specified package from the local planet cache, deleting the installe [pkg (and/c string? #rx"[.]plt$")] [maj natural-number/c] [min natural-number/c]) - any]{ + any]{ Like @racket[remove-pkg], removes the specified package from the local planet cache and deletes all of the files corresponding to the package, but also deletes the cached @filepath{.plt} file (so it will be redownloaded later). } - + @defproc[(display-plt-file-structure [plt-file (or/c path-string? path?)]) any]{ Print a tree representing the file and directory structure of the PLaneT archive .plt file named by @racket[plt-file] to @racket[(current-output-port)].} @defproc[(display-plt-archived-file [plt-file (or/c path-string? path?)] - [file-to-print string?]) - any]{ + [file-to-print string?]) + any]{ Print the contents of the file named @racket[file-to-print] within the PLaneT archive .plt file named by @racket[plt-file] to @racket[(current-output-port)].} @@ -432,11 +432,11 @@ Removes the entire linkage table from the system, which will force all modules to relink themselves to PLaneT modules the next time they run.} @defproc[(add-hard-link [owner string?] - [pkg (and/c string? #rx"[.]plt$")] - [maj natural-number/c] - [min natural-number/c] - [dir path?]) - any]{ + [pkg (and/c string? #rx"[.]plt$")] + [maj natural-number/c] + [min natural-number/c] + [dir path?]) + any]{ Adds a development link between the specified package and the given directory; once a link is established, PLaneT will treat the cache as having a package with the given owner, name, and version whose files @@ -451,11 +451,11 @@ The @racket[pkg] argument must end with the string @racket[".plt"]. } @defproc[(remove-hard-link [owner string?] - [pkg (and/c string? #rx"[.]plt$")] - [maj natural-number/c] - [min natural-number/c] + [pkg (and/c string? #rx"[.]plt$")] + [maj natural-number/c] + [min natural-number/c] [#:quiet? quiet? boolean? #false]) - any]{ + any]{ Removes any hard link that may be associated with the given package. The @racket[pkg] argument must end with the string @racket[".plt"]. @@ -465,7 +465,7 @@ procedure signals an error if no such link exists, unless } @defproc[(resolve-planet-path [spec quoted-planet-require-spec?]) - path?]{ + path?]{ This is the same function as the one with the same name, exported by @racketmodname[planet/resolver]. } diff --git a/collects/plot/common/date-time.rkt b/collects/plot/common/date-time.rkt index d5d7c93b67..93f429faf9 100644 --- a/collects/plot/common/date-time.rkt +++ b/collects/plot/common/date-time.rkt @@ -102,39 +102,39 @@ #| Supported format specifiers: -~a locale's abbreviated weekday name (Sun...Sat) -~A locale's full weekday name (Sunday...Saturday) -~b locale's abbreviate month name (Jan...Dec) -~B locale's full month day (January...December) -~d day of month, zero padded (01...31) -~D date (mm/dd/yy) -~e day of month, blank padded ( 1...31) -~h same as ~b -~H hour, zero padded, 24-hour clock (00...23) -~I hour, zero padded, 12-hour clock (01...12) -~j day of year, zero padded -~k hour, blank padded, 24-hour clock (00...23) -~l hour, blank padded, 12-hour clock (01...12) -~m month, zero padded (01...12) -~M minute, zero padded (00...59) -~N nanosecond, zero padded -~p locale's AM or PM -~r time, 12 hour clock, same as "~I:~M:~S ~p" -~S second, zero padded (00...60) -~f seconds+fractional seconds, using locale's decimal separator (e.g. 5.2). -~s number of full seconds since "the epoch" (in UTC) -~T time, 24 hour clock, same as "~H:~M:~S" -~U week number of year with Sunday as first day of week (00...53) -~V week number of year with Monday as first day of week (01...52) -~w day of week (0...6) -~W week number of year with Monday as first day of week (01...52) -~x week number of year with Monday as first day of week (00...53) -~X locale's date representation, for example: "07/31/00" -~y last two digits of year (00...99) -~Y year -~1 ISO-8601 year-month-day format -~3 ISO-8601 hour-minute-second format -~5 ISO-8601 year-month-day-hour-minute-second format +~a locale's abbreviated weekday name (Sun...Sat) +~A locale's full weekday name (Sunday...Saturday) +~b locale's abbreviate month name (Jan...Dec) +~B locale's full month day (January...December) +~d day of month, zero padded (01...31) +~D date (mm/dd/yy) +~e day of month, blank padded ( 1...31) +~h same as ~b +~H hour, zero padded, 24-hour clock (00...23) +~I hour, zero padded, 12-hour clock (01...12) +~j day of year, zero padded +~k hour, blank padded, 24-hour clock (00...23) +~l hour, blank padded, 12-hour clock (01...12) +~m month, zero padded (01...12) +~M minute, zero padded (00...59) +~N nanosecond, zero padded +~p locale's AM or PM +~r time, 12 hour clock, same as "~I:~M:~S ~p" +~S second, zero padded (00...60) +~f seconds+fractional seconds, using locale's decimal separator (e.g. 5.2). +~s number of full seconds since "the epoch" (in UTC) +~T time, 24 hour clock, same as "~H:~M:~S" +~U week number of year with Sunday as first day of week (00...53) +~V week number of year with Monday as first day of week (01...52) +~w day of week (0...6) +~W week number of year with Monday as first day of week (01...52) +~x week number of year with Monday as first day of week (00...53) +~X locale's date representation, for example: "07/31/00" +~y last two digits of year (00...99) +~Y year +~1 ISO-8601 year-month-day format +~3 ISO-8601 hour-minute-second format +~5 ISO-8601 year-month-day-hour-minute-second format |# (define (plot-date-formatter x-min x-max) @@ -155,19 +155,19 @@ Supported format specifiers: #| Supported format specifiers: -~d day -~H hour, zero padded, 24-hour clock (00...23) -~I hour, zero padded, 12-hour clock (01...12) -~k hour, blank padded, 24-hour clock ( 0...23) -~l hour, blank padded, 12-hour clock ( 1...12) -~p locale's AM or PM -~M minute, zero padded (00...59) -~S second, zero padded (00...60) -~f seconds+fractional seconds, using locale's decimal separator (e.g. 5.2). -~s second, formatted (nanoseconds, etc.) -~r time, 12 hour clock, same as "~I:~M:~S ~p" -~T time, 24 hour clock, same as "~H:~M:~S" -~3 ISO-8601 hour-minute-second format +~d day +~H hour, zero padded, 24-hour clock (00...23) +~I hour, zero padded, 12-hour clock (01...12) +~k hour, blank padded, 24-hour clock ( 0...23) +~l hour, blank padded, 12-hour clock ( 1...12) +~p locale's AM or PM +~M minute, zero padded (00...59) +~S second, zero padded (00...60) +~f seconds+fractional seconds, using locale's decimal separator (e.g. 5.2). +~s second, formatted (nanoseconds, etc.) +~r time, 12 hour clock, same as "~I:~M:~S ~p" +~T time, 24 hour clock, same as "~H:~M:~S" +~3 ISO-8601 hour-minute-second format |# (define (plot-time-formatter x-min x-max) diff --git a/collects/r6rs/private/records-explicit.rkt b/collects/r6rs/private/records-explicit.rkt index 7d8734cd00..b2aec4f4c5 100644 --- a/collects/r6rs/private/records-explicit.rkt +++ b/collects/r6rs/private/records-explicit.rkt @@ -99,13 +99,13 @@ (define-syntax define-record-type (syntax-rules () ((define-record-type (?record-name ?constructor-name ?predicate-name) - ?clause ...) + ?clause ...) (define-record-type-1 - ((record-name ?record-name) ; prop alist - (constructor-name ?constructor-name) - (predicate-name ?predicate-name)) - () ; fields - ?clause ...)))) + ((record-name ?record-name) ; prop alist + (constructor-name ?constructor-name) + (predicate-name ?predicate-name)) + () ; fields + ?clause ...)))) (define-syntax define-record-type-1 (syntax-rules (parent parent-rtd protocol sealed nongenerative opaque fields mutable immutable) diff --git a/collects/racket/draw/unsafe/jpeg.rkt b/collects/racket/draw/unsafe/jpeg.rkt index 2a9991e7be..3dc3ddb131 100644 --- a/collects/racket/draw/unsafe/jpeg.rkt +++ b/collects/racket/draw/unsafe/jpeg.rkt @@ -26,10 +26,10 @@ (define _J_DITHER_MODE _int) (define _jbool (if win64? - (make-ctype _byte - (lambda (v) (if v 1 0)) - (lambda (v) (not (zero? v)))) - _bool)) + (make-ctype _byte + (lambda (v) (if v 1 0)) + (lambda (v) (not (zero? v)))) + _bool)) (define-enum 0 JCS_UNKNOWN @@ -40,7 +40,7 @@ JCS_YCCK) (define _pool_id _int) -(define JPOOL_PERMANENT 0) +(define JPOOL_PERMANENT 0) (define JPOOL_IMAGE 1) (define JPOOL_NUMPOOLS 2) (define JMSG_LENGTH_MAX 200) diff --git a/collects/racket/future.rkt b/collects/racket/future.rkt index 416459d8ee..cd9e657aac 100644 --- a/collects/racket/future.rkt +++ b/collects/racket/future.rkt @@ -6,11 +6,11 @@ touch processor-count current-future - fsemaphore? - make-fsemaphore - fsemaphore-count - fsemaphore-post - fsemaphore-wait + fsemaphore? + make-fsemaphore + fsemaphore-count + fsemaphore-post + fsemaphore-wait fsemaphore-try-wait? would-be-future futures-enabled?) diff --git a/collects/rackunit/scribblings/check.scrbl b/collects/rackunit/scribblings/check.scrbl index e7ebbbddc8..168afc64ff 100644 --- a/collects/rackunit/scribblings/check.scrbl +++ b/collects/rackunit/scribblings/check.scrbl @@ -184,7 +184,7 @@ The following check fails: @defproc[(check (op (-> any any any)) (v1 any) (v2 any) - (message string? "")) + (message string? "")) void?]{ The most generic check. Succeeds if @racket[op] applied to @@ -233,13 +233,13 @@ misspelling errors: @defproc*[([(make-check-name (name string?)) check-info?] [(make-check-params (params (listof any))) check-info?] - [(make-check-location (loc (list/c any (or/c number? #f) (or/c number? #f) + [(make-check-location (loc (list/c any (or/c number? #f) (or/c number? #f) (or/c number? #f) (or/c number? #f)))) check-info?] - [(make-check-expression (msg any)) check-info?] - [(make-check-message (msg string?)) check-info?] - [(make-check-actual (param any)) check-info?] - [(make-check-expected (param any)) check-info?])]{} + [(make-check-expression (msg any)) check-info?] + [(make-check-message (msg string?)) check-info?] + [(make-check-actual (param any)) check-info?] + [(make-check-expected (param any)) check-info?])]{} @defproc[(with-check-info* (info (listof check-info?)) (thunk (-> any))) any]{ diff --git a/collects/redex/private/compiler/match.rkt b/collects/redex/private/compiler/match.rkt index fe298581bf..33af396cdd 100644 --- a/collects/redex/private/compiler/match.rkt +++ b/collects/redex/private/compiler/match.rkt @@ -885,11 +885,11 @@ repeat-split) ; Repeat - ; If a row in a matrix starts with (repeat p_1 p_2), first determine all the identifiers for name patterns in p_1. Call the ones which are not marked as bound in the matrix variable_1 ..., and the ones which are marked as bound in the matrix variable_2 ... - ; Seperate the matrix into the row with the repeat and all other rows, unioning the result together. Wrap the repeat row in a let expression to bind all the elements of variable_2 ... to fresh temporary variables. Inside this define a letrec called match-repeach as a function which takes a fresh variable z, variable_1 ..., and variable_2 ... as its arguments. variable_1 ... will be used to build up the bindings from inside the repeat, while variable_2 ... will be unwrapped to check that values already bound outside of the repeat match those inside the repeat. - ; Inside the function, union the results of two conditionals. The first is the "base case," where every element of variable_2 ... is equal to the empty list, and therefore the variable bound outside the repeat are correct inside the repeat. In this case, we return a matrix where the first input variable is z, the first pattern in the row is p_2, and the rest of the input/row are the same as before. We mark variable_1 ... as bound. This matrix is wrapped in a let expression which restores the values bound outside the repeat back from their temporary forms. - ; The second conditional checks if z and variable_2 ... are all cons?. If they are, it stores all the values for variable_1 ... as temporaries, then matches (car z) against p_1, with the righthand side equal to a call to match repeat with (cdr z), the cons of variable_1 ... the temporary values for variable_1 ..., and the cdr of all the elements of variable 2. (The new bindings are built up by one layer, and the ones bound outside of the repeat are "unwrapped" by one layer). In this one row, one pattern matrix, the natural indicating the depth of the repeat is incremented. - ; Finally, in the body of the letrec, all the elements of variable_1 ... are bound to empty, and there is the call (match-repeat x_1 variable_1 ... variable_2 ...). + ; If a row in a matrix starts with (repeat p_1 p_2), first determine all the identifiers for name patterns in p_1. Call the ones which are not marked as bound in the matrix variable_1 ..., and the ones which are marked as bound in the matrix variable_2 ... + ; Seperate the matrix into the row with the repeat and all other rows, unioning the result together. Wrap the repeat row in a let expression to bind all the elements of variable_2 ... to fresh temporary variables. Inside this define a letrec called match-repeach as a function which takes a fresh variable z, variable_1 ..., and variable_2 ... as its arguments. variable_1 ... will be used to build up the bindings from inside the repeat, while variable_2 ... will be unwrapped to check that values already bound outside of the repeat match those inside the repeat. + ; Inside the function, union the results of two conditionals. The first is the "base case," where every element of variable_2 ... is equal to the empty list, and therefore the variable bound outside the repeat are correct inside the repeat. In this case, we return a matrix where the first input variable is z, the first pattern in the row is p_2, and the rest of the input/row are the same as before. We mark variable_1 ... as bound. This matrix is wrapped in a let expression which restores the values bound outside the repeat back from their temporary forms. + ; The second conditional checks if z and variable_2 ... are all cons?. If they are, it stores all the values for variable_1 ... as temporaries, then matches (car z) against p_1, with the righthand side equal to a call to match repeat with (cdr z), the cons of variable_1 ... the temporary values for variable_1 ..., and the cdr of all the elements of variable 2. (The new bindings are built up by one layer, and the ones bound outside of the repeat are "unwrapped" by one layer). In this one row, one pattern matrix, the natural indicating the depth of the repeat is incremented. + ; Finally, in the body of the letrec, all the elements of variable_1 ... are bound to empty, and there is the call (match-repeat x_1 variable_1 ... variable_2 ...). ;; what happens with the (pvar_3 ...) field of the matrix when you have a matrix from a pattern like this one: #;(((((name x number) (name x number)) ...) diff --git a/collects/redex/scribblings/tut.scrbl b/collects/redex/scribblings/tut.scrbl index 2c43b75af7..96a5f6c070 100644 --- a/collects/redex/scribblings/tut.scrbl +++ b/collects/redex/scribblings/tut.scrbl @@ -45,7 +45,7 @@ @(define-for-syntax (loc stx) (let ([src (syntax-source stx)]) (if (path? src) - (path->relative-string/library src) + (path->relative-string/library src) #f))) @(define-syntax (interaction/test stx) (syntax-case stx () diff --git a/collects/redex/tests/check-syntax-test.rkt b/collects/redex/tests/check-syntax-test.rkt index 4d9b822dba..343da9d44c 100644 --- a/collects/redex/tests/check-syntax-test.rkt +++ b/collects/redex/tests/check-syntax-test.rkt @@ -45,8 +45,8 @@ (super-new) (define/override (syncheck:find-source-object stx) stx) - (define/override (syncheck:add-rename-menu id - all-ids + (define/override (syncheck:add-rename-menu id + all-ids new-name-interferes?) (match all-ids [(list (list ids _ _) ...) @@ -58,13 +58,13 @@ (equal? (source stx) (source id))) (set-union class (apply set (map source ids))) class))) - (define/override (syncheck:add-arrow start-source-obj - start-left - start-right - end-source-obj - end-left - end-right - actual? + (define/override (syncheck:add-arrow start-source-obj + start-left + start-right + end-source-obj + end-left + end-right + actual? phase-level) (set! arrows (set-add arrows diff --git a/collects/scribblings/framework/splash.scrbl b/collects/scribblings/framework/splash.scrbl index fc61340e0f..3de13845f7 100644 --- a/collects/scribblings/framework/splash.scrbl +++ b/collects/scribblings/framework/splash.scrbl @@ -26,7 +26,7 @@ that number to control the gauge along the bottom of the splash screen. [splash-title string?] [width-default exact-nonnegative-integer?] [#:allow-funny? allow-funny? boolean? #f] - [#:frame-icon + [#:frame-icon frame-icon (or/c #f (is-a?/c bitmap%) diff --git a/collects/scribblings/guide/contracts-examples/ho-version3.rkt b/collects/scribblings/guide/contracts-examples/ho-version3.rkt index b9664b8936..573ccb0be1 100644 --- a/collects/scribblings/guide/contracts-examples/ho-version3.rkt +++ b/collects/scribblings/guide/contracts-examples/ho-version3.rkt @@ -18,8 +18,8 @@ (r (f lov) (lambda (r) (define f@r (f r)) - (and (for/and ((v lov)) (>= f@r (f v))) - (eq? (first (memf (lambda (v) (= (f v) f@r)) lov)) + (and (for/and ((v lov)) (>= f@r (f v))) + (eq? (first (memf (lambda (v) (= (f v) f@r)) lov)) r)))))]))) (module b racket/base diff --git a/collects/scribblings/htdp-langs/beginner-abbr.scrbl b/collects/scribblings/htdp-langs/beginner-abbr.scrbl index 117b06e563..15e3a15d79 100644 --- a/collects/scribblings/htdp-langs/beginner-abbr.scrbl +++ b/collects/scribblings/htdp-langs/beginner-abbr.scrbl @@ -30,7 +30,7 @@ (code:line @#,elem{@racketvalfont{'}@racket[_quoted]}) (code:line @#,elem{@racketvalfont{`}@racket[_quasiquoted]}) number - boolean + boolean string character] ] diff --git a/collects/scribblings/reference/generic.scrbl b/collects/scribblings/reference/generic.scrbl index 6c94941c07..7b9ab77121 100644 --- a/collects/scribblings/reference/generic.scrbl +++ b/collects/scribblings/reference/generic.scrbl @@ -4,8 +4,8 @@ @title[#:tag "struct-generics"]{Generic Interfaces} @; @author[@author+email["Eli Barzilay" "eli@racket-lang.org"] @; @author+email["Jay McCarthy" "jay@racket-lang.org"] -@; @author+email["Vincent St-Amour" "stamourv@racket-lang.org"] -@; @author+email["Asumu Takikawa" "asumu@racket-lang.org"]] +@; @author+email["Vincent St-Amour" "stamourv@racket-lang.org"] +@; @author+email["Asumu Takikawa" "asumu@racket-lang.org"]] @defmodule[racket/generic] diff --git a/collects/scribblings/tools/tools.scrbl b/collects/scribblings/tools/tools.scrbl index ec535c8b24..91acdcd094 100644 --- a/collects/scribblings/tools/tools.scrbl +++ b/collects/scribblings/tools/tools.scrbl @@ -786,15 +786,15 @@ Check Syntax is a part of the DrRacket collection, but is implemented via the to (super-new) (define/override (syncheck:find-source-object stx) stx) - (define/override (syncheck:add-arrow start-source-obj - start-left - start-right - end-source-obj - end-left - end-right - actual? + (define/override (syncheck:add-arrow start-source-obj + start-left + start-right + end-source-obj + end-left + end-right + actual? phase-level) - (set! arrows + (set! arrows (cons (list start-source-obj end-source-obj) arrows))) (define arrows '()) diff --git a/collects/sgl/examples/alpha.rkt b/collects/sgl/examples/alpha.rkt index a0fdc8e44d..c99a06b628 100644 --- a/collects/sgl/examples/alpha.rkt +++ b/collects/sgl/examples/alpha.rkt @@ -64,14 +64,14 @@ ;; draw cube. (glLoadIdentity) (glTranslated 0 0 *z*) - (glRotated *xrot* 1 0 0) + (glRotated *xrot* 1 0 0) (glRotated *yrot* 0 1 0) (glRotated *zrot* 0 0 1) (glBindTexture GL_TEXTURE_2D (get-texture *tex*)) (glBegin GL_QUADS) ; front (glNormal3d 0 0 1) - (glTexCoord2i 0 0) + (glTexCoord2i 0 0) (glVertex3i -1 -1 1) (glTexCoord2i 1 0) (glVertex3i 1 -1 1) @@ -81,7 +81,7 @@ (glVertex3i -1 1 1) ; back (glNormal3d 0 0 -1) - (glTexCoord2i 1 0) + (glTexCoord2i 1 0) (glVertex3i -1 -1 -1) (glTexCoord2i 1 1) (glVertex3i 1 -1 -1) @@ -91,7 +91,7 @@ (glVertex3i -1 1 -1) ; top (glNormal3d 0 1 0) - (glTexCoord2i 0 1) + (glTexCoord2i 0 1) (glVertex3i -1 1 -1) (glTexCoord2i 0 0) (glVertex3i 1 1 -1) @@ -111,7 +111,7 @@ (glVertex3i 1 -1 -1) ; right (glNormal3d 1 0 0) - (glTexCoord2i 1 0) + (glTexCoord2i 1 0) (glVertex3i 1 -1 -1) (glTexCoord2i 1 1) (glVertex3i 1 -1 1) @@ -121,7 +121,7 @@ (glVertex3i 1 1 -1) ;left (glNormal3d -1 0 0) - (glTexCoord2i 0 0) + (glTexCoord2i 0 0) (glVertex3i -1 -1 -1) (glTexCoord2i 1 0) (glVertex3i -1 1 -1) diff --git a/collects/sirmail/readr.rkt b/collects/sirmail/readr.rkt index f65189e8d0..5a648b14b8 100644 --- a/collects/sirmail/readr.rkt +++ b/collects/sirmail/readr.rkt @@ -11,9 +11,9 @@ (module readr mzscheme (require mzlib/unit - mzlib/class + mzlib/class mzlib/file - mred/mred-sig + mred/mred-sig framework mzlib/process) @@ -27,11 +27,11 @@ (require "pref.rkt") (require net/imap-sig - net/smtp-sig - net/head-sig - net/base64-sig - net/mime-sig - net/qp-sig + net/smtp-sig + net/head-sig + net/base64-sig + net/mime-sig + net/qp-sig browser/htmltext) (require mrlib/hierlist/hierlist-sig) @@ -2197,7 +2197,7 @@ (define re:date (regexp - "([0-9]*)[ ]+([A-Za-z]+)[ ]+([0-9]+)[ ]+([0-9][0-9]):([0-9][0-9]):([0-9][0-9])")) + "([0-9]*)[ \t]+([A-Za-z]+)[ \t]+([0-9]+)[ \t]+([0-9][0-9]):([0-9][0-9]):([0-9][0-9])")) ;; using the tz seems to require a date->seconds -- too expensive. (define (date-cmp aid bid a b) diff --git a/collects/srfi/14/char-set.rkt b/collects/srfi/14/char-set.rkt index 85fac2b8db..cbdeed27f7 100644 --- a/collects/srfi/14/char-set.rkt +++ b/collects/srfi/14/char-set.rkt @@ -8,21 +8,21 @@ racket/contract) ;; Data defn ---------------------------------------- - + (define-struct char-set (set/thunk)) (define (fold-set op init l) (if (null? l) - init - (fold-set op (op init (car l)) (cdr l)))) + init + (fold-set op (op init (car l)) (cdr l)))) (define (char-set-set cs) (let ([v (char-set-set/thunk cs)]) (if (procedure? v) - (let ([v2 (v)]) - (set-char-set-set/thunk! cs v2) - v2) - v))) + (let ([v2 (v)]) + (set-char-set-set/thunk! cs v2) + v2) + v))) ;; General procedures ---------------------------------------- @@ -31,7 +31,7 @@ [() #t] [(cs) #t] [(cs1 cs2) (equal? (integer-set-contents (char-set-set cs1)) - (integer-set-contents (char-set-set cs2)))] + (integer-set-contents (char-set-set cs2)))] [(cs1 . rest) (fold-set (lambda (v cs) (and v (char-set= cs1 cs))) #t rest)])) (define char-set<= @@ -63,8 +63,8 @@ (define (char-set-cursor-next cs c) (let ([d (- (cdadr c) (caadr c))]) (if (= d (car c)) - (cons 0 (cddr c)) - (cons (add1 (car c)) (cdr c))))) + (cons 0 (cddr c)) + (cons (add1 (car c)) (cdr c))))) (define (end-of-char-set? c) (null? (cdr c))) @@ -72,15 +72,15 @@ (define (char-set-fold/done kons knil cs done?) (let loop ([v knil][l (integer-set-contents (char-set-set cs))]) (if (null? l) - v - (let ([end (cdar l)]) - (let iloop ([v v][i (caar l)]) - (if (i . > . end) - (loop v (cdr l)) - (let ([v (kons (integer->char i) v)]) - (if (done? v) - v - (iloop v (add1 i)))))))))) + v + (let ([end (cdar l)]) + (let iloop ([v v][i (caar l)]) + (if (i . > . end) + (loop v (cdr l)) + (let ([v (kons (integer->char i) v)]) + (if (done? v) + v + (iloop v (add1 i)))))))))) (define (char-set-fold kons knil cs) (char-set-fold/done kons knil cs (lambda (x) #f))) @@ -92,7 +92,7 @@ ;; Implementation taken directly from SRFI-14: (let lp ((seed seed) (cs base-cs)) (if (p seed) - cs ; P says we are done. + cs ; P says we are done. (lp (g seed) ; Loop on (G SEED). (char-set-adjoin! cs (f seed)))))])) @@ -116,7 +116,7 @@ (define mk-char-set (let ([char-set (lambda more - (list->char-set more char-set:empty))]) + (list->char-set more char-set:empty))]) char-set)) (define list->char-set @@ -138,10 +138,10 @@ [(pred cs) (char-set-filter pred cs char-set:empty)] [(pred cs base-cs) (char-set-fold (lambda (c v) (if (pred c) - (char-set-adjoin v c) - v)) - base-cs - cs)])) + (char-set-adjoin v c) + v)) + base-cs + cs)])) (define (char-set-filter! pred cs base-cs) (char-set-filter pred cs base-cs)) @@ -151,34 +151,34 @@ [(lower upper error?) (ucs-range->char-set lower upper error? char-set:empty)] [(lower upper error? cs) (when (or (lower . < . 0) - (upper . > . #x110000) - (lower . >= . upper)) - (raise (make-exn:fail:contract - (format "ucs-range->char-set: invalid range: [~a, ~a)" lower upper) - (current-continuation-marks)))) + (upper . > . #x110000) + (lower . >= . upper)) + (raise (make-exn:fail:contract + (format "ucs-range->char-set: invalid range: [~a, ~a)" lower upper) + (current-continuation-marks)))) (char-set-union cs - (cond - [(and (upper . <= . #xE000) - (lower . >= . #xD800)) - ;; Completely in the hole - char-set:empty] - [(upper . <= . #xE000) - ;; Below the hole - (make-char-set (make-integer-set (list (cons lower (sub1 (min #xD800 upper))))))] - [(lower . >= . #xD800) - ;; Above the hole - (make-char-set (make-integer-set (list (cons (max #xE000 lower) (sub1 upper)))))] - [else - ;; Spans the hole: - (make-char-set (make-integer-set (list (cons lower #xD7FF) - (cons #xE000 (sub1 upper)))))]))])) + (cond + [(and (upper . <= . #xE000) + (lower . >= . #xD800)) + ;; Completely in the hole + char-set:empty] + [(upper . <= . #xE000) + ;; Below the hole + (make-char-set (make-integer-set (list (cons lower (sub1 (min #xD800 upper))))))] + [(lower . >= . #xD800) + ;; Above the hole + (make-char-set (make-integer-set (list (cons (max #xE000 lower) (sub1 upper)))))] + [else + ;; Spans the hole: + (make-char-set (make-integer-set (list (cons lower #xD7FF) + (cons #xE000 (sub1 upper)))))]))])) (define (ucs-range->char-set! lower upper error? base-cs) (ucs-range->char-set lower upper error? base-cs)) (define (->char-set x) (cond [(char? x) (let ([v (char->integer x)]) - (make-char-set (make-integer-set (list (cons v v)))))] + (make-char-set (make-integer-set (list (cons v v)))))] [(string? x) (string->char-set x)] [(char-set? x) x] [else (raise-type-error '->char-set "character, string, or char-set" x)])) @@ -188,18 +188,18 @@ (define (char-set-size cs) (let loop ([l (integer-set-contents (char-set-set cs))][c 0]) (if (null? l) - c - (loop (cdr l) (+ c 1 (- (cdar l) (caar l))))))) + c + (loop (cdr l) (+ c 1 (- (cdar l) (caar l))))))) (define (char-set-count pred cs) (char-set-fold (lambda (c v) - (+ v (if (pred c) 1 0))) - 0 - cs)) + (+ v (if (pred c) 1 0))) + 0 + cs)) (define (char-set->list cs) (char-set-fold cons null cs)) - + (define (char-set->string cs) (list->string (char-set->list cs))) @@ -208,28 +208,28 @@ (define (char-set-every pred cs) (char-set-fold/done (lambda (c v) - (and v - (pred c))) - #t - cs - not)) + (and v + (pred c))) + #t + cs + not)) (define (char-set-any pred cs) (char-set-fold/done (lambda (c v) - (or v - (pred c))) - #f - cs - values)) + (or v + (pred c))) + #f + cs + values)) ;; Character-set algebra ---------------------------------------- - (define char-set-adjoin + (define char-set-adjoin (case-lambda [(cs char1) (let ([v (char->integer char1)]) - (make-char-set (union (char-set-set cs) - (make-integer-set (list (cons v v))))))] + (make-char-set (union (char-set-set cs) + (make-integer-set (list (cons v v))))))] [(cs . more) (fold-set char-set-adjoin cs more)])) @@ -237,27 +237,27 @@ (case-lambda [(cs char1) (let ([v (char->integer char1)]) - (make-char-set (difference (char-set-set cs) - (make-integer-set (list (cons v v))))))] + (make-char-set (difference (char-set-set cs) + (make-integer-set (list (cons v v))))))] [(cs . more) (fold-set char-set-delete cs more)])) (define (char-set-complement cs) (make-char-set (difference (complement (char-set-set cs) 0 #x10FFFF) - (make-range #xD800 #xDFFF)))) + (make-range #xD800 #xDFFF)))) (define-syntax define-set-op (syntax-rules () [(_ char-set-op set-op neutral) - (define char-set-op - (case-lambda - [(cs1 cs2) - (make-char-set (set-op (char-set-set cs1) (char-set-set cs2)))] - [() - neutral] - [(cs1 . more) - (fold-set char-set-op cs1 more)]))])) + (define char-set-op + (case-lambda + [(cs1 cs2) + (make-char-set (set-op (char-set-set cs1) (char-set-set cs2)))] + [() + neutral] + [(cs1 . more) + (fold-set char-set-op cs1 more)]))])) (define-set-op char-set-union union char-set:empty) (define-set-op char-set-intersection intersect char-set:full) @@ -301,39 +301,39 @@ (make-char-set (lambda () (make-integer-set - (let loop ([l unicode]) - (cond - [(null? l) null] - [(caddar l) - ;; Every char in this range has the same properites - (if (pred? (integer->char (caar l))) - (cons (cons (caar l) (cadar l)) (loop (cdr l))) - (loop (cdr l)))] - [else - ;; Check char-by-char: - (let ([end (cadar l)]) - (let no-loop ([v (caar l)]) - (cond - [(v . > . end) - ;; None in this range - (loop (cdr l))] - [(pred? (integer->char v)) - ;; Found a char in this range - (let yes-loop ([v2 (add1 v)]) - (cond - [(v2 . > . end) - ;; Went to end - (cons (cons v (sub1 v2)) (loop (cdr l)))] - [(pred? (integer->char v2)) - (yes-loop (add1 v2))] - [else - ;; Found end of sub-range; treat the rest - ;; of this range as a new range - (cons (cons v (sub1 v2)) - (loop (cons (list v2 end #f) (cdr l))))]))] - [else - ;; Still looking for a char in this range - (no-loop (add1 v))])))])))))) + (let loop ([l unicode]) + (cond + [(null? l) null] + [(caddar l) + ;; Every char in this range has the same properites + (if (pred? (integer->char (caar l))) + (cons (cons (caar l) (cadar l)) (loop (cdr l))) + (loop (cdr l)))] + [else + ;; Check char-by-char: + (let ([end (cadar l)]) + (let no-loop ([v (caar l)]) + (cond + [(v . > . end) + ;; None in this range + (loop (cdr l))] + [(pred? (integer->char v)) + ;; Found a char in this range + (let yes-loop ([v2 (add1 v)]) + (cond + [(v2 . > . end) + ;; Went to end + (cons (cons v (sub1 v2)) (loop (cdr l)))] + [(pred? (integer->char v2)) + (yes-loop (add1 v2))] + [else + ;; Found end of sub-range; treat the rest + ;; of this range as a new range + (cons (cons v (sub1 v2)) + (loop (cons (list v2 end #f) (cdr l))))]))] + [else + ;; Still looking for a char in this range + (no-loop (add1 v))])))])))))) (define char-set:lower-case (make-standard-set char-lower-case?)) diff --git a/collects/srfi/19/time.rkt b/collects/srfi/19/time.rkt index 37adbf89f6..bac5a3388a 100644 --- a/collects/srfi/19/time.rkt +++ b/collects/srfi/19/time.rkt @@ -166,8 +166,8 @@ ;; a different epoch is used. (define tm:nano (expt 10 9)) -(define tm:sid 86400) ; seconds in a day -(define tm:sihd 43200) ; seconds in a half day +(define tm:sid 86400) ; seconds in a day +(define tm:sihd 43200) ; seconds in a half day (define tm:tai-epoch-in-jd 4881175/2) ; julian day number for 'the epoch' ;; A Very simple Error system for the time procedures @@ -1341,9 +1341,9 @@ (accum-int port (+ (* accum 10) (tm:char->int (read-char port))) (+ nchars 1))) (padding-ok - (read-char port) ; consume padding + (read-char port) ; consume padding (accum-int port accum (+ nchars 1))) - (else ; padding where it shouldn't be + (else ; padding where it shouldn't be (tm:time-error 'string->date 'bad-date-template-string "Non-numeric characters in integer read."))))) (accum-int port 0 0))) diff --git a/collects/srfi/2/and-let.rkt b/collects/srfi/2/and-let.rkt index 90938fd429..ba68aae08b 100644 --- a/collects/srfi/2/and-let.rkt +++ b/collects/srfi/2/and-let.rkt @@ -6,14 +6,14 @@ ;;; this code is under the LGPL licence. Nevertheless, I only did the ;;; port to PLT Scheme, the original comment follows: -; Checking of a LAND* special form +; Checking of a LAND* special form ; ; LAND* is a generalized AND: it evaluates a sequence of forms one after another ; till the first one that yields #f; the non-#f result of a form can be bound ; to a fresh variable and used in the subsequent forms. ; ; When an ordinary AND is formed of _proper_ boolean expressions: -; (AND E1 E2 ...) +; (AND E1 E2 ...) ; expression E2, if it gets to be evaluated, knows that E1 has returned non-#f. ; Moreover, E2 knows exactly what the result of E1 was - #t - so E2 can use ; this knowledge to its advantage. If E1 however is an _extended_ @@ -27,22 +27,22 @@ ; their work. ; ; Syntax: -; LAND* (CLAWS) BODY +; LAND* (CLAWS) BODY ; ; where CLAWS is a list of expressions or bindings: -; CLAWS ::= '() | (cons CLAW CLAWS) +; CLAWS ::= '() | (cons CLAW CLAWS) ; Every element of the CLAWS list, a CLAW, must be one of the following: -; (VARIABLE EXPRESSION) +; (VARIABLE EXPRESSION) ; or -; (EXPRESSION) +; (EXPRESSION) ; or -; BOUND-VARIABLE +; BOUND-VARIABLE ; These CLAWS are evaluated in the strict left-to-right order. For each ; CLAW, the EXPRESSION part is evaluated first (or BOUND-VARIABLE is looked up). ; If the result is #f, LAND* immediately returns #f, thus disregarding the rest ; of the CLAWS and the BODY. If the EXPRESSION evaluates to not-#f, and ; the CLAW is of the form -; (VARIABLE EXPRESSION) +; (VARIABLE EXPRESSION) ; the EXPRESSION's value is bound to a freshly made VARIABLE. The VARIABLE is ; available for _the rest_ of the CLAWS, and the BODY. As usual, all ; VARIABLEs must be unique (like in let*). @@ -52,8 +52,8 @@ ; Denotation semantics: ; ; Eval[ (LAND* (CLAW1 ...) BODY), Env] = -; EvalClaw[ CLAW1, Env ] andalso -; Eval[ (LAND* ( ...) BODY), ExtClawEnv[ CLAW1, Env]] +; EvalClaw[ CLAW1, Env ] andalso +; Eval[ (LAND* ( ...) BODY), ExtClawEnv[ CLAW1, Env]] ; ; Eval[ (LAND* (CLAW) ), Env] = EvalClaw[ CLAW, Env ] ; Eval[ (LAND* () FORM1 ...), Env] = Eval[ (BEGIN FORM1 ...), Env ] @@ -66,8 +66,8 @@ ; ExtClawEnv[ BOUND-VARIABLE, Env ] = Env ; ExtClawEnv[ (EXPRESSION), Env ] = EnvAfterEval[ EXPRESSION, Env ] ; ExtClawEnv[ (VARIABLE EXPRESSION), Env ] = -; ExtendEnv[ EnvAfterEval[ EXPRESSION, Env ], -; VARIABLE boundto Eval[ EXPRESSION, Env ]] +; ExtendEnv[ EnvAfterEval[ EXPRESSION, Env ], +; VARIABLE boundto Eval[ EXPRESSION, Env ]] ; ; ; If one has a Scheme interpreter written in Prolog/ML/Haskell, he can @@ -78,10 +78,10 @@ ; The following LAND* macro will convert a LAND* expression into a "tree" of ; AND and LET expressions. For example, ; (LAND* ((my-list (compute-list)) ((not (null? my-list)))) -; (do-something my-list)) +; (do-something my-list)) ; is transformed into ; (and (let ((my-list (compute-list))) -; (and my-list (not (null? my-list)) (begin (do-something my-list))))) +; (and my-list (not (null? my-list)) (begin (do-something my-list))))) ; ; I must admit the LAND* macro is written in a pathetic anti-functional style. ; To my excuse, the macro's goal is a syntactic transformation of source @@ -95,23 +95,23 @@ ; (if new-root (set! root new-root))) ; could be elegantly re-written as ; (land* ((new-root (node:dispatch-on-key root key ...))) -; (set! root new-root)) +; (set! root new-root)) ; ; A very common application of land* is looking up a value ; associated with a given key in an assoc list, returning #f in case of a ; look-up failure: ; -; ; Standard implementation +; ; Standard implementation ; (define (look-up key alist) ; (let ((found-assoc (assq key alist))) -; (and found-assoc (cdr found-assoc)))) +; (and found-assoc (cdr found-assoc)))) ; -; ; A more elegant solution +; ; A more elegant solution ; (define (look-up key alist) ; (cdr (or (assq key alist) '(#f . #f)))) ; -; ; An implementation which is just as graceful as the latter -; ; and just as efficient as the former: +; ; An implementation which is just as graceful as the latter +; ; and just as efficient as the former: ; (define (look-up key alist) ; (land* ((x (assq key alist))) (cdr x))) ; @@ -128,7 +128,7 @@ ; ; (or ; (land* ((c (read-char)) ((not (eof-object? c)))) -; (string-set! some-str i c) (++! i)) +; (string-set! some-str i c) (++! i)) ; (begin (do-process-eof))) ; ; Another concept LAND* is reminiscent of is programming with guards: @@ -162,17 +162,17 @@ ;; (and-let* ((x y))) [(_ ((id val))) (unless (identifier? (syntax id)) - (raise-syntax-error #f "expected an identifier" stx (syntax id))) + (raise-syntax-error #f "expected an identifier" stx (syntax id))) (syntax val)] ;; (and-let* ((x y)) body) [(_ ((id val) more ...) . body) (unless (identifier? (syntax id)) - (raise-syntax-error #f "expected an identifier" stx (syntax id))) + (raise-syntax-error #f "expected an identifier" stx (syntax id))) (syntax (let ((id val)) - (if id - (and-let* (more ...) . body) - #f)))] + (if id + (and-let* (more ...) . body) + #f)))] [(_ ((exp))) (syntax exp)] @@ -183,18 +183,18 @@ [(_ (exp) . body) (syntax (if exp - (begin . body) - #f))] + (begin . body) + #f))] [(_ ((exp) more ...) . body) (syntax (if exp - (and-let* (more ...) . body) - #f))] + (and-let* (more ...) . body) + #f))] [(_ (exp more ...) . body) (syntax (if exp - (and-let* (more ...) . body) - #f))] + (and-let* (more ...) . body) + #f))] [(_ () . body) (syntax (begin . body))] )) diff --git a/collects/srfi/25/array.rkt b/collects/srfi/25/array.rkt index 08af32dae7..4b2f47fa21 100644 --- a/collects/srfi/25/array.rkt +++ b/collects/srfi/25/array.rkt @@ -650,7 +650,7 @@ (array:index-set! in k 0)) (let* ((n0 (proc in)) (n (array:index-length n0))) - (let ((arr (make-array (shape 0 (+ m 1) 0 n)))) ; (*) + (let ((arr (make-array (shape 0 (+ m 1) 0 n)))) ; (*) (do ((k 0 (+ k 1))) ((= k n)) (array-set! arr 0 k (array:index-ref n0 k))) ; (**) diff --git a/collects/string-constants/private/german-string-constants.rkt b/collects/string-constants/private/german-string-constants.rkt index dc841094ec..972dc308e5 100644 --- a/collects/string-constants/private/german-string-constants.rkt +++ b/collects/string-constants/private/german-string-constants.rkt @@ -61,12 +61,12 @@ (bug-report-field-docs-installed "Installierte Dokumentation") (bug-report-field-collections "Collections") (bug-report-field-links "Links") ;; from 'raco link' - (bug-report-field-human-language "Interaktionssprache") ; + (bug-report-field-human-language "Interaktionssprache") ; (bug-report-field-memory-use "Speicherverbrauch") (bug-report-field-version "Version") (bug-report-synthesized-information "Generierte Information") ;; dialog title - (bug-report-show-synthesized-info "Generierte Informationen anzeigen") ; (an)zeigen - (bug-report-submit "Abschicken") + (bug-report-show-synthesized-info "Generierte Informationen anzeigen") ; (an)zeigen + (bug-report-submit "Abschicken") (close-and-save-bug-report "Schließen && Speichern") ;; button in bug report dialog, next to cancel and bug-report-submit (bug-report-submit-menu-item "Bug-Report abschicken...") ;; in Help Menu (drs & help desk) (saved-bug-reports-menu-item "Gepeicherte Bug-Reports") ;; in Help Menu, submenu title diff --git a/collects/string-constants/private/korean-string-constants.rkt b/collects/string-constants/private/korean-string-constants.rkt index b3108dbeb1..ece2d1ae65 100644 --- a/collects/string-constants/private/korean-string-constants.rkt +++ b/collects/string-constants/private/korean-string-constants.rkt @@ -111,7 +111,7 @@ (cs-view-docs "~a 문서 보기") (cs-view-docs-from "~a 에서 온 ~a") ;; a completed version of the line above (cs-view-docs) is put into the first ~a and a list of modules (separated by commas) is put into the second ~a. Use check syntax and right-click on a documented variable (eg, 'require') to see this in use - (cs-lexical-variable "lexical 변수") ;확인하기 + (cs-lexical-variable "lexical 변수") ;확인하기 (cs-set!d-variable "set!’d 변수") (cs-imported-variable "imported 변수") @@ -216,7 +216,7 @@ (plt:hd:feeling-lucky "느낌이 옴") (plt:hd:home "도움말 홈") ; next 3 are popup menu choices in help desk search frame - (plt:hd:search-for-keyword "키워드 입력") ;확인하기. entry? + (plt:hd:search-for-keyword "키워드 입력") ;확인하기. entry? (plt:hd:search-for-keyword-or-index "키워드 또는 목차 입력") (plt:hd:search-for-keyword-or-index-or-text "키워드, 목차, 텍스트 입력") (plt:hd:exact-match "정확하게 일치") diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl index f3474aaecc..132a52e5fc 100644 --- a/collects/teachpack/2htdp/scribblings/universe.scrbl +++ b/collects/teachpack/2htdp/scribblings/universe.scrbl @@ -13,13 +13,13 @@ ;; (list paragraph paragraph) *-> Table (define (flow* x) (make-flow (list x))) (make-blockquote #f - (list + (list (make-table (make-with-attributes 'boxed - '((cellspacing . "6"))) - ;list - (map (lambda (x) (map flow* x)) stuff) - #;(map flow* (map car stuff)) - #;(map flow* (map cadr stuff)))))) + '((cellspacing . "6"))) + ;list + (map (lambda (x) (map flow* x)) stuff) + #;(map flow* (map car stuff)) + #;(map flow* (map cadr stuff)))))) @; ----------------------------------------------------------------------------- @@ -59,19 +59,19 @@ The purpose of this documentation is to give experienced Schemers and HtDP @; ----------------------------------------------------------------------------- @section[#:tag "scene"]{Background} - + The universe teachpack assumes working knowledge of the basic image manipulation operations, either @racketmodname[htdp/image] or @racketmodname[2htdp/image]. As far as this extended reference is concerned, the major difference between the two image teachpacks is -the assumption that +the assumption that @nested[#:style 'inset]{ - @racketmodname[htdp/image] programs render their state as @emph{scenes}, + @racketmodname[htdp/image] programs render their state as @emph{scenes}, i.e., images that satisfy the @racket[scene?] predicate. } Recall that @racketmodname[htdp/image] defines a scene to be an image whose -pinhole is at @math{(0,0)}. If your program uses the operations of -@racketmodname[2htdp/image], all images are also scenes. +pinhole is at @math{(0,0)}. If your program uses the operations of +@racketmodname[2htdp/image], all images are also scenes. While the operations of this teachpack work with both image teachpacks, we hope to eliminate @racketmodname[htdp/image] in the not-too-distant future. @@ -79,7 +79,7 @@ All example programs are already written using @racketmodname[2htdp/image] operations. We urge programmers to use @racketmodname[2htdp/image] when they design new ``world'' and ``universe'' programs and to rewrite their existing @racketmodname[htdp/image] programs to use -@racketmodname[2htdp/image]. +@racketmodname[2htdp/image]. @; ----------------------------------------------------------------------------- @section[#:tag "simulations"]{Simple Simulations} @@ -98,7 +98,7 @@ The simplest kind of animated @tech{world} program is a time-based function calls are displayed in the canvas. The simulation runs until you click the @tt{Stop} button in DrRacket or close the window. At that point, @racket[animate] returns the number of ticks that have - passed. + passed. } Example: @@ -121,7 +121,7 @@ Example: @racket[animate] was originally called @racket[run-simulation], and this binding is retained for backwards compatibility} -@defproc[(run-movie [r (and/c real? positive?)] [m [Listof image?]]) +@defproc[(run-movie [r (and/c real? positive?)] [m [Listof image?]]) true]{ @racket[run-movie] displays the list of images @racket[m] at the rate of @@ -147,14 +147,14 @@ Your program may deal with such events via the @emph{designation} of program must specify a @racket[draw] function, which is called every time your program should visualize the current world, and a @racket[done] predicate, which is used - to determine when the @tech{world} program should shut down. + to determine when the @tech{world} program should shut down. Each handler function consumes the current state of the @tech{world} and optionally a data representation of the event. It produces a new state of - the @tech{world}. + the @tech{world}. The following picture provides an intuitive overview of the workings of a - @tech{world} program in the form of a state transition diagram. + @tech{world} program in the form of a state transition diagram. @image["nuworld.png"] @@ -163,7 +163,7 @@ The following picture provides an intuitive overview of the workings of a one world into another one; each time an event is handled, @racket[done] is used to check whether the world is final, in which case the program is shut down; and finally, @racket[draw] renders each world as an image, which - is then displayed on an external canvas. + is then displayed on an external canvas. @deftech{WorldState} : @racket[any/c] @@ -176,28 +176,28 @@ The design of a world program demands that you come up with a data violates the Design Recipe. @defform/subs[#:id big-bang - #:literals - (on-tick to-draw on-draw on-key on-pad on-release on-mouse on-receive stop-when - check-with register record? state name) + #:literals + (on-tick to-draw on-draw on-key on-pad on-release on-mouse on-receive stop-when + check-with register record? state name) (big-bang state-expr clause ...) ([clause - (on-tick tick-expr) - (on-tick tick-expr rate-expr) - (on-tick tick-expr rate-expr limit-expr) - (on-key key-expr) - (on-pad pad-expr) - (on-release release-expr) - (on-mouse mouse-expr) - (to-draw draw-expr) - (to-draw draw-expr width-expr height-expr) - (stop-when stop-expr) (stop-when stop-expr last-scene-expr) - (check-with world?-expr) - (record? r-expr) - (state boolean-expr) - (on-receive rec-expr) - (register IP-expr) - (name name-expr) - ])]{ + (on-tick tick-expr) + (on-tick tick-expr rate-expr) + (on-tick tick-expr rate-expr limit-expr) + (on-key key-expr) + (on-pad pad-expr) + (on-release release-expr) + (on-mouse mouse-expr) + (to-draw draw-expr) + (to-draw draw-expr width-expr height-expr) + (stop-when stop-expr) (stop-when stop-expr last-scene-expr) + (check-with world?-expr) + (record? r-expr) + (state boolean-expr) + (on-receive rec-expr) + (register IP-expr) + (name name-expr) + ])]{ starts a @tech{world} program in the initial state specified with @racket[state-expr], which must of course evaluate to an element of @@ -215,14 +215,14 @@ The design of a world program demands that you come up with a data } The only mandatory clause of a @racket[big-bang] description is -@racket[to-draw] (or @racket[on-draw] for backwards compatibility): +@racket[to-draw] (or @racket[on-draw] for backwards compatibility): @itemize[ @item{ - + @defform[(to-draw render-expr) #:contracts - ([render-expr (-> (unsyntax @tech{WorldState}) scene?)])]{ + ([render-expr (-> (unsyntax @tech{WorldState}) scene?)])]{ @note-scene tells DrRacket to call the function @racket[render-expr] whenever the canvas must be drawn. The external canvas is usually re-drawn after DrRacket has @@ -233,8 +233,8 @@ The only mandatory clause of a @racket[big-bang] description is (to-draw render-expr width-expr height-expr) #:contracts ([render-expr (-> (unsyntax @tech{WorldState}) scene?)] - [width-expr natural-number/c] - [height-expr natural-number/c])]{ + [width-expr natural-number/c] + [height-expr natural-number/c])]{ @note-scene tells DrRacket to use a @racket[width-expr] by @racket[height-expr] canvas instead of one determine by the first generated image. @@ -242,18 +242,18 @@ The only mandatory clause of a @racket[big-bang] description is For compatibility reasons, the teachpack also supports the keyword @defidform/inline[on-draw] in lieu of @racket[to-draw] but the latter is preferred -now. +now. } ] -All remaining clauses are optional: +All remaining clauses are optional: @itemize[ @item{ @defform[(on-tick tick-expr) #:contracts - ([tick-expr (-> (unsyntax @tech{WorldState}) (unsyntax @tech{WorldState}))])]{ + ([tick-expr (-> (unsyntax @tech{WorldState}) (unsyntax @tech{WorldState}))])]{ tells DrRacket to call the @racket[tick-expr] function on the current world every time the clock ticks. The result of the call becomes the @@ -275,13 +275,13 @@ current world. The clock ticks every @racket[rate-expr] seconds.}} #:contracts ([tick-expr (-> (unsyntax @tech{WorldState}) (unsyntax @tech{WorldState}))] [rate-expr (and/c real? positive?)] - [limit-expr (and/c integer? positive?)])]{ + [limit-expr (and/c integer? positive?)])]{ tells DrRacket to call the @racket[tick-expr] function on the current world every time the clock ticks. The result of the call becomes the -current world. The clock ticks every @racket[rate-expr] seconds. +current world. The clock ticks every @racket[rate-expr] seconds. The world ends when the clock has ticked more than @scheme[limit-expr] times.}} -@item{A @tech{KeyEvent} represents key board events. +@item{A @tech{KeyEvent} represents key board events. @deftech{KeyEvent} : @racket[string?] @@ -330,9 +330,9 @@ Second, some keys have multiple-character string representations. Strings @item{@racket["snapshot"]} @item{@racket["insert"]} @item{@racket["help"]} -@item{@racket["numpad0"], - @racket["numpad1"], - @racket["numpad2"], +@item{@racket["numpad0"], + @racket["numpad1"], + @racket["numpad2"], @racket["numpad3"], @racket["numpad4"], @racket["numpad5"], @@ -387,12 +387,12 @@ Second, some keys have multiple-character string representations. Strings @defform[(on-key key-expr) #:contracts - ([key-expr (-> (unsyntax @tech{WorldState}) key-event? (unsyntax @tech{WorldState}))])]{ - tells DrRacket to call the @racket[key-expr] function on the current world and a + ([key-expr (-> (unsyntax @tech{WorldState}) key-event? (unsyntax @tech{WorldState}))])]{ + tells DrRacket to call the @racket[key-expr] function on the current world and a @tech{KeyEvent} for every keystroke the user of the computer makes. The result of the call becomes the current world. - Here is a typical key-event handler: + Here is a typical key-event handler: @racketblock[ (define (change w a-key) (cond @@ -409,24 +409,24 @@ Second, some keys have multiple-character string representations. Strings @defform[(on-release release-expr) #:contracts - ([release-expr (-> (unsyntax @tech{WorldState}) key-event? (unsyntax @tech{WorldState}))])]{ - tells DrRacket to call the @racket[release-expr] function on the current world and a + ([release-expr (-> (unsyntax @tech{WorldState}) key-event? (unsyntax @tech{WorldState}))])]{ + tells DrRacket to call the @racket[release-expr] function on the current world and a @tech{KeyEvent} for every release event on the keyboard. A release event occurs when a user presses the key and then releases it. The second argument indicates which key has been released. The result of the function call - becomes the current world. + becomes the current world. } } @item{A @tech{PadEvent} is a @tech{KeyEvent} for a game-pad simulation via @racket[big-bang]. The presence of an @racket[on-pad] clause superimposes -the game-pad image onto the current image, suitably scaled to its size: +the game-pad image onto the current image, suitably scaled to its size: @image["gamepad.png"] -@deftech{PadEvent} : @racket[key-event?] +@deftech{PadEvent} : @racket[key-event?] -It is one of the following: +It is one of the following: @itemize[ @item{@racket["left"] is the left arrow;} @item{@racket["right"] is the right arrow;} @@ -449,17 +449,17 @@ It is one of the following: @defform[(on-pad pad-expr) #:contracts - ([pad-expr (-> (unsyntax @tech{WorldState}) pad-event? (unsyntax @tech{WorldState}))])]{ + ([pad-expr (-> (unsyntax @tech{WorldState}) pad-event? (unsyntax @tech{WorldState}))])]{ tells DrRacket to call the @racket[pad-expr] function on the current world and the @tech{KeyEvent} for every keystroke that is also a @tech{PadEvent}. The result of the call becomes the current world. - Here is a typical @tech{PadEvent} handler: + Here is a typical @tech{PadEvent} handler: @;% @(begin #reader scribble/comment-reader (racketblock -;; ComplexNumber PadEvent -> ComplexNumber +;; ComplexNumber PadEvent -> ComplexNumber (define (handle-pad-events x k) (case (string->symbol k) [(up w) (- x 0+10i)] @@ -479,106 +479,102 @@ When a @racket[big-bang] expression specifies an @racket[on-pad] clause, all @tech{PadEvent}s are sent to the @racket[on-pad] handler. All other key events are discarded, unless an @racket[on-key] and/or an @racket[on-release] clause are specified, in which case all remaining -@tech{KeyEvent}s are sent there. +@tech{KeyEvent}s are sent there. To facilitate the definition of @racket[on-pad] handlers, the library -provides the @racket[pad-handler] form. +provides the @racket[pad-handler] form. @defform/subs[#:id pad-handler - #:literals - (up down left right space shift) + #:literals + (up down left right space shift) (pad-handler clause ...) ([clause - (up up-expr) - (down down-expr) - (left left-expr) - (right right-expr) - (space space-expr) - (shift shift-expr)])]{ + (up up-expr) + (down down-expr) + (left left-expr) + (right right-expr) + (space space-expr) + (shift shift-expr)])]{ Creates a function that deals with @tech{PadEvent}s. Each (optional) clause contributes one function that consumes a @tech{World} and produces a world. The name of the clause determines for which kind of @tech{PadEvent} - the function is called. + the function is called. Using the form is entirely optional and not required to use @racket[on-pad]. Indeed, @racket[pad-handler] could be used to define a plain @tech{KeyEvent} handler---if we could guarantee that players never - hit keys other than @tech{PadEvent} keys. + hit keys other than @tech{PadEvent} keys. } -All clauses in a @racket[pad-handler] form are optional: +All clauses in a @racket[pad-handler] form are optional: @itemize[ @item{ -@defform[(up up-expr) +@defform[(up up-expr) #:contracts ([tick-expr (-> (unsyntax @tech{WorldState}) (unsyntax @tech{WorldState}))])]{ Creates a handler for @racket["up"] and @racket["w"] events.} } @item{ -@defform[(down down-expr) +@defform[(down down-expr) #:contracts ([tick-expr (-> (unsyntax @tech{WorldState}) (unsyntax @tech{WorldState}))])]{ Creates a handler for @racket["down"] and @racket["s"] events.} } @item{ -@defform[(left left-expr) +@defform[(left left-expr) #:contracts - ([tick-expr (-> (unsyntax @tech{WorldState}) (unsyntax - @tech{WorldState}))])]{ + ([tick-expr (-> (unsyntax @tech{WorldState}) (unsyntax @tech{WorldState}))])]{ Creates a handler for @racket["left"] and @racket["a"] events.} } @item{ -@defform[(right right-expr) +@defform[(right right-expr) #:contracts - ([tick-expr (-> (unsyntax @tech{WorldState}) (unsyntax - @tech{WorldState}))])]{ + ([tick-expr (-> (unsyntax @tech{WorldState}) (unsyntax @tech{WorldState}))])]{ Creates a handler for @racket["right"] and @racket["d"] events.} } @item{ -@defform[(space space-expr) +@defform[(space space-expr) #:contracts - ([tick-expr (-> (unsyntax @tech{WorldState}) (unsyntax - @tech{WorldState}))])]{ + ([tick-expr (-> (unsyntax @tech{WorldState}) (unsyntax @tech{WorldState}))])]{ Creates a handler for space-bar events (@racket[" "]).} } @item{ -@defform[(shift shift-expr) +@defform[(shift shift-expr) #:contracts - ([tick-expr (-> (unsyntax @tech{WorldState}) (unsyntax - @tech{WorldState}))])]{ + ([tick-expr (-> (unsyntax @tech{WorldState}) (unsyntax @tech{WorldState}))])]{ Creates a handler for @racket["shift"] and @racket["rshift"] events.} } ] If a clause is omitted, @racket[pad-handler] installs a default function - that maps the existing world to itself. + that maps the existing world to itself. Here is a @tech{PadEvent} handler defined with @racket[pad-handler]: @;% @(begin #reader scribble/comment-reader (racketblock -;; ComplexNumber -> ComplexNumber +;; ComplexNumber -> ComplexNumber (define (i-sub1 x) (- x 0+1i)) -;; ComplexNumber -> ComplexNumber +;; ComplexNumber -> ComplexNumber (define (i-add1 x) (+ x 0+1i)) -;; ComplexNumber -> ComplexNumber +;; ComplexNumber -> ComplexNumber ;; deal with all @tech{PadEvent}s -(define handler +(define handler (pad-handler (left sub1) (right add1) (up i-sub1) (down i-add1) (shift (lambda (w) 0)) (space stop-with))) -;; some tests: +;; some tests: (check-expect (handler 9 "left") 8) (check-expect (handler 8 "up") 8-i) )) @@ -586,14 +582,14 @@ All clauses in a @racket[pad-handler] form are optional: } @item{ A @tech{MouseEvent} represents mouse events, e.g., mouse movements - or mouse clicks, by the computer's user. - + or mouse clicks, by the computer's user. + @deftech{MouseEvent} : @racket[(one-of/c "button-down" "button-up" "drag" "move" "enter" "leave")] All @tech{MouseEvent}s are represented via strings: @itemize[ -@item{@racket["button-down"] +@item{@racket["button-down"] signals that the computer user has pushed a mouse button down;} @item{@racket["button-up"] signals that the computer user has let go of a mouse button;} @@ -616,14 +612,14 @@ All @tech{MouseEvent}s are represented via strings: @defform[(on-mouse mouse-expr) #:contracts - ([mouse-expr - (-> (unsyntax @tech{WorldState}) - integer? integer? (unsyntax @tech{MouseEvent}) + ([mouse-expr + (-> (unsyntax @tech{WorldState}) + integer? integer? (unsyntax @tech{MouseEvent}) (unsyntax @tech{WorldState}))])]{ tells DrRacket to call @racket[mouse-expr] on the current world, the current @racket[x] and @racket[y] coordinates of the mouse, and a @tech{MouseEvent} for every (noticeable) action of the mouse by the - computer user. The result of the call becomes the current world. + computer user. The result of the call becomes the current world. For @racket["leave"] and @racket["enter"] events, the coordinates of the mouse click may be outside of the (implicit) rectangle. That is, the @@ -651,14 +647,14 @@ All @tech{MouseEvent}s are represented via strings: down. Specifically, the clock is stopped; no more tick events, @tech{KeyEvent}s, or @tech{MouseEvent}s are forwarded to the respective handlers. The @racket[big-bang] expression returns this - last world. + last world. } @defform/none[#:literals (stop-when) (stop-when last-world? last-picture) #:contracts ([last-world? (-> (unsyntax @tech{WorldState}) boolean?)] - [last-picture (-> (unsyntax @tech{WorldState}) scene?)])]{ + [last-picture (-> (unsyntax @tech{WorldState}) scene?)])]{ @note-scene tells DrRacket to call the @racket[last-world?] function whenever the canvas is drawn. If this call produces @racket[true], the world program is shut @@ -666,7 +662,7 @@ All @tech{MouseEvent}s are represented via strings: rendered with @racket[last-picture]. Specifically, the clock is stopped; no more tick events, @tech{KeyEvent}s, or @tech{MouseEvent}s are forwarded to the respective handlers. The @racket[big-bang] expression returns this - last world. + last world. } } @@ -687,7 +683,7 @@ and @racket[big-bang] will close down all event handling.} ([world-expr? (-> Any boolean?)])]{ tells DrRacket to call the @racket[world-expr?] function on the result of every world handler call. If this call produces @racket[true], the result - is considered a world; otherwise the world program signals an error. + is considered a world; otherwise the world program signals an error. }} @item{ @@ -695,7 +691,7 @@ and @racket[big-bang] will close down all event handling.} @defform[(record? r-expr) #:contracts ([r-expr any/c])]{ - tells DrRacket to enable a visual replay of the interaction, + tells DrRacket to enable a visual replay of the interaction, unless @racket[#f]. The replay action generates one png image per image and an animated gif for the entire sequence in the directory of the user's @@ -709,10 +705,10 @@ and @racket[big-bang] will close down all event handling.} @defform[(state boolean-expr) #:contracts ([boolean-expr boolean?])]{ - tells DrRacket to display a separate window in which the current + tells DrRacket to display a separate window in which the current state is rendered each time it is updated. This is useful for beginners who wish to see how their world evolves---without having to design a - rendering function---plus for the debugging of world programs. + rendering function---plus for the debugging of world programs. }} @item{ @@ -726,11 +722,11 @@ and @racket[big-bang] will close down all event handling.} ] The following example shows that @racket[(run-simulation create-UFO-scene)] is -a short-hand for three lines of code: +a short-hand for three lines of code: @(begin #reader scribble/comment-reader -@racketblock[ +@racketblock[ (define (create-UFO-scene height) (underlay/xy (rectangle 100 100 "solid" "white") 50 height UFO)) @@ -740,18 +736,18 @@ a short-hand for three lines of code: (circle 10 "solid" "green") (rectangle 40 4 "solid" "green"))) -;; (run-simulation create-UFO-scene) is short for: -(big-bang 0 +;; (run-simulation create-UFO-scene) is short for: +(big-bang 0 (on-tick add1) - (to-draw create-UFO-scene)) + (to-draw create-UFO-scene)) ]) Exercise: Add a condition for stopping the flight of the UFO when it -reaches the bottom. +reaches the bottom. @; ----------------------------------------------------------------------------- -@section[#:tag "world-example"]{A First Sample World} +@section[#:tag "world-example"]{A First Sample World} This section uses a simple example to explain the design of worlds. The first subsection introduces the sample domain, a door that closes @@ -770,7 +766,7 @@ Say we wish to design a @tech{world} program that simulates the working of door is closed, you can lock it again. Here is a diagram that translates our words into a graphical - representation: + representation: @image["door-real.png"] @@ -821,7 +817,7 @@ Second, we must translate the actions in our domain---the arrows in the #reader scribble/comment-reader (racketblock ;; tick : WorldState -> WorldState -;; deal with the passing of time +;; deal with the passing of time (define (tick w) ...) ;; click : WorldState @emph{Number} @emph{Number} @tech{MouseEvent} -> WorldState @@ -837,18 +833,18 @@ Second, we must translate the actions in our domain---the arrows in the That is, the contracts of the various handler designations dictate what the contracts of our functions are, once we have defined how to represent the - domain with data in our chosen language. + domain with data in our chosen language. A typical program does not use all three of these functions. Furthermore, the design of these functions provides only the top-level, initial design goal. It often demands the design of many auxiliary functions. The - collection of all these functions is your @tech{world} program. + collection of all these functions is your @tech{world} program. -@centerline{An extended example is available in +@centerline{An extended example is available in @link["http://www.ccs.neu.edu/home/matthias/HtDP2e/"]{How to Design Programs/2e}.} @; ----------------------------------------------------------------------------- -@section[#:tag "world2"]{The World is not Enough} +@section[#:tag "world2"]{The World is not Enough} The library facilities covered so far are about designing individual programs with interactive graphical user interfaces (simulations, @@ -874,7 +870,7 @@ After a world program has become a part of a universe, it may send messages @tech{S-expression}. @deftech{S-expression} An S-expression is roughly a nested list of basic -data; to be precise, an S-expression is one of: +data; to be precise, an S-expression is one of: @itemize[ @item{a string,} @@ -885,7 +881,7 @@ data; to be precise, an S-expression is one of: @item{a list of S-expressions, or} @item{a prefab struct of S-expressions.} ] -Note the @racket[list] clause includes @racket[empty] of course. +Note the @racket[list] clause includes @racket[empty] of course. @defproc[(sexp? [x any/c]) boolean?]{ determines whether @racket[x] is an @tech{S-expression}.} @@ -894,7 +890,7 @@ Note the @racket[list] clause includes @racket[empty] of course. Each world-producing callback in a world program---those for handling clock tick events, keyboard events, and mouse events---may produce a - @tech{Package} in addition to just a @tech{WorldState}. + @tech{Package} in addition to just a @tech{WorldState}. @deftech{Package} represents a pair consisting of a @tech{WorldState} and a message from a @tech{world} program to the @tech{server}. Because @@ -909,13 +905,13 @@ Each world-producing callback in a world program---those for handling clock create a @tech{Package} from a @tech{WorldState} and an @tech{S-expression}.} As mentioned, all event handlers may return @tech{WorldState}s or -@tech{Package}s; here are the revised specifications: +@tech{Package}s; here are the revised specifications: @defform/none[#:literals (on-tick) (on-tick tick-expr) #:contracts ([tick-expr (-> (unsyntax @tech{WorldState}) (or/c (unsyntax @tech{WorldState}) package?))])]{ -} +} @defform/none[#:literals (on-tick) (on-tick tick-expr rate-expr) @@ -929,7 +925,7 @@ As mentioned, all event handlers may return @tech{WorldState}s or #:contracts ([tick-expr (-> (unsyntax @tech{WorldState}) (or/c (unsyntax @tech{WorldState}) package?))] [rate-expr (and/c real? positive?)] - [limit-expr (and/c integer? positive?)])]{ + [limit-expr (and/c integer? positive?)])]{ } @defform/none[#:literals (on-key) @@ -948,7 +944,7 @@ As mentioned, all event handlers may return @tech{WorldState}s or (on-mouse mouse-expr) #:contracts ([mouse-expr - (-> (unsyntax @tech{WorldState}) + (-> (unsyntax @tech{WorldState}) integer? integer? (unsyntax @tech{MouseEvent}) (or/c (unsyntax @tech{WorldState}) package?))])]{ } @@ -963,7 +959,7 @@ If one of these event handlers produces a @tech{Package}, the content of the wor Messages are sent to the universe program, which runs on some computer in the world. The next section is about constructs for creating such a universe server. For now, we just need to know that it exists and that it is the recipient - of messages. + of messages. @deftech{IP} @racket[string?] @@ -971,7 +967,7 @@ Before a world program can send messages, it must register with the server. Registration must specify the internet address of the computer on which the server runs, also known as an @tech{IP} address or a host. Here a @tech{IP} address is a string of the right shape, e.g., @racket["192.168.1.1"] - or @racket["www.google.com"]. + or @racket["www.google.com"]. @defthing[LOCALHOST string?]{the @tech{IP} of your computer. Use it while you are developing a distributed program, especially while you are @@ -981,7 +977,7 @@ Before a world program can send messages, it must register with the A @racket[big-bang] description of a world program that wishes to communicate with other programs must contain a @racket[register] clause of one of the -following shapes: +following shapes: @itemize[ @@ -989,14 +985,14 @@ following shapes: @defform[(register ip-expr) #:contracts ([ip-expr string?])]{ connect this world to a universe server at the specified @racket[ip-expr] address and set up capabilities for sending and receiving messages. - If the world description includes a name specification of the form + If the world description includes a name specification of the form @racket[(name SomeString)] or @racket[(name SomeSymbol)], the name of the - world is sent along to the server. + world is sent along to the server. }} ] When a world program registers with a universe program and the universe program -stops working, the world program stops working, too. +stops working, the world program stops working, too. @subsection{Receiving Messages} @@ -1007,21 +1003,21 @@ Finally, the receipt of a message from the server is an event, just like clause, the message is discarded. The @racket[on-receive] clause of a @racket[big-bang] specifies the event handler - for message receipts. + for message receipts. @defform[(on-receive receive-expr) #:contracts - ([receive-expr (-> (unsyntax @tech{WorldState}) sexp? (or/c (unsyntax @tech{WorldState}) package?))])]{ + ([receive-expr (-> (unsyntax @tech{WorldState}) sexp? (or/c (unsyntax @tech{WorldState}) package?))])]{ tells DrRacket to call @racket[receive-expr] for every message receipt, on the current @tech{WorldState} and the received message. The result of the call becomes the current - @tech{WorldState}. + @tech{WorldState}. Because @racket[receive-expr] is (or evaluates to) a world-transforming function, it too can produce a @tech{Package} instead of just a @tech{WorldState}. If the result is a @tech{Package}, its message content is sent to the @tech{server}.} -The diagram below summarizes the extensions of this section in graphical form. +The diagram below summarizes the extensions of this section in graphical form. @image["universe.png"] @@ -1048,8 +1044,8 @@ A @deftech{server} is the central control program of a @tech{universe} and programs that participate in the @tech{universe}. Like a @tech{world} program, a server is a program that reacts to events, though to different events than @tech{world}s. The two primary kinds of events are the - appearance of a new @tech{world} program in the @tech{universe} - and the receipt of a message from a @tech{world} program. + appearance of a new @tech{world} program in the @tech{universe} + and the receipt of a message from a @tech{world} program. The teachpack provides a mechanism for designating event handlers for servers that is quite similar to the mechanism for describing @tech{world} @@ -1064,7 +1060,7 @@ The teachpack provides a mechanism for designating event handlers for @item{A server may enforce a ``back and forth'' protocol, i.e., it may force two (or more) worlds to engage in a civilized tit-for-tat exchange. Each - world is given a chance to send a message and must then wait + world is given a chance to send a message and must then wait to get a reply before it sends anything again.} @item{A server may play the role of a special-purpose arbiter, e.g., the referee @@ -1075,30 +1071,30 @@ The teachpack provides a mechanism for designating event handlers for As a matter of fact, a pass-through @tech{server} can become basically invisible, making it appear as if all communication goes from peer -@tech{world} to peer in a @tech{universe}. +@tech{world} to peer in a @tech{universe}. This section first introduces some basic forms of data that the @tech{server} uses to represent @tech{world}s and other matters. Second, - it explains how to describe a server program. + it explains how to describe a server program. @; ----------------------------------------------------------------------------- @subsection{Worlds and Messages} Understanding the server's event handling functions demands several data representations: that of (a connection to) a @tech{world} program and that - of a response of a handler to an event. + of a response of a handler to an event. @itemize[ @item{The @tech{server} and its event handlers must agree on a data representation of the @tech{world}s that participate in the - universe. + universe. @defproc[(iworld? [x any/c]) boolean?]{ determines whether @racket[x] is an @emph{iworld}. Because the universe server represents worlds via structures that collect essential information about the connections, the teachpack does not export any constructor or selector - functions on worlds.} + functions on worlds.} @defproc[(iworld=? [u iworld?][v iworld?]) boolean?]{ compares two @emph{iworld}s for equality.} @@ -1111,7 +1107,7 @@ Understanding the server's event handling functions demands several data @defthing[iworld3 iworld?]{and a third one} The three sample iworlds are provided so that you can test your functions -for universe programs. For example: +for universe programs. For example: @racketblock[ (check-expect (iworld=? iworld1 iworld2) false) @@ -1120,8 +1116,8 @@ for universe programs. For example: } @item{Each event handler produces a @emph{bundle}, which is a structure - that contains the @tech{server}'s state, a list of mails to other worlds, - and the list of @emph{iworld}s that are to be disconnected. + that contains the @tech{server}'s state, a list of mails to other worlds, + and the list of @emph{iworld}s that are to be disconnected. @defproc[(bundle? [x any/c]) boolean?]{ determines whether @racket[x] is a @emph{bundle}.} @@ -1165,20 +1161,20 @@ The @tech{server} itself is created with a description that includes the with @tech{universe} events. @defform/subs[#:id universe - #:literals - (on-new on-msg on-tick on-disconnect to-string check-with state) + #:literals + (on-new on-msg on-tick on-disconnect to-string check-with state) (universe state-expr clause ...) ([clause - (on-new new-expr) - (on-msg msg-expr) - (on-tick tick-expr) - (on-tick tick-expr rate-expr) - (on-tick tick-expr rate-expr limit-expr) - (on-disconnect dis-expr) - (state boolean-expr) - (to-string render-expr) - (check-with universe?-expr) - ])]{ + (on-new new-expr) + (on-msg msg-expr) + (on-tick tick-expr) + (on-tick tick-expr rate-expr) + (on-tick tick-expr rate-expr limit-expr) + (on-disconnect dis-expr) + (state boolean-expr) + (to-string render-expr) + (check-with universe?-expr) + ])]{ creates a server with a given state, @racket[state-expr]. The behavior is specified via handler functions through mandatory and optional @@ -1193,10 +1189,10 @@ Evaluating a @racket[universe] expression starts a server. Visually it opens convenience, the console also has two buttons: one for shutting down a universe and another one for re-starting it. The latter functionality is especially useful during the integration of the various pieces of a - distributed program. + distributed program. The mandatory clauses of a @racket[universe] server description are -@racket[on-new] and @racket[on-msg]: +@racket[on-new] and @racket[on-msg]: @itemize[ @@ -1216,17 +1212,17 @@ The mandatory clauses of a @racket[universe] server description are #:contracts ([msg-expr (-> (unsyntax @tech{UniverseState}) iworld? sexp? bundle?)])]{ tells DrRacket to apply @racket[msg-expr] to the current state of the - universe, the world - @racket[w] that sent the message, and the message itself. + universe, the world + @racket[w] that sent the message, and the message itself. } }] All proper event handlers produce a @emph{bundle}. The state in the bundle is safe-guarded by the server until the next event, and the mails are broadcast as specified. The list of iworlds in the third field of the bundle is removed from the list of participants from which to expect - messages. + messages. -The following picture provides a graphical overview of the server's workings. +The following picture provides a graphical overview of the server's workings. @; ----------------------------------------------------------------------------- @;; THE PICTURE IS WRONG @@ -1235,7 +1231,7 @@ The following picture provides a graphical overview of the server's workings. @image["server.png"] In addition to the mandatory handlers, a program may wish to add some -optional handlers: +optional handlers: @itemize[ @@ -1250,7 +1246,7 @@ optional handlers: (on-tick tick-expr rate-expr) #:contracts ([tick-expr (-> (unsyntax @tech{UniverseState}) bundle?)] - [rate-expr (and/c real? positive?)])]{ + [rate-expr (and/c real? positive?)])]{ tells DrRacket to apply @racket[tick-expr] as above; the clock ticks every @racket[rate-expr] seconds.} @@ -1259,7 +1255,7 @@ optional handlers: #:contracts ([tick-expr (-> (unsyntax @tech{UniverseState}) bundle?)] [rate-expr (and/c real? positive?)] - [limit-expr (and/c integer? positive?)])]{ + [limit-expr (and/c integer? positive?)])]{ tells DrRacket to apply @racket[tick-expr] as above; the clock ticks every @racket[rate-expr] seconds. The universe stops when the clock has ticked more than @scheme[limit-expr] times.} @@ -1283,7 +1279,7 @@ optional handlers: #:contracts ([render-expr (-> (unsyntax @tech{UniverseState}) string?)])]{ tells DrRacket to render the state of the universe after each event and to - display this string in the universe console. + display this string in the universe console. } } @@ -1300,9 +1296,9 @@ optional handlers: @defform/none[(state boolean-expr) #:contracts ([boolean-expr boolean?])]{ - tells DrRacket to display a separate window in which the current + tells DrRacket to display a separate window in which the current state is rendered each time it is updated. This is mostly useful for - debugging server programs. + debugging server programs. }} ] @@ -1313,7 +1309,7 @@ In order to explore the workings of a universe, it is necessary to launch a server and several world programs on one and the same computer. We recommend launching one server out of one DrRacket tab and as many worlds as necessary out of a second tab. For the latter, the teachpack provides a - special form. + special form. @defform[(launch-many-worlds expression ...)]{ evaluates all sub-expressions in parallel. Typically each sub-expression @@ -1322,21 +1318,21 @@ In order to explore the workings of a universe, it is necessary to launch a worlds in order.} Once you have designed a world program, add a function definition - concerning @racket[big-bang] to the end of the tab: + concerning @racket[big-bang] to the end of the tab: @(begin #reader scribble/comment-reader (racketblock -;; String -> World +;; String -> World (define (main n) (big-bang ... (name n) ...)) )) Then in DrRacket's Interactions area, use @racket[launch-many-worlds] - to create several distinctively named worlds: + to create several distinctively named worlds: @(begin #reader scribble/comment-reader (racketblock -> (launch-many-worlds (main "matthew") - (main "kathi") +> (launch-many-worlds (main "matthew") + (main "kathi") (main "h3")) 10 25 @@ -1344,10 +1340,10 @@ Once you have designed a world program, add a function definition )) The three worlds can then interact via a server. When all of them have stopped, they produce the final states, here @racket[10], @racket[25], and - @racket[33]. + @racket[33]. For advanced programmers, the library also provides a programmatic -interface for launching many worlds in parallel. +interface for launching many worlds in parallel. @defproc[(launch-many-worlds/proc [thunk-that-runs-a-world (-> any/c)] ...) (values any @#,racketfont{...})]{ @@ -1362,7 +1358,7 @@ in parallel: @(begin #reader scribble/comment-reader (racketblock -> (apply launch-many-worlds/proc +> (apply launch-many-worlds/proc (build-list (random 10) (lambda (i) (lambda () @@ -1383,7 +1379,7 @@ in parallel: @; ----------------------------------------------------------------------------- -@section[#:tag "universe-sample"]{A First Sample Universe} +@section[#:tag "universe-sample"]{A First Sample Universe} This section uses a simple example to explain the design of a universe, especially its server and some participating worlds. The first subsection @@ -1396,16 +1392,16 @@ Say we want to represent a universe that consists of a number of worlds and that gives each world a ``turn'' in a round-robin fashion. If a world is given its turn, it displays a ball that ascends from the bottom of a canvas to the top. It relinquishes its turn at that point and the server - gives the next world a turn. + gives the next world a turn. Here is an image that illustrates how this universe would work if two - worlds participated: + worlds participated: @image["balls" #:suffixes '(".gif" ".png")] The two @tech{world} programs could be located on two distinct computers or on just one. A @tech{server} mediates between the two worlds, including - the initial start-up. + the initial start-up. @; ----------------------------------------------------------------------------- @subsection{Hints on Designing Universes} @@ -1440,14 +1436,14 @@ From the perspective of the @tech{universe}, the design of a protocol is therefore select a subset of suitable @tech{S-expression}s. As for the state of the server and the worlds, they must reflect how they currently relate to the universe. Later, when we design their ``local'' behavior, we - may add more components to their state space. + may add more components to their state space. -In summary, the first step of a protocol design is to introduce: +In summary, the first step of a protocol design is to introduce: @itemize[ @item{a data definition for the information about the universe that the -server tracks, call it @tech{UniverseState};} +server tracks, call it @tech{UniverseState};} @item{a data definition for the world(s) about their current relationship to the universe;} @@ -1460,11 +1456,11 @@ in the most general case you may need one pair per world.} If all the worlds exhibit the same behavior over time, a single data definition suffices for step 2. If they play different roles, we may need -one data definition per world. +one data definition per world. Of course, as you define these collections of data always keep in mind what the pieces of data mean, what they represent from the universe's -perspective. +perspective. The second step of a protocol design is to figure out which major events---the addition of a world to the universe, the arrival of a message @@ -1472,12 +1468,12 @@ The second step of a protocol design is to figure out which major exchange of messages. Conversely, when a server sends a message to a world, this may have implications for both the state of the server and the state of the world. A good tool for writing down these agreements is an - interaction diagram. + interaction diagram. @verbatim{ - - Server World1 World2 + + Server World1 World2 | | | | 'go | | |<------------------| | @@ -1489,13 +1485,13 @@ The second step of a protocol design is to figure out which major Each vertical line is the life line of a @tech{world} program or the @tech{server}. Each horizontal arrow denotes a message sent from one - @tech{universe} participant to another. + @tech{universe} participant to another. The design of the protocol, especially the data definitions, have direct implications for the design of event handling functions. For example, in the server we may wish to deal with two kinds of events: the joining of a new world and the receipt of a message from one of the worlds. This -translates into the design of two functions with the following headers, +translates into the design of two functions with the following headers, @(begin #reader scribble/comment-reader @@ -1503,13 +1499,13 @@ translates into the design of two functions with the following headers, ;; Bundle is ;; (make-bundle UniverseState [Listof mail?] [Listof iworld?]) -;; UniverseState iworld? -> Bundle -;; next list of worlds when world @racket[iw] is joining +;; UniverseState iworld? -> Bundle +;; next list of worlds when world @racket[iw] is joining ;; the universe in state @racket[s] (define (add-world s iw) ...) -;; UniverseState iworld? W2U -> Bundle -;; next list of worlds when world @racket[iw] is sending message @racket[m] to +;; UniverseState iworld? W2U -> Bundle +;; next list of worlds when world @racket[iw] is sending message @racket[m] to ;; the universe in state @racket[s] (define (process s iw m) ...) )) @@ -1518,7 +1514,7 @@ Finally, we must also decide how the messages affect the states of the worlds; which of their callback may send messages and when; and what to do with the messages a world receives. Because this step is difficult to explain in the abstract, we move on to the protocol design for the - universe of ball worlds. + universe of ball worlds. @; ----------------------------------------------------------------------------- @subsection{Designing the Ball Universe} @@ -1526,12 +1522,12 @@ Finally, we must also decide how the messages affect the states of the Running the ball @tech{universe} has a simple overall goal: to ensure that at any point in time, one @tech{world} is active and all others are passive. The active @tech{world} displays a moving ball, and the passive @tech{world}s should display - something, anything that indicates that it is some other @tech{world}'s turn. + something, anything that indicates that it is some other @tech{world}'s turn. As for the server's state, it must obviously keep track of all @tech{world}s that joined the @tech{universe}, and it must know which one is active and which ones are passive. Of course, initially the @tech{universe} is empty, i.e., there are - no @tech{world}s and, at that point, the server has nothing to track. + no @tech{world}s and, at that point, the server has nothing to track. While there are many different useful ways of representing such a @tech{universe}, we just use the list of @emph{iworlds} that is handed to @@ -1539,7 +1535,7 @@ While there are many different useful ways of representing such a @tech{UniverseState} itself is useless for this trivial example. We interpret non-empty lists as those where the first @emph{iworld} is active and the remainder are the passive @emph{iworld}s. As for the two possible - events, + events, @itemize[ @@ -1562,7 +1558,7 @@ The server should send messages to the first @emph{iworld} of its list as @item{A @defterm{StopMessage} is @racket['done].} ] -From the @tech{universe}'s perspective, each @tech{world} is in one of two states: +From the @tech{universe}'s perspective, each @tech{world} is in one of two states: @itemize[ @item{A passive @tech{world} is @emph{resting}. We use @racket['resting] for this state.} @item{An active @tech{world} is not resting. We delay choosing a representation @@ -1570,7 +1566,7 @@ for this part of a @tech{world}'s state until we design its ``local'' behavior.} ] It is also clear that an active @tech{world} may receive additional messages, which it may ignore. When it is done with its turn, it will send a - message. + message. @verbatim{ Server @@ -1578,7 +1574,7 @@ for this part of a @tech{world}'s state until we design its ``local'' behavior.} |<==================| | 'it-is-your-turn | |------------------>| - | | World2 + | | World2 |<==========================================| | 'done | | |<------------------| | @@ -1591,19 +1587,19 @@ for this part of a @tech{world}'s state until we design its ``local'' behavior.} | 'it-is-your-turn | | |------------------>| | | | | - | | | + | | | } Here the double-lines (horizontal) denote the registration step, the others are message exchanges. The diagram thus shows how the @tech{server} decides to make the first registered world the active one and to enlist - all others as they join. + all others as they join. @; ----------------------------------------------------------------------------- @subsection{Designing the Ball Server} -The preceding subsection dictates that our server program starts like this: +The preceding subsection dictates that our server program starts like this: @(begin #reader scribble/comment-reader @@ -1625,17 +1621,17 @@ The preceding subsection dictates that our server program starts like this: @(begin #reader scribble/comment-reader [racketblock -;; Result is +;; Result is ;; (make-bundle [Listof iworld?] ;; (list (make-mail iworld? GoMessage)) ;; '()) -;; [Listof iworld?] iworld? -> Result +;; [Listof iworld?] iworld? -> Result ;; add world @racket[iw] to the universe, when server is in state @racket[u] (define (add-world u iw) ...) ;; [Listof iworld?] iworld? StopMessage -> Result -;; world @racket[iw] sent message @racket[m] when server is in state @racket[u] +;; world @racket[iw] sent message @racket[m] when server is in state @racket[u] (define (switch u iw m) ...) ]) @@ -1645,24 +1641,24 @@ message to exactly one world. Note how these contracts are just refinements of the generic ones. (A type-oriented programmer would say that the contracts here are subtypes of the generic ones.) -The second step of the design recipe calls for functional examples: +The second step of the design recipe calls for functional examples: @(begin #reader scribble/comment-reader [racketblock -;; an obvious example for adding a world: +;; an obvious example for adding a world: (check-expect - (add-world '() world1) + (add-world '() world1) (make-bundle (list world1) (list (make-mail world1 'it-is-your-turn)) - '())) + '())) ;; an example for receiving a message from the active world: (check-expect (switch (list world1 world2) world1 'done) (make-bundle (list world2 world1) (list (make-mail world2 'it-is-your-turn)) - '())) + '())) ]) Note that our protocol analysis dictates this behavior for the two @@ -1671,7 +1667,7 @@ The second step of the design recipe calls for functional examples: worlds. Exercise: Create additional examples for the two functions based on our -protocol. +protocol. The protocol tells us that @emph{add-world} just adds the given @emph{world} structure---recall that this a data representation of the @@ -1685,18 +1681,18 @@ The protocol tells us that @emph{add-world} just adds the given (local ((define univ* (append univ (list wrld)))) (make-bundle univ* (list (make-mail (first univ*) 'it-is-your-turn)) - '()))) + '()))) ]) Because @emph{univ*} contains at least @emph{wrld}, it is acceptable to create a mail to @racket[(first univ*)]. Of course, this same reasoning also implies that if @emph{univ} isn't empty, its first element is an -active world and is about to receive a second @racket['it-is-your-turn] message. +active world and is about to receive a second @racket['it-is-your-turn] message. Similarly, the protocol says that when @emph{switch} is invoked because a @tech{world} program sends a message, the data representation of the corresponding world is moved to the end of the list and the next world on - the (resulting) list is sent a message: + the (resulting) list is sent a message: @(begin #reader scribble/comment-reader @@ -1710,7 +1706,7 @@ Similarly, the protocol says that when @emph{switch} is invoked because a As before, appending the first world to the end of the list guarantees that there is at least this one world on this list. It is therefore - acceptable to create a mail for this world. + acceptable to create a mail for this world. Start the server now. @@ -1725,13 +1721,13 @@ Exercise: The function definition simply assumes that @emph{wrld} is possible that a program registers with a @tech{server} but fails to stick to the agreed-upon protocol. How to deal with such situations properly depends on the context. For now, stop the @tech{universe} at this point by - returning an empty list of worlds. Consider alternative solutions, too.) + returning an empty list of worlds. Consider alternative solutions, too.) -Exercise: An alternative state representation would equate +Exercise: An alternative state representation would equate @tech{UniverseState} with @emph{world} structures, keeping track of the active world. The list of world in the server would track the passive worlds only. Design appropriate @racket[add-world] and @racket[switch] - functions. + functions. @; ----------------------------------------------------------------------------- @subsection{Designing the Ball World} @@ -1742,14 +1738,14 @@ The final step is to design the ball @tech{world}. Recall that each world coordinate; the first kind of @tech{world} displays something that says it's someone else's turn. Assuming the ball always moves along a vertical line and that the vertical line is fixed, the state of the world is an - enumeration of two cases: + enumeration of two cases: @(begin #reader scribble/comment-reader (racketblock ;; teachpack: universe.rkt ;; WorldState is one of: -;; -- Number %% representing the @emph{y} coordinate +;; -- Number %% representing the @emph{y} coordinate ;; -- @racket['resting] (define WORLD0 'resting) @@ -1758,23 +1754,23 @@ The final step is to design the ball @tech{world}. Recall that each world ;; -- WorldState ;; -- (make-package WorldState StopMessage) )) - The definition says that initially a @tech{world} is passive. + The definition says that initially a @tech{world} is passive. The communication protocol and the refined data definition of @tech{WorldState} - imply a number of contract and purpose statements: + imply a number of contract and purpose statements: @(begin #reader scribble/comment-reader (racketblock -;; WorldState GoMessage -> WorldResult -;; make sure the ball is moving +;; WorldState GoMessage -> WorldResult +;; make sure the ball is moving (define (receive w n) ...) ;; WorldState -> WorldResult -;; move this ball upwards for each clock tick +;; move this ball upwards for each clock tick ;; or stay @racket['resting] -(define (move w) ...) +(define (move w) ...) ;; WorldState -> Image ;; render the world as an image @@ -1801,7 +1797,7 @@ Since there are two kinds of states, we make up at least two kinds of second ambiguity shows up when we study additional examples, which are suggested by our approach to designing functions on numeric intervals (HtDP, section 3). That is we should consider the following three inputs - to @emph{receive}: + to @emph{receive}: @itemize[ @item{@racket[HEIGHT] when the ball is at the bottom of the image;} @@ -1813,14 +1809,14 @@ Since there are two kinds of states, we make up at least two kinds of @racket[0], @racket['resting], or @racket[(make-package 'resting 'done)]. The first leaves things alone; the second turns the active @tech{world} into a resting one; the third does so, too, and tells the universe about - this switch. + this switch. We choose to design @emph{receive} so that it ignores the message and returns the current state of an active @tech{world}. This ensures that the ball moves in a continuous fashion and that the @tech{world} remains active. Exercise: One alternative design is to move the ball back to the bottom of -the image every time @racket['it-is-your-turn] is received. Design this function, too. +the image every time @racket['it-is-your-turn] is received. Design this function, too. @(begin #reader scribble/comment-reader @@ -1834,7 +1830,7 @@ the image every time @racket['it-is-your-turn] is received. Design this function Our second function to design is @emph{move}, the function that computes the ball movement. We have the contract and the second step in the design - recipe calls for examples: + recipe calls for examples: @(begin #reader scribble/comment-reader @@ -1857,7 +1853,7 @@ the image every time @racket['it-is-your-turn] is received. Design this function becomes @racket[0]. In the latter case, the result is a package that renders the @tech{world} passive and tells the server about it. - Turning these thoughts into a complete definition is straightforward now: + Turning these thoughts into a complete definition is straightforward now: @(begin #reader scribble/comment-reader @@ -1865,7 +1861,7 @@ the image every time @racket['it-is-your-turn] is received. Design this function (define (move x) (cond [(symbol? x) x] - [(number? x) (if (<= x 0) + [(number? x) (if (<= x 0) (make-package 'resting 'done) (sub1 x))])) )) @@ -1876,24 +1872,24 @@ Exercise: what could happen if we had designed @emph{receive} so that it state change to the tick event handler instead of the message receipt handler? -Finally, here is the third function, which renders the state as an image: +Finally, here is the third function, which renders the state as an image: @(begin #reader scribble/comment-reader (racketblock ; WorldState -> Image -; render the state of the world as an image +; render the state of the world as an image (check-expect (render HEIGHT) (underlay/xy MT 50 HEIGHT BALL)) (check-expect (render 'resting) (underlay/xy MT 10 10 (text "resting" 11 "red"))) (define (render w) - (underlay/xy + (underlay/xy (cond [(symbol? w) (underlay/xy MT 10 10 (text "resting" 11 "red"))] [(number? w) (underlay/xy MT 50 w BALL)]) - 5 85 + 5 85 (text name 11 "black"))) )) @@ -1905,21 +1901,21 @@ Finally, here is the third function, which renders the state as an image: #reader scribble/comment-reader (racketblock ; String -> (WorldState -> Image) -; render the state of the world as an image +; render the state of the world as an image -(check-expect - ((draw "Carl") 100) - (underlay/xy (underlay/xy MT 50 100 BALL) - 5 85 +(check-expect + ((draw "Carl") 100) + (underlay/xy (underlay/xy MT 50 100 BALL) + 5 85 (text "Carl" 11 "black"))) (define (draw name) (lambda (w) - (overlay/xy + (overlay/xy (cond [(symbol? w) (underlay/xy MT 10 10 (text "resting" 11 "red"))] [(number? w) (underlay/xy MT 50 w BALL)]) - 5 85 + 5 85 (text name 11 'black)))) )) @@ -1930,22 +1926,21 @@ Finally, here is the third function, which renders the state as an image: #reader scribble/comment-reader (racketblock -; String -> WorldState +; String -> WorldState ; create and hook up a world with the @racket[LOCALHOST] server (define (create-world n) (big-bang WORLD0 (on-receive receive) - (to-draw (draw n)) - (on-tick move) + (to-draw (draw n)) + (on-tick move) (name n) - (register LOCALHOST))) + (register LOCALHOST))) )) Now you can use @racket[(create-world 'carl)] and @racket[(create-world 'sam)], respectively, to run two different worlds, after launching a @tech{server} - first. + first. Exercise: Design a function that takes care of a world to which the universe has lost its connection. Is @emph{Result} the proper contract for - the result of this function? - + the result of this function? diff --git a/collects/test-engine/test-display.scm b/collects/test-engine/test-display.scm index 89d4dc178b..4ba27e39e1 100644 --- a/collects/test-engine/test-display.scm +++ b/collects/test-engine/test-display.scm @@ -7,9 +7,9 @@ string-constants "test-info.scm" "test-engine.rkt" - "print.ss" - (except-in deinprogramm/signature/signature signature-violation) ; clashes with test-engine - deinprogramm/quickcheck/quickcheck) + "print.ss" + (except-in deinprogramm/signature/signature signature-violation) ; clashes with test-engine + deinprogramm/quickcheck/quickcheck) (define test-display% (class* object% () @@ -40,29 +40,29 @@ (unless drscheme-frame (set! drscheme-frame (send current-rep get-top-level-window))) (let ([curr-win (and current-tab (send current-tab get-test-window))]) - (when curr-win - (let ([content (make-object (editor:standard-style-list-mixin text%))]) - (send content lock #t) - (when curr-win (send curr-win update-editor content)) - (when current-tab (send current-tab current-test-editor content)) - (when (docked?) - (send drscheme-frame display-test-panel content) - (send curr-win show #f))))))) + (when curr-win + (let ([content (make-object (editor:standard-style-list-mixin text%))]) + (send content lock #t) + (when curr-win (send curr-win update-editor content)) + (when current-tab (send current-tab current-test-editor content)) + (when (docked?) + (send drscheme-frame display-test-panel content) + (send curr-win show #f))))))) (define/public (display-success-summary port count) (unless (test-silence) - (display (case count - [(0) (string-constant test-engine-0-tests-passed)] - [(1) (string-constant test-engine-1-test-passed)] - [(2) (string-constant test-engine-both-tests-passed)] - [else (format (string-constant test-engine-all-n-tests-passed) - count)]) - port))) + (display (case count + [(0) (string-constant test-engine-0-tests-passed)] + [(1) (string-constant test-engine-1-test-passed)] + [(2) (string-constant test-engine-both-tests-passed)] + [else (format (string-constant test-engine-all-n-tests-passed) + count)]) + port))) (define/public (display-untested-summary port) (unless (test-silence) (display (string-constant test-engine-should-be-tested) port) - (display "\n" port))) + (display "\n" port))) (define/public (display-disabled-summary port) (display (string-constant test-engine-tests-disabled) port) @@ -100,7 +100,7 @@ [failed-tests (send test-info tests-failed)] [total-checks (send test-info checks-run)] [failed-checks (send test-info checks-failed)] - [violated-signatures (send test-info failed-signatures)] + [violated-signatures (send test-info failed-signatures)] [wishes (send test-info unimplemented-wishes)] [total-wishes (length wishes)] [total-wish-calls (send test-info called-wishes)] @@ -109,20 +109,20 @@ (lambda (total failed zero-message ck?) (send editor insert (cond - [(zero? total) zero-message] - [(= 1 total) - (string-append - (if ck? - (string-constant test-engine-ran-1-check) - (string-constant test-engine-ran-1-test)) - "\n")] - [else - (format (string-append - (if ck? - (string-constant test-engine-ran-n-checks) - (string-constant test-engine-ran-n-tests)) - "\n") - total)])) + [(zero? total) zero-message] + [(= 1 total) + (string-append + (if ck? + (string-constant test-engine-ran-1-check) + (string-constant test-engine-ran-1-test)) + "\n")] + [else + (format (string-append + (if ck? + (string-constant test-engine-ran-n-checks) + (string-constant test-engine-ran-n-tests)) + "\n") + total)])) (send editor insert (cond [(null? wishes) ""] @@ -132,76 +132,76 @@ (when (> total 0) (send editor insert (cond - [(and (zero? failed) (= 1 total)) - (string-append (if ck? - (string-constant test-engine-1-check-passed) - (string-constant test-engine-1-test-passed)) - "\n\n")] - [(zero? failed) - (string-append (if ck? - (string-constant test-engine-all-checks-passed) - (string-constant test-engine-all-tests-passed)) - "\n\n")] - [(= failed total) - (string-append (if ck? - (string-constant test-engine-0-checks-passed) - (string-constant test-engine-0-tests-passed)) - "\n")] - [else (format (string-append - (if ck? - (string-constant test-engine-m-of-n-checks-failed) - (string-constant test-engine-m-of-n-tests-failed)) - "\n\n") - failed total)]))) - (send editor insert - (cond - ((null? violated-signatures) - (string-append (string-constant test-engine-no-signature-violations) "\n\n")) - ((null? (cdr violated-signatures)) - (string-append (string-constant test-engine-1-signature-violation) "\n\n")) - (else - (format (string-append (string-constant test-engine-n-signature-violations) "\n\n") - (length violated-signatures))))) - )] + [(and (zero? failed) (= 1 total)) + (string-append (if ck? + (string-constant test-engine-1-check-passed) + (string-constant test-engine-1-test-passed)) + "\n\n")] + [(zero? failed) + (string-append (if ck? + (string-constant test-engine-all-checks-passed) + (string-constant test-engine-all-tests-passed)) + "\n\n")] + [(= failed total) + (string-append (if ck? + (string-constant test-engine-0-checks-passed) + (string-constant test-engine-0-tests-passed)) + "\n")] + [else (format (string-append + (if ck? + (string-constant test-engine-m-of-n-checks-failed) + (string-constant test-engine-m-of-n-tests-failed)) + "\n\n") + failed total)]))) + (send editor insert + (cond + ((null? violated-signatures) + (string-append (string-constant test-engine-no-signature-violations) "\n\n")) + ((null? (cdr violated-signatures)) + (string-append (string-constant test-engine-1-signature-violation) "\n\n")) + (else + (format (string-append (string-constant test-engine-n-signature-violations) "\n\n") + (length violated-signatures))))) + )] - [check-outcomes/check - (lambda (zero-message) - (check-outcomes total-checks failed-checks - zero-message #t))] - [check-outcomes/test - (lambda (zero-message) - (check-outcomes total-checks failed-checks - zero-message #f))] - [test-outcomes - (lambda (zero-message) - (check-outcomes total-tests failed-tests - zero-message #f))]) + [check-outcomes/check + (lambda (zero-message) + (check-outcomes total-checks failed-checks + zero-message #t))] + [check-outcomes/test + (lambda (zero-message) + (check-outcomes total-checks failed-checks + zero-message #f))] + [test-outcomes + (lambda (zero-message) + (check-outcomes total-tests failed-tests + zero-message #f))]) (case style [(test-require) (test-outcomes - (string-append (string-constant test-engine-must-be-tested) "\n")) + (string-append (string-constant test-engine-must-be-tested) "\n")) (check-outcomes/check - (string-append (string-constant test-engine-is-unchecked) "\n"))] + (string-append (string-constant test-engine-is-unchecked) "\n"))] [(check-require) (check-outcomes/check - (string-append (string-constant test-engine-is-unchecked) "\n"))] + (string-append (string-constant test-engine-is-unchecked) "\n"))] [(test-basic) (test-outcomes "") (check-outcomes/check "")] [(test-check) (check-outcomes/test - (string-append (string-constant test-engine-must-be-tested) - "\n"))] + (string-append (string-constant test-engine-must-be-tested) + "\n"))] [else (check-outcomes/check "")]) (unless (and (zero? total-checks) - (null? violated-signatures)) + (null? violated-signatures)) (inner (begin - (display-check-failures (send test-info failed-checks) - editor test-info src-editor) - (send editor insert "\n") - (display-signature-violations violated-signatures - editor test-info src-editor)) + (display-check-failures (send test-info failed-checks) + editor test-info src-editor) + (send editor insert "\n") + (display-signature-violations violated-signatures + editor test-info src-editor)) insert-test-results editor test-info src-editor)))) (define (format-list l) @@ -211,7 +211,7 @@ (define/public (display-check-failures checks editor test-info src-editor) (when (pair? checks) - (send editor insert (string-append (string-constant test-engine-check-failures) "\n"))) + (send editor insert (string-append (string-constant test-engine-check-failures) "\n"))) (for ([failed-check (reverse checks)]) (send editor insert "\t") (if (failed-check-exn? failed-check) @@ -228,12 +228,12 @@ (define/public (display-signature-violations violations editor test-info src-editor) (when (pair? violations) - (send editor insert (string-append (string-constant test-engine-signature-violations) "\n"))) + (send editor insert (string-append (string-constant test-engine-signature-violations) "\n"))) (for-each (lambda (violation) - (send editor insert "\t") - (make-signature-link editor violation src-editor) - (send editor insert "\n")) - violations)) + (send editor insert "\t") + (make-signature-link editor violation src-editor) + (send editor insert "\n")) + violations)) ;next-line: editor% -> void ;Inserts a newline and a tab into editor @@ -249,53 +249,53 @@ start (send text get-end-position) (lambda (t s e) (highlight-check-error dest src-editor)) #f #f) - (set-clickback-style text start "royalblue")))) + (set-clickback-style text start "royalblue")))) (define (display-reason text fail) #;(write (list 'display-reason fail (check-fail? fail) (message-error? fail)) - (current-error-port)) + (current-error-port)) #;(newline (current-error-port)) - + (let* ((print-string - (lambda (m) - (send text insert m))) - (print-formatted - (lambda (m) - (when (is-a? m snip%) - (send m set-style (send (send text get-style-list) - find-named-style "Standard"))) - (send text insert m))) - (print - (lambda (fstring . vals) - (apply print-with-values fstring print-string print-formatted vals))) - (formatter (check-fail-format fail))) - (cond - [(unexpected-error? fail) - (print (string-constant test-engine-check-encountered-error) - (formatter (unexpected-error-expected fail)) - (unexpected-error-message fail))] - [(unequal? fail) - (print (string-constant test-engine-actual-value-differs-error) - (formatter (unequal-test fail)) - (formatter (unequal-actual fail)))] - [(outofrange? fail) - (print (string-constant test-engine-actual-value-not-within-error) - (formatter (outofrange-test fail)) - (outofrange-range fail) - (formatter (outofrange-actual fail)))] - [(incorrect-error? fail) - (print (string-constant test-engine-encountered-error-error) - (incorrect-error-expected fail) - (incorrect-error-message fail))] - [(expected-error? fail) - (print (string-constant test-engine-expected-error-error) - (formatter (expected-error-value fail)) - (expected-error-message fail))] + (lambda (m) + (send text insert m))) + (print-formatted + (lambda (m) + (when (is-a? m snip%) + (send m set-style (send (send text get-style-list) + find-named-style "Standard"))) + (send text insert m))) + (print + (lambda (fstring . vals) + (apply print-with-values fstring print-string print-formatted vals))) + (formatter (check-fail-format fail))) + (cond + [(unexpected-error? fail) + (print (string-constant test-engine-check-encountered-error) + (formatter (unexpected-error-expected fail)) + (unexpected-error-message fail))] + [(unequal? fail) + (print (string-constant test-engine-actual-value-differs-error) + (formatter (unequal-test fail)) + (formatter (unequal-actual fail)))] + [(outofrange? fail) + (print (string-constant test-engine-actual-value-not-within-error) + (formatter (outofrange-test fail)) + (outofrange-range fail) + (formatter (outofrange-actual fail)))] + [(incorrect-error? fail) + (print (string-constant test-engine-encountered-error-error) + (incorrect-error-expected fail) + (incorrect-error-message fail))] + [(expected-error? fail) + (print (string-constant test-engine-expected-error-error) + (formatter (expected-error-value fail)) + (expected-error-message fail))] [(expected-an-error? fail) - (print (string-constant test-engine-expected-an-error-error) - (formatter (expected-an-error-value fail)))] - [(message-error? fail) - (for-each print-formatted (message-error-strings fail))] + (print (string-constant test-engine-expected-an-error-error) + (formatter (expected-an-error-value fail)))] + [(message-error? fail) + (for-each print-formatted (message-error-strings fail))] [(not-mem? fail) (print (string-constant test-engine-not-mem-error) (formatter (not-mem-test fail))) @@ -310,20 +310,20 @@ (print "Test relies on a call to wished for function ~F that has not been implemented, with arguments ~F." (symbol->string (unimplemented-wish-name fail)) (formatter (unimplemented-wish-args fail)))] - [(property-fail? fail) - (print-string (string-constant test-engine-property-fail-error)) - (for-each (lambda (arguments) - (for-each (lambda (p) - (if (car p) - (print " ~a = ~F" (car p) (formatter (cdr p))) - (print "~F" (formatter (cdr p))))) - arguments)) - (result-arguments-list (property-fail-result fail)))] - [(property-error? fail) - (print (string-constant test-engine-property-error-error) - (property-error-message fail))] + [(property-fail? fail) + (print-string (string-constant test-engine-property-fail-error)) + (for-each (lambda (arguments) + (for-each (lambda (p) + (if (car p) + (print " ~a = ~F" (car p) (formatter (cdr p))) + (print "~F" (formatter (cdr p))))) + arguments)) + (result-arguments-list (property-fail-result fail)))] + [(property-error? fail) + (print (string-constant test-engine-property-error-error) + (property-error-message fail))] ) - (print-string "\n"))) + (print-string "\n"))) ;; make-error-link: text% check-fail exn src editor -> void (define (make-error-link text reason exn dest src-editor) @@ -331,13 +331,13 @@ ;; the following code never worked #;(let ((start (send text get-end-position))) (send text insert (string-constant test-engine-trace-error)) - (send text insert " ") + (send text insert " ") (when (and src-editor current-rep) (send text set-clickback start (send text get-end-position) (lambda (t s e) ((error-handler) exn)) #f #f) - (set-clickback-style text start "red")))) + (set-clickback-style text start "red")))) (define (insert-messages text msgs) (for ([m msgs]) @@ -348,67 +348,67 @@ (define (make-signature-link text violation src-editor) (let* ((signature (signature-violation-signature violation)) - (stx (signature-syntax signature)) - (srcloc (signature-violation-srcloc violation)) - (message (signature-violation-message violation))) - (cond - ((string? message) - (send text insert message)) - ((signature-got? message) - (insert-messages text (list (string-constant test-engine-got) - " " - ((signature-got-format message) - (signature-got-value message)))))) - (when srcloc - (send text insert " ") - (let ((source (srcloc-source srcloc)) - (line (srcloc-line srcloc)) - (column (srcloc-column srcloc)) - (pos (srcloc-position srcloc)) - (span (srcloc-span srcloc)) - (start (send text get-end-position))) - (send text insert (format-position source line column)) - (send text set-clickback - start (send text get-end-position) - (lambda (t s e) - (highlight-error source line column pos span src-editor)) - #f #f) - (set-clickback-style text start "blue"))) - (send text insert ", ") - (send text insert (string-constant test-engine-signature)) - (send text insert " ") - (format-clickable-syntax-src text stx src-editor) - (cond - ((signature-violation-blame violation) - => (lambda (blame) - (next-line text) - (send text insert (string-constant test-engine-to-blame)) - (send text insert " ") - (format-clickable-syntax-src text blame src-editor)))))) + (stx (signature-syntax signature)) + (srcloc (signature-violation-srcloc violation)) + (message (signature-violation-message violation))) + (cond + ((string? message) + (send text insert message)) + ((signature-got? message) + (insert-messages text (list (string-constant test-engine-got) + " " + ((signature-got-format message) + (signature-got-value message)))))) + (when srcloc + (send text insert " ") + (let ((source (srcloc-source srcloc)) + (line (srcloc-line srcloc)) + (column (srcloc-column srcloc)) + (pos (srcloc-position srcloc)) + (span (srcloc-span srcloc)) + (start (send text get-end-position))) + (send text insert (format-position source line column)) + (send text set-clickback + start (send text get-end-position) + (lambda (t s e) + (highlight-error source line column pos span src-editor)) + #f #f) + (set-clickback-style text start "blue"))) + (send text insert ", ") + (send text insert (string-constant test-engine-signature)) + (send text insert " ") + (format-clickable-syntax-src text stx src-editor) + (cond + ((signature-violation-blame violation) + => (lambda (blame) + (next-line text) + (send text insert (string-constant test-engine-to-blame)) + (send text insert " ") + (format-clickable-syntax-src text blame src-editor)))))) (define (format-clickable-syntax-src text stx src-editor) (let ((start (send text get-end-position))) - (send text insert (format-syntax-src stx)) - (send text set-clickback - start (send text get-end-position) - (lambda (t s e) - (highlight-error/syntax stx src-editor)) - #f #f) - (set-clickback-style text start "blue"))) + (send text insert (format-syntax-src stx)) + (send text set-clickback + start (send text get-end-position) + (lambda (t s e) + (highlight-error/syntax stx src-editor)) + #f #f) + (set-clickback-style text start "blue"))) (define (set-clickback-style text start color) (let ([end (send text get-end-position)] - [c (new style-delta%)]) - (send text insert " ") - (send text change-style - (make-object style-delta% 'change-underline #t) - start end #f) - (send c set-delta-foreground color) - (send text change-style c start end #f))) + [c (new style-delta%)]) + (send text insert " ") + (send text change-style + (make-object style-delta% 'change-underline #t) + start end #f) + (send c set-delta-foreground color) + (send text change-style c start end #f))) (define (format-syntax-src stx) - (format-position (syntax-source stx) - (syntax-line stx) (syntax-column stx))) + (format-position (syntax-source stx) + (syntax-line stx) (syntax-column stx))) ;format-src: src -> string (define (format-src src) @@ -416,45 +416,45 @@ (define (format-position file line column) (let ([line (cond [line => number->string] - [else - (string-constant test-engine-unknown)])] - [col - (cond [column => number->string] - [else (string-constant test-engine-unknown)])]) - - (if (path? file) - (let-values (((base name must-be-dir?) - (split-path file))) - (if (path? name) - (format (string-constant test-engine-in-at-line-column) - (path->string name) line col) - (format (string-constant test-engine-at-line-column) - line col))) - (format (string-constant test-engine-at-line-column) - line col)))) + [else + (string-constant test-engine-unknown)])] + [col + (cond [column => number->string] + [else (string-constant test-engine-unknown)])]) + + (if (path? file) + (let-values (((base name must-be-dir?) + (split-path file))) + (if (path? name) + (format (string-constant test-engine-in-at-line-column) + (path->string name) line col) + (format (string-constant test-engine-at-line-column) + line col))) + (format (string-constant test-engine-at-line-column) + line col)))) (define (highlight-error source line column position span src-editor) (when (and current-rep src-editor) - (cond - [(is-a? src-editor text:basic<%>) - (let ((highlight - (lambda () - (let ((error-src (if (send src-editor port-name-matches? source) ; definitions or REPL? - src-editor - current-rep))) - (send current-rep highlight-errors - (list (make-srcloc error-src - line - column - position span)) #f) - (let ([frame (send current-tab get-frame)]) - (unless (send current-tab is-current-tab?) - (let loop ([tabs (send frame get-tabs)] [i 0]) - (unless (null? tabs) - (if (eq? (car tabs) current-tab) - (send frame change-to-nth-tab i) - (loop (cdr tabs) (add1 i)))))) - (send frame show #t)))))) + (cond + [(is-a? src-editor text:basic<%>) + (let ((highlight + (lambda () + (let ((error-src (if (send src-editor port-name-matches? source) ; definitions or REPL? + src-editor + current-rep))) + (send current-rep highlight-errors + (list (make-srcloc error-src + line + column + position span)) #f) + (let ([frame (send current-tab get-frame)]) + (unless (send current-tab is-current-tab?) + (let loop ([tabs (send frame get-tabs)] [i 0]) + (unless (null? tabs) + (if (eq? (car tabs) current-tab) + (send frame change-to-nth-tab i) + (loop (cdr tabs) (add1 i)))))) + (send frame show #t)))))) (queue-callback highlight))]))) (define (highlight-check-error srcloc src-editor) @@ -462,14 +462,14 @@ [src-span (lambda (l) (car (cddddr l)))] [position (src-pos srcloc)] [span (src-span srcloc)]) - (highlight-error (car srcloc) (cadr srcloc) (caddr srcloc) - position span - src-editor))) + (highlight-error (car srcloc) (cadr srcloc) (caddr srcloc) + position span + src-editor))) (define (highlight-error/syntax stx src-editor) (highlight-error (syntax-source stx) (syntax-line stx) (syntax-column stx) - (syntax-position stx) (syntax-span stx) - src-editor)) + (syntax-position stx) (syntax-span stx) + src-editor)) (super-instantiate ()))) diff --git a/collects/tests/deinprogramm/image.rkt b/collects/tests/deinprogramm/image.rkt index 6b4be587ee..e52b91f3c5 100644 --- a/collects/tests/deinprogramm/image.rkt +++ b/collects/tests/deinprogramm/image.rkt @@ -3,13 +3,13 @@ (provide all-image-tests) (require rackunit - deinprogramm/image + deinprogramm/image (only-in lang/private/imageeq image=?) - (except-in mred make-color make-pen) - mzlib/class - mrlib/cache-image-snip - lang/posn - htdp/error) + (except-in mred make-color make-pen) + mzlib/class + mrlib/cache-image-snip + lang/posn + htdp/error) (define-values (image-snip1 image-snip2) @@ -140,10 +140,10 @@ (define (add-line i x1 y1 x2 y2 color) (overlay i - (line (image-width i) - (image-height i) - x1 y1 x2 y2 color) - "left" "top")) + (line (image-width i) + (image-height i) + x1 y1 x2 y2 color) + "left" "top")) (define (not-image-inside? i1 i2) (not (image-inside? i1 i2))) @@ -155,19 +155,19 @@ (define (tp-exn-pred name position) (lambda (exn) (and (exn:fail:contract? exn) - (let* ([msg (exn-message exn)] - [beg (format "~a:" name)] - [len (string-length beg)]) - (and (regexp-match position msg) - ((string-length msg) . > . len) - (string=? (substring msg 0 len) beg)))))) + (let* ([msg (exn-message exn)] + [beg (format "~a:" name)] + [len (string-length beg)]) + (and (regexp-match position msg) + ((string-length msg) . > . len) + (string=? (substring msg 0 len) beg)))))) (define-syntax err/rt-name-test (syntax-rules () [(_ (name . args) position) (check-exn (tp-exn-pred 'name position) - (lambda () - (name . args)))])) + (lambda () + (name . args)))])) (define all-image-tests (test-suite @@ -184,87 +184,87 @@ (test-case "color-list" (check-equal? (list red) - (image->color-list (rectangle 1 1 'solid 'red))) + (image->color-list (rectangle 1 1 'solid 'red))) (check-equal? (list blue blue blue blue) - (image->color-list (rectangle 2 2 'solid 'blue)))) + (image->color-list (rectangle 2 2 'solid 'blue)))) (test-case "colors-set-up-properly" (check-equal? (list (list red) (list blue) (list black) (list white)) - (list (image->color-list (rectangle 1 1 'solid 'red)) - (image->color-list (rectangle 1 1 'solid 'blue)) - (image->color-list (rectangle 1 1 'solid 'black)) - (image->color-list (rectangle 1 1 'solid 'white))))) + (list (image->color-list (rectangle 1 1 'solid 'red)) + (image->color-list (rectangle 1 1 'solid 'blue)) + (image->color-list (rectangle 1 1 'solid 'black)) + (image->color-list (rectangle 1 1 'solid 'white))))) (test-case "color-list2" (check-equal? (list blue blue blue - blue blue blue - blue blue blue) - (image->color-list (rectangle 3 3 'solid 'blue))) + blue blue blue + blue blue blue) + (image->color-list (rectangle 3 3 'solid 'blue))) (check-equal? (list blue blue blue - blue blue blue - blue blue blue) - (image->color-list (rectangle 3 3 "solid" 'blue))) + blue blue blue + blue blue blue) + (image->color-list (rectangle 3 3 "solid" 'blue))) (check-equal? (list blue blue blue - blue white blue - blue blue blue) - (image->color-list (rectangle 3 3 'outline 'blue)))) + blue white blue + blue blue blue) + (image->color-list (rectangle 3 3 'outline 'blue)))) (test-case "color-list3" (check-equal? (list blue blue blue - blue white blue - blue blue blue) - (image->color-list (rectangle 3 3 "outline" 'blue)))) + blue white blue + blue blue blue) + (image->color-list (rectangle 3 3 "outline" 'blue)))) (test-case "color-list4" (check-image=? (color-list->image (list blue blue blue blue) 2 2) - (rectangle 2 2 'solid 'blue))) + (rectangle 2 2 'solid 'blue))) (test-case "color-list5" (check-not-image=? (color-list->image (list blue blue blue blue) 2 2) - (rectangle 1 4 'solid 'blue))) + (rectangle 1 4 'solid 'blue))) (test-case "color-list6" (check-image=? (color-list->image (list blue blue blue blue) 1 4) - (rectangle 1 4 'solid 'blue))) + (rectangle 1 4 'solid 'blue))) (test-case "color-list7" (check-image=? (color-list->image (list 'blue 'blue 'blue 'blue) 2 2) - (rectangle 2 2 'solid 'blue))) + (rectangle 2 2 'solid 'blue))) (test-case "color-list8" (check-equal? 10 - (image-width (color-list->image '() 10 0)))) + (image-width (color-list->image '() 10 0)))) (test-case "color-list9" (check-equal? 0 - (image-height (color-list->image '() 10 0)))) + (image-height (color-list->image '() 10 0)))) (test-case "color-list10" (check-equal? 0 - (image-width (color-list->image '() 0 10)))) + (image-width (color-list->image '() 0 10)))) (test-case "color-list11" (check-equal? 10 - (image-height (color-list->image '() 0 10)))) + (image-height (color-list->image '() 0 10)))) (test-case "alpha-color-list1" (check-equal? (make-alpha-color 0 255 0 0) - (car (image->alpha-color-list (rectangle 1 1 'solid 'red))))) + (car (image->alpha-color-list (rectangle 1 1 'solid 'red))))) (test-case "alpha-color-list2" (check-equal? (make-alpha-color 0 255 0 0) - (car (image->alpha-color-list (rectangle 1 1 "solid" 'red))))) + (car (image->alpha-color-list (rectangle 1 1 "solid" 'red))))) (test-case "alpha-color-list3" @@ -283,7 +283,7 @@ (test-case "alpha-color-list5" (check-equal? (make-alpha-color 0 0 255 0) - (car (image->alpha-color-list (rectangle 1 1 'solid 'green))))) + (car (image->alpha-color-list (rectangle 1 1 'solid 'green))))) (test-case "alpha-color-list6" @@ -293,45 +293,45 @@ (test-case "alpha-color-list7" (check-equal? (image-width - (alpha-color-list->image - (list ared aclr ared - aclr aclr aclr) - 3 - 2)) - 3)) + (alpha-color-list->image + (list ared aclr ared + aclr aclr aclr) + 3 + 2)) + 3)) (test-case "alpha-color-list8" (check-equal? (image-height - (alpha-color-list->image - (list ared aclr ared - aclr aclr aclr) - 3 - 2)) - 2)) + (alpha-color-list->image + (list ared aclr ared + aclr aclr aclr) + 3 + 2)) + 2)) (test-case "alpha-color-list9" (check-equal? (image->color-list - (alpha-color-list->image - (list ared aclr ared - aclr aclr aclr) - 3 2)) - (list red white red - white white white))) + (alpha-color-list->image + (list ared aclr ared + aclr aclr aclr) + 3 2)) + (list red white red + white white white))) (test-case "alpha-color-list10" (check-equal? (image->color-list - (overlay - (rectangle 3 3 'solid 'blue) - (alpha-color-list->image - (list ared aclr ared - aclr aclr aclr - ared aclr ared) - 3 3) - "left" "top")) - (list red blue red - blue blue blue - red blue red))) + (overlay + (rectangle 3 3 'solid 'blue) + (alpha-color-list->image + (list ared aclr ared + aclr aclr aclr + ared aclr ared) + 3 3) + "left" "top")) + (list red blue red + blue blue blue + red blue red))) (test-case "alpha-color-list11" @@ -352,227 +352,227 @@ (test-case "image=?1" (check-image=? (alpha-color-list->image (list (make-alpha-color 200 100 150 175)) 1 1) - (alpha-color-list->image (list (make-alpha-color 200 100 150 175)) 1 1))) + (alpha-color-list->image (list (make-alpha-color 200 100 150 175)) 1 1))) (test-case "image=?2" (check-image=? (alpha-color-list->image (list (make-alpha-color 255 100 100 100)) 1 1) - (alpha-color-list->image (list (make-alpha-color 255 200 200 200)) 1 1))) + (alpha-color-list->image (list (make-alpha-color 255 200 200 200)) 1 1))) (test-case "image=?3" (check-not-image=? (alpha-color-list->image (list (make-alpha-color 200 100 100 100)) 1 1) - (alpha-color-list->image (list (make-alpha-color 200 200 200 200)) 1 1))) + (alpha-color-list->image (list (make-alpha-color 200 200 200 200)) 1 1))) (test-case "image=?4" (check-not-image=? (alpha-color-list->image (list (make-alpha-color 200 100 150 175) - (make-alpha-color 200 100 150 175)) - 1 - 2) - (alpha-color-list->image (list (make-alpha-color 200 100 150 175) - (make-alpha-color 200 100 150 175)) - 2 - 1))) + (make-alpha-color 200 100 150 175)) + 1 + 2) + (alpha-color-list->image (list (make-alpha-color 200 100 150 175) + (make-alpha-color 200 100 150 175)) + 2 + 1))) ;; This one is broken because of a fundamental problem with the ;; image primitives. #;(test-case "image=?5" (check-not-image=? (rectangle 4 4 'outline 'black) - (overlay - (rectangle 4 4 'outline 'black) - (circle 1 'solid 'red) - 0 0))) + (overlay + (rectangle 4 4 'outline 'black) + (circle 1 'solid 'red) + 0 0))) (test-case "overlay" (check-image=? (color-list->image (list blue red blue red) 2 2) - (overlay (rectangle 2 2 'solid 'red) - (rectangle 1 2 'solid 'blue) - "left" "top"))) + (overlay (rectangle 2 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + "left" "top"))) (test-case "overlay/multiple" (check-image=? (overlay (rectangle 6 6 'solid 'red) - (overlay (rectangle 4 4 'solid 'white) - (rectangle 2 2 'solid 'blue) - "center" "center") - "center" "center") - (overlay (overlay (rectangle 6 6 'solid 'red) - (rectangle 4 4 'solid 'white) - "center" "center") - (rectangle 2 2 'solid 'blue) - "center" "center"))) + (overlay (rectangle 4 4 'solid 'white) + (rectangle 2 2 'solid 'blue) + "center" "center") + "center" "center") + (overlay (overlay (rectangle 6 6 'solid 'red) + (rectangle 4 4 'solid 'white) + "center" "center") + (rectangle 2 2 'solid 'blue) + "center" "center"))) (test-case "overlay/empty-spaces-are-unmasked" (check-image=? (color-list->image (list red red red blue) 2 2) - (overlay - (rectangle 2 2 'solid 'blue) - (overlay (rectangle 1 2 'solid 'red) - (rectangle 2 1 'solid 'red) - "left" "top") - "left" "top"))) + (overlay + (rectangle 2 2 'solid 'blue) + (overlay (rectangle 1 2 'solid 'red) + (rectangle 2 1 'solid 'red) + "left" "top") + "left" "top"))) (test-case "overlay/xy1" (check-image=? (color-list->image (list red blue red blue) 2 2) - (overlay (rectangle 2 2 'solid 'red) + (overlay (rectangle 2 2 'solid 'red) (rectangle 1 2 'solid 'blue) - 1 0))) + 1 0))) (test-case "overlay/xy2" (check-image=? (color-list->image (list red red red blue) 2 2) - (overlay (rectangle 2 2 'solid 'red) + (overlay (rectangle 2 2 'solid 'red) (rectangle 1 1 'solid 'blue) - 1 1))) + 1 1))) (test-case "overlay/xy3" (check-image=? (color-list->image (list red red blue blue) 2 2) - (overlay (rectangle 2 1 'solid 'red) + (overlay (rectangle 2 1 'solid 'red) (rectangle 2 1 'solid 'blue) 0 1))) (test-case "overlay/xy/white" (check-image=? (alpha-color-list->image (list ablack ablack ablack - ablack awhite ablack - ablack ablack ablack) - 3 3) - (overlay (rectangle 3 3 'solid 'black) - (rectangle 1 1 'solid 'white) - 1 1))) + ablack awhite ablack + ablack ablack ablack) + 3 3) + (overlay (rectangle 3 3 'solid 'black) + (rectangle 1 1 'solid 'white) + 1 1))) (test-case "color-list->image/white-in-mask" (check-image=? (color-list->image (list black red black - red red red - black red black) - 3 3) - (overlay (rectangle 3 3 'solid 'red) - (color-list->image (list black white black - white white white - black white black) - 3 3) - "left" "top"))) + red red red + black red black) + 3 3) + (overlay (rectangle 3 3 'solid 'red) + (color-list->image (list black white black + white white white + black white black) + 3 3) + "left" "top"))) (test-case "overlay" (check-image=? (color-list->image (list red blue red red blue red) 3 2) (overlay (rectangle 3 2 'solid 'red) - (rectangle 1 2 'solid 'blue) - 1 0))) + (rectangle 1 2 'solid 'blue) + 1 0))) (test-case "image=?-zero1" (check-image=? (rectangle 0 10 'solid 'red) - (rectangle 0 10 'solid 'red))) + (rectangle 0 10 'solid 'red))) (test-case "image=?-zero2" (check-image=? (rectangle 0 10 'solid 'red) - (rectangle 0 10 'solid 'blue))) + (rectangle 0 10 'solid 'blue))) (test-case "image=?-zero3" (check-not-image=? (rectangle 0 5 'solid 'red) - (rectangle 0 4'solid 'blue))) + (rectangle 0 4'solid 'blue))) (test-case "image-inside?1" (check image-inside? - (overlay (rectangle 3 2 'solid 'red) - (rectangle 1 2 'solid 'blue) - 1 0) - (rectangle 1 2 'solid 'blue))) + (overlay (rectangle 3 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + 1 0) + (rectangle 1 2 'solid 'blue))) (test-case "image-inside?2" (check not-image-inside? - (overlay (rectangle 3 2 'solid 'red) - (rectangle 1 2 'solid 'blue) - 1 0) - (rectangle 1 2 'solid 'black))) + (overlay (rectangle 3 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + 1 0) + (rectangle 1 2 'solid 'black))) (test-case "image-inside?3" (check image-inside? - (overlay (rectangle 3 2 'solid 'red) - (rectangle 1 2 'solid 'blue) - 1 0) - (rectangle 1 2 'solid 'red))) + (overlay (rectangle 3 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + 1 0) + (rectangle 1 2 'solid 'red))) (test-case "image-inside?4" (check not-image-inside? - (overlay (rectangle 3 2 'solid 'red) - (rectangle 1 2 'solid 'blue) - 1 0) - (rectangle 2 1 'solid 'red))) + (overlay (rectangle 3 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + 1 0) + (rectangle 2 1 'solid 'red))) (test-case "image-inside?5" (check image-inside? - (alpha-color-list->image (list (make-alpha-color 0 255 0 0)) 1 1) - (alpha-color-list->image (list (make-alpha-color 255 0 0 0)) 1 1))) + (alpha-color-list->image (list (make-alpha-color 0 255 0 0)) 1 1) + (alpha-color-list->image (list (make-alpha-color 255 0 0 0)) 1 1))) (test-case "image-inside?6" (check not-image-inside? - (overlay (rectangle 3 2 'solid 'red) - (rectangle 1 2 'solid 'blue) - 1 0) - (color-list->image (list blue white white) - 3 1))) + (overlay (rectangle 3 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + 1 0) + (color-list->image (list blue white white) + 3 1))) (test-case "image-inside?7" (check image-inside? - (overlay (rectangle 16 16 'solid 'red) - (ellipse 6 6 'outline 'blue) - 2 5) - (ellipse 6 6 'outline 'blue))) + (overlay (rectangle 16 16 'solid 'red) + (ellipse 6 6 'outline 'blue) + 2 5) + (ellipse 6 6 'outline 'blue))) (test-case "image-inside?8" (check image-inside? - (overlay (rectangle (image-width (text "x" 12 'red)) - (image-height (text "x" 12 'red)) - 'solid - 'white) - (text "x" 12 'red) - "center" "center") - (text "x" 12 'red))) + (overlay (rectangle (image-width (text "x" 12 'red)) + (image-height (text "x" 12 'red)) + 'solid + 'white) + (text "x" 12 'red) + "center" "center") + (text "x" 12 'red))) (test-case "image-inside?9" (check image-inside? - (text "y x y" 12 'red) - (text "x" 12 'red))) + (text "y x y" 12 'red) + (text "x" 12 'red))) (test-case "find-image1" (check-equal? (make-posn 2 5) - (find-image (overlay (rectangle 16 16 'solid 'red) - (ellipse 6 6 'outline 'blue) - 2 5) - (ellipse 6 6 'outline 'blue)))) + (find-image (overlay (rectangle 16 16 'solid 'red) + (ellipse 6 6 'outline 'blue) + 2 5) + (ellipse 6 6 'outline 'blue)))) (test-case "find-image2" (check-equal? (make-posn 0 0) - (find-image (rectangle 16 16 'solid 'blue) - (ellipse 6 6 'outline 'blue)))) + (find-image (rectangle 16 16 'solid 'blue) + (ellipse 6 6 'outline 'blue)))) (test-case "find-image3" (check-equal? (make-posn 1 1) - (find-image (overlay (rectangle 10 10 'solid 'blue) - (ellipse 5 5 'solid 'red) - 1 1) - (ellipse 5 5 'solid 'red)))) + (find-image (overlay (rectangle 10 10 'solid 'blue) + (ellipse 5 5 'solid 'red) + 1 1) + (ellipse 5 5 'solid 'red)))) (test-case "image-width" @@ -629,19 +629,19 @@ (test-case "line" (check image=? - (line 5 1 0 0 4 0 'red) - (color-list->image (list red red red red red) 5 1)) + (line 5 1 0 0 4 0 'red) + (color-list->image (list red red red red red) 5 1)) (check image=? - (line 1 5 0 0 0 4 'red) - (color-list->image (list red red red red red) 1 5)) + (line 1 5 0 0 0 4 'red) + (color-list->image (list red red red red red) 1 5)) (check image=? - (line 1 5 0 4 0 0 'red) - (color-list->image (list red red red red red) 1 5)) + (line 1 5 0 4 0 0 'red) + (color-list->image (list red red red red red) 1 5)) (check image=? - (line 5 1 4 0 0 0 'red) - (color-list->image (list red red red red red) 5 1))) + (line 5 1 4 0 0 0 'red) + (color-list->image (list red red red red red) 5 1))) ; note: next two tests may be platform-specific... I'm not sure. @@ -649,41 +649,41 @@ (test-case "triangle1" (check image=? - (triangle 3 'outline 'red) - (color-list->image - (list white red white - white red white - red white red - red red red) - 3 - 4))) + (triangle 3 'outline 'red) + (color-list->image + (list white red white + white red white + red white red + red red red) + 3 + 4))) (test-case "triangle2" (check image=? - (triangle 3 'solid 'red) - (color-list->image - (list white red white - white red white - red red red - red red red) - 3 - 4))) + (triangle 3 'solid 'red) + (color-list->image + (list white red white + white red white + red red red + red red red) + 3 + 4))) (test-case "clipping-twice-clips-both-times" (check image=? - (overlay - (rectangle 11 11 'solid 'green) - (clip (rectangle 11 11 'solid 'red) - 5 5 1 1) - "center" "center") - (overlay - (rectangle 11 11 'solid 'green) - (clip (clip (rectangle 11 11 'solid 'red) - 3 3 2 2) - 2 2 1 1) - "center" "center"))) + (overlay + (rectangle 11 11 'solid 'green) + (clip (rectangle 11 11 'solid 'red) + 5 5 1 1) + "center" "center") + (overlay + (rectangle 11 11 'solid 'green) + (clip (clip (rectangle 11 11 'solid 'red) + 3 3 2 2) + 2 2 1 1) + "center" "center"))) (test-case "solid-rect" @@ -752,21 +752,21 @@ (test-case "overlay1" (check-on-bitmap (overlay (rectangle 1 4 'solid 'blue) - (rectangle 4 1 'solid 'green) - "left" "top"))) + (rectangle 4 1 'solid 'green) + "left" "top"))) (test-case "overlay2" (check-on-bitmap (overlay (rectangle 4 4 'solid 'blue) - (rectangle 4 4 'solid 'green) - 2 2))) + (rectangle 4 4 'solid 'green) + 2 2))) (test-case "overlay3" (check-on-bitmap (overlay image-snip1 - (rectangle (image-width image-snip1) - (image-height image-snip1) - 'outline - 'red) - "center" "center"))) + (rectangle (image-width image-snip1) + (image-height image-snip1) + 'outline + 'red) + "center" "center"))) (test-case "alpha-color-list" (check-on-bitmap @@ -774,8 +774,8 @@ (rectangle 3 3 'solid 'blue) (alpha-color-list->image (list ared aclr ared - aclr aclr aclr - ared aclr ared) + aclr aclr aclr + ared aclr ared) 3 3) "center" "center"))) @@ -791,68 +791,68 @@ "add-line1" (check-on-bitmap (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") - -20 -20 - 0 0 - 'red))) + -20 -20 + 0 0 + 'red))) (test-case "add-line2" (check-on-bitmap (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") - -20 20 - 0 0 - 'red))) + -20 20 + 0 0 + 'red))) (test-case "add-line3" (check-on-bitmap (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") - 20 -20 - 0 0 - 'red))) + 20 -20 + 0 0 + 'red))) (test-case "add-line4" (check-on-bitmap (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") - 20 20 - 0 0 - 'red))) + 20 20 + 0 0 + 'red))) (test-case "add-line5" (check-on-bitmap (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") - 0 0 - -20 -20 - 'red))) + 0 0 + -20 -20 + 'red))) (test-case "add-line6" (check-on-bitmap (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") - 0 0 - -20 20 - 'red))) + 0 0 + -20 20 + 'red))) (test-case "add-line7" (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") - 0 0 - 20 -20 - 'red)) + 0 0 + 20 -20 + 'red)) (test-case "add-line8" (check-on-bitmap (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") - 0 0 - 20 20 - 'red))) + 0 0 + 20 20 + 'red))) (test-case "shrink" (check-on-bitmap (clip (rectangle 11 11 'solid 'red) - 5 5 1 1))) + 5 5 1 1))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -888,26 +888,26 @@ (test-case "accept-non-integer" (check-equal? (image->color-list (rectangle 2 2 'solid 'blue)) - (image->color-list (rectangle #e2.5 2.5 'solid 'blue))) + (image->color-list (rectangle #e2.5 2.5 'solid 'blue))) (check-equal? (image->color-list (ellipse 2 2 'solid 'blue)) - (image->color-list (ellipse #e2.5 2.5 'solid 'blue))) + (image->color-list (ellipse #e2.5 2.5 'solid 'blue))) (check-equal? (image->color-list (circle 2 'solid 'blue)) - (image->color-list (circle #e2.5 'solid 'blue))) + (image->color-list (circle #e2.5 'solid 'blue))) (check-equal? (image->color-list (triangle 12 'solid 'blue)) - (image->color-list (triangle 12.5 'solid 'blue))) + (image->color-list (triangle 12.5 'solid 'blue))) (check-equal? (image->color-list (line 10 12 0 0 9 11 'blue)) - (image->color-list (line 10 12 0 0 9.5 #e11.5 'blue))) + (image->color-list (line 10 12 0 0 9.5 #e11.5 'blue))) (check-equal? (image->color-list (clip (rectangle 10 10 'solid 'blue) 3 3 4 4)) - (image->color-list - (clip (rectangle 10 10 'solid 'blue) - 3.1 - 3.2 - #e4.3 - 4.4))) + (image->color-list + (clip (rectangle 10 10 'solid 'blue) + 3.1 + 3.2 + #e4.3 + 4.4))) (check-equal? (image->color-list (add-line (rectangle 10 10 'solid 'blue) - 0 0 2 2 'red)) - (image->color-list (add-line (rectangle 10 10 'solid 'blue) - 0.1 #e.2 2.1 2.2 'red)))) + 0 0 2 2 'red)) + (image->color-list (add-line (rectangle 10 10 'solid 'blue) + 0.1 #e.2 2.1 2.2 'red)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -931,18 +931,18 @@ (check image=? image-snip1 (overlay image-snip1 image-snip2 "center" "center")) (check image=? image-snip1 (overlay image-snip1 image-snip2 "left" "top")) (check image=? - (add-line image-snip1 0 0 10 10 'green) - (add-line image-snip2 0 0 10 10 'green)) + (add-line image-snip1 0 0 10 10 'green) + (add-line image-snip2 0 0 10 10 'green)) (check image-inside? image-snip1 image-snip2) (check image-inside? image-snip2 image-snip1) (check-equal? (make-posn 0 0) - (find-image image-snip1 image-snip2)) + (find-image image-snip1 image-snip2)) (check-equal? (make-posn 0 0) - (find-image image-snip2 image-snip1)) + (find-image image-snip2 image-snip1)) (check-equal? (image->color-list image-snip1) - (image->color-list image-snip2)) + (image->color-list image-snip2)) (check-equal? (image->alpha-color-list image-snip1) - (image->alpha-color-list image-snip2))) + (image->alpha-color-list image-snip2))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -953,7 +953,7 @@ (test-case "image-snip-no-bitmap" (check-equal? 20 - (image-width image-snip3)) + (image-width image-snip3)) (overlay image-snip3 image-snip3 10 10)) diff --git a/collects/tests/eopl/chapter3/lexaddr-lang/environments.rkt b/collects/tests/eopl/chapter3/lexaddr-lang/environments.rkt index b3f4dc03ab..0f858c70ac 100755 --- a/collects/tests/eopl/chapter3/lexaddr-lang/environments.rkt +++ b/collects/tests/eopl/chapter3/lexaddr-lang/environments.rkt @@ -15,9 +15,9 @@ (define init-nameless-env (lambda () (extend-nameless-env - (num-val 1) ; was i + (num-val 1) ; was i (extend-nameless-env - (num-val 5) ; was v + (num-val 5) ; was v (extend-nameless-env - (num-val 10) ; was x + (num-val 10) ; was x (empty-nameless-env)))))) diff --git a/collects/tests/eopl/chapter9/classes/tests.rkt b/collects/tests/eopl/chapter9/classes/tests.rkt index dc7509b029..5b35b42260 100755 --- a/collects/tests/eopl/chapter9/classes/tests.rkt +++ b/collects/tests/eopl/chapter9/classes/tests.rkt @@ -583,7 +583,7 @@ class c2 extends c1 let o1 = new c1() o2 = new c2() -in list(send o1 m1(), % returns 1 +in list(send o1 m1(), % returns 1 send o1 m2(), % returns 100 send o1 m3(), % returns 100 send o2 m1(), % returns 1 (from c1) diff --git a/collects/tests/gracket/mem.rkt b/collects/tests/gracket/mem.rkt index 296104d90b..ba7d340762 100644 --- a/collects/tests/gracket/mem.rkt +++ b/collects/tests/gracket/mem.rkt @@ -21,8 +21,8 @@ (define allocated '()) (define (remember tag v) (set! allocated - (cons (cons tag (make-weak-box v)) - allocated)) + (cons (cons tag (make-weak-box v)) + allocated)) v) (define sub-collect-frame @@ -71,163 +71,163 @@ (unless (zero? n) (let ([tag (cons id n)]) (let* ([edit (remember tag (make-object text%))] - [ef (let ([f (make-object frame% "Editor Frame")]) - (send (make-object editor-canvas% f) set-editor edit) - (remember tag f))] - [c (make-custodian)] - [es (parameterize ([current-custodian c]) - (make-eventspace))]) + [ef (let ([f (make-object frame% "Editor Frame")]) + (send (make-object editor-canvas% f) set-editor edit) + (remember tag f))] + [c (make-custodian)] + [es (parameterize ([current-custodian c]) + (make-eventspace))]) - (when edit? - (send ef show #t) - (sleep 0.1)) + (when edit? + (send ef show #t) + (sleep 0.1)) - (parameterize ([current-eventspace es]) - (send (remember - tag - (make-object - (class timer% + (parameterize ([current-eventspace es]) + (send (remember + tag + (make-object + (class timer% (init-rest args) - (override* [notify (lambda () (void))]) + (override* [notify (lambda () (void))]) (apply super-make-object args)))) - start 100)) + start 100)) - (when frame? - (let* ([f (remember tag - (make-object (if (even? n) - frame% - dialog%) - "Tester" #f 200 200))] - [cb (lambda (x y) f)] - [p (remember tag (make-object (get-pane% n) f))]) - (remember tag (make-object canvas% f)) - (when (zero? (modulo n 3)) - (thread (lambda () (send f show #t))) - (let loop () (sleep) (unless (send f is-shown?) (loop)))) - (remember tag (make-object button% "one" p cb)) - (let ([class check-box%]) - (let loop ([m 10]) - (unless (zero? m) - (remember (cons tag m) - (make-object class "another" p cb)) - (loop (sub1 m))))) - (remember tag (make-object check-box% "check" p cb)) - (remember tag (make-object choice% "choice" '("a" "b" "c") p cb)) - (remember tag (make-object list-box% "list" '("apple" "banana" "coconut") - p cb)) - (remember tag (make-object button% "two" p cb)) - (send f show #f))) + (when frame? + (let* ([f (remember tag + (make-object (if (even? n) + frame% + dialog%) + "Tester" #f 200 200))] + [cb (lambda (x y) f)] + [p (remember tag (make-object (get-pane% n) f))]) + (remember tag (make-object canvas% f)) + (when (zero? (modulo n 3)) + (thread (lambda () (send f show #t))) + (let loop () (sleep) (unless (send f is-shown?) (loop)))) + (remember tag (make-object button% "one" p cb)) + (let ([class check-box%]) + (let loop ([m 10]) + (unless (zero? m) + (remember (cons tag m) + (make-object class "another" p cb)) + (loop (sub1 m))))) + (remember tag (make-object check-box% "check" p cb)) + (remember tag (make-object choice% "choice" '("a" "b" "c") p cb)) + (remember tag (make-object list-box% "list" '("apple" "banana" "coconut") + p cb)) + (remember tag (make-object button% "two" p cb)) + (send f show #f))) - (when subwindows? - (let ([p (make-object (get-panel% n) sub-collect-frame)] - [cv (make-object canvas% sub-collect-frame)] - [add-objects - (lambda (p tag hide?) - (let ([b (let* ([x #f] - [bcb (lambda (a b) x)]) - (set! x (make-object button% "one" p bcb)) - x)] - [c (make-object check-box% "check" p void)] - [co (make-object choice% "choice" '("a" "b" "c") p void)] - [cv (make-object canvas% p)] - [lb (make-object list-box% "list" '("apple" "banana" "coconut") p void)]) - (when hide? - (send p delete-child b) - (send p delete-child c) - (send p delete-child cv) - (send p delete-child co) - (send p delete-child lb)) - (remember tag b) - (remember tag c) - (remember tag cv) - (remember tag co) - (remember tag lb)))]) - (add-objects sub-collect-panel (cons 'sc1 tag) #t) - (add-objects p (cons 'sc2 tag) #f) - (remember (cons 'sc0 tag) p) - (remember (cons 'sc0 tag) cv) - (send sub-collect-frame delete-child p) - (send sub-collect-frame delete-child cv))) + (when subwindows? + (let ([p (make-object (get-panel% n) sub-collect-frame)] + [cv (make-object canvas% sub-collect-frame)] + [add-objects + (lambda (p tag hide?) + (let ([b (let* ([x #f] + [bcb (lambda (a b) x)]) + (set! x (make-object button% "one" p bcb)) + x)] + [c (make-object check-box% "check" p void)] + [co (make-object choice% "choice" '("a" "b" "c") p void)] + [cv (make-object canvas% p)] + [lb (make-object list-box% "list" '("apple" "banana" "coconut") p void)]) + (when hide? + (send p delete-child b) + (send p delete-child c) + (send p delete-child cv) + (send p delete-child co) + (send p delete-child lb)) + (remember tag b) + (remember tag c) + (remember tag cv) + (remember tag co) + (remember tag lb)))]) + (add-objects sub-collect-panel (cons 'sc1 tag) #t) + (add-objects p (cons 'sc2 tag) #f) + (remember (cons 'sc0 tag) p) + (remember (cons 'sc0 tag) cv) + (send sub-collect-frame delete-child p) + (send sub-collect-frame delete-child cv))) - (when (and edit? insert?) - (let ([e edit]) + (when (and edit? insert?) + (let ([e edit]) (send e begin-edit-sequence) - (when load-file? - (send e load-file (build-path source-dir "mem.rkt"))) - (let loop ([i 20]) - (send e insert (number->string i)) - (unless (zero? i) - (loop (sub1 i)))) - (let ([s (make-object editor-snip%)]) - (send (send s get-editor) insert "Hello!") - (send e insert s)) - (send e insert #\newline) - (send e insert "done") - (send e set-modified #f) + (when load-file? + (send e load-file (build-path source-dir "mem.rkt"))) + (let loop ([i 20]) + (send e insert (number->string i)) + (unless (zero? i) + (loop (sub1 i)))) + (let ([s (make-object editor-snip%)]) + (send (send s get-editor) insert "Hello!") + (send e insert s)) + (send e insert #\newline) + (send e insert "done") + (send e set-modified #f) (send e end-edit-sequence))) - - (when menus? - (let ([f (remember tag (make-object frame% "MB Frame 0"))]) - (remember tag (make-object menu% "TM1" (remember (cons 'q tag) (make-object menu-bar% f))))) - (let* ([mb (remember tag (make-object menu-bar% ef))] - [m (remember tag (make-object menu% "Ok" mb))]) - (remember tag (make-object menu-item% "Hi" m void)) - (remember tag (make-object menu-item% "There" m void #\t)) - (remember tag - (make-object checkable-menu-item% - "Checkable" - (remember tag (make-object menu% "Hello" m)) - void)) - (let ([i (remember tag (make-object menu-item% "Delete Me" m void))]) - (send i delete))) + + (when menus? + (let ([f (remember tag (make-object frame% "MB Frame 0"))]) + (remember tag (make-object menu% "TM1" (remember (cons 'q tag) (make-object menu-bar% f))))) + (let* ([mb (remember tag (make-object menu-bar% ef))] + [m (remember tag (make-object menu% "Ok" mb))]) + (remember tag (make-object menu-item% "Hi" m void)) + (remember tag (make-object menu-item% "There" m void #\t)) + (remember tag + (make-object checkable-menu-item% + "Checkable" + (remember tag (make-object menu% "Hello" m)) + void)) + (let ([i (remember tag (make-object menu-item% "Delete Me" m void))]) + (send i delete))) - (when subwindows? - (unless permanent-ready? - (semaphore-wait mb-lock) - (unless (send sub-collect-frame get-menu-bar) - (let ([mb (make-object menu-bar% sub-collect-frame)]) - (make-object menu% "Permanent" mb))) - (set! permanent-ready? #t) - (semaphore-post mb-lock)) - (let* ([mb (send sub-collect-frame get-menu-bar)] - [mm (car (send mb get-items))]) - (send (remember (cons 'm tag) (make-object menu-item% "Delete Me" mm void)) delete) - (let ([m (remember tag (make-object menu% "Temporary" mb))]) - (remember (cons 't tag) (make-object menu-item% "Temp Hi" m void)) - (send m delete))))) - - (when atomic? - (let loop ([m 8]) - (unless (zero? m) - (remember (cons tag m) (make-object point% n m)) - (let ([br (make-object brush%)]) - (remember (cons tag m) br) - (hash-set! htw br 'ok)) - (remember (cons tag m) (make-object pen%)) - (loop (sub1 m))))) - - (when offscreen? - (let ([m (remember tag (make-object bitmap-dc%))] - [b0 (remember (cons tag 'f) (make-object bitmap% (get-image n)))] - [b (remember (cons tag 'u) (make-object bitmap% 100 100))] - [b2 (remember (cons tag 'x) (make-object bitmap% 100 100))]) - (unless (send b0 ok?) - (error "bitmap load error")) - (send m set-bitmap b))) - - (when edit? - (send ef show #f)) - - (custodian-shutdown-all c) + (when subwindows? + (unless permanent-ready? + (semaphore-wait mb-lock) + (unless (send sub-collect-frame get-menu-bar) + (let ([mb (make-object menu-bar% sub-collect-frame)]) + (make-object menu% "Permanent" mb))) + (set! permanent-ready? #t) + (semaphore-post mb-lock)) + (let* ([mb (send sub-collect-frame get-menu-bar)] + [mm (car (send mb get-items))]) + (send (remember (cons 'm tag) (make-object menu-item% "Delete Me" mm void)) delete) + (let ([m (remember tag (make-object menu% "Temporary" mb))]) + (remember (cons 't tag) (make-object menu-item% "Temp Hi" m void)) + (send m delete))))) - (collect-garbage) + (when atomic? + (let loop ([m 8]) + (unless (zero? m) + (remember (cons tag m) (make-object point% n m)) + (let ([br (make-object brush%)]) + (remember (cons tag m) br) + (hash-set! htw br 'ok)) + (remember (cons tag m) (make-object pen%)) + (loop (sub1 m))))) + + (when offscreen? + (let ([m (remember tag (make-object bitmap-dc%))] + [b0 (remember (cons tag 'f) (make-object bitmap% (get-image n)))] + [b (remember (cons tag 'u) (make-object bitmap% 100 100))] + [b2 (remember (cons tag 'x) (make-object bitmap% 100 100))]) + (unless (send b0 ok?) + (error "bitmap load error")) + (send m set-bitmap b))) + + (when edit? + (send ef show #f)) + + (custodian-shutdown-all c) - (maker id (sub1 n)))))) + (collect-garbage) + + (maker id (sub1 n)))))) (define (still) (map (lambda (x) - (let ([v (weak-box-value (cdr x))]) - (when v + (let ([v (weak-box-value (cdr x))]) + (when v (printf "~s ~s\n" (car x) v)))) allocated) (void)) @@ -241,29 +241,29 @@ (define (breakable t) (if #f (thread (lambda () - (read) - (printf "breaking\n") - (break-thread t) - (thread-wait t) - (printf "done\n"))) + (read) + (printf "breaking\n") + (break-thread t) + (thread-wait t) + (printf "done\n"))) (void))) (define (do-test) (let ([sema (make-semaphore)]) (let loop ([n num-threads]) (unless (zero? n) - (breakable - (thread (lambda () - (stw (current-thread) n) - (dynamic-wind - void - (lambda () (maker n num-times)) - (lambda () (semaphore-post sema)))))) - (loop (sub1 n)))) + (breakable + (thread (lambda () + (stw (current-thread) n) + (dynamic-wind + void + (lambda () (maker n num-times)) + (lambda () (semaphore-post sema)))))) + (loop (sub1 n)))) (let loop ([n num-threads]) (unless (zero? n) - (yield sema) - (loop (sub1 n))))) + (yield sema) + (loop (sub1 n))))) (collect-garbage) (collect-garbage) @@ -280,4 +280,3 @@ (still))) (do-test) - diff --git a/collects/tests/r6rs/test.sls b/collects/tests/r6rs/test.sls index 19dae25955..fc1fb1a7c0 100644 --- a/collects/tests/r6rs/test.sls +++ b/collects/tests/r6rs/test.sls @@ -69,10 +69,10 @@ ((not (number? y)) #f) ((or (not (real? x)) (not (real? y))) - (and (good-enough? (real-part x) (real-part y)) - (good-enough? (imag-part x) (imag-part y)))) + (and (good-enough? (real-part x) (real-part y)) + (good-enough? (imag-part x) (imag-part y)))) ((infinite? x) - (= x (* 2.0 y))) + (= x (* 2.0 y))) ((infinite? y) (= (* 2.0 x) y)) ((nan? y) diff --git a/collects/tests/racket/basic.rktl b/collects/tests/racket/basic.rktl index 1f166d3dd0..93cdde8215 100644 --- a/collects/tests/racket/basic.rktl +++ b/collects/tests/racket/basic.rktl @@ -1417,18 +1417,18 @@ (test-values '(1 2) (lambda () (andmap (lambda (x) (values 1 2)) '(1)))) (test -3 call-with-current-continuation - (lambda (exit) - (for-each (lambda (x) (if (negative? x) (exit x) (void))) - '(54 0 37 -3 245 19)) - #t)) + (lambda (exit) + (for-each (lambda (x) (if (negative? x) (exit x) (void))) + '(54 0 37 -3 245 19)) + #t)) (define list-length (lambda (obj) (call-with-current-continuation (lambda (return) (letrec ((r (lambda (obj) (cond ((null? obj) 0) - ((pair? obj) (+ (r (cdr obj)) 1)) - (else (return #f)))))) - (r obj)))))) + ((pair? obj) (+ (r (cdr obj)) 1)) + (else (return #f)))))) + (r obj)))))) (test 4 list-length '(1 2 3 4)) (test #f list-length '(a b . c)) (test '() map cadr '()) diff --git a/collects/tests/racket/benchmarks/shootout/nsievebits.rkt b/collects/tests/racket/benchmarks/shootout/nsievebits.rkt index ab145a7cc0..6980d1c851 100644 --- a/collects/tests/racket/benchmarks/shootout/nsievebits.rkt +++ b/collects/tests/racket/benchmarks/shootout/nsievebits.rkt @@ -37,7 +37,7 @@ (let ((a (make-bit-vector m))) (define (clear i) (do ([j (+ i i) (+ j i)]) - ((>= j m)) + ((>= j m)) (bit-vector-set! a j #f))) (let ([c 0]) (do ([i 2 (add1 i)]) diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index b07f2353f7..42415d762c 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -11999,7 +11999,7 @@ so that propagation occurs. (test-name '(->* (integer?) #:pre ... integer?) (->* (integer?) () #:pre (= 1 2) integer?)) (test-name '(->* (integer?) integer? #:post ...) - (->* (integer?) () integer? #:post #f)) + (->* (integer?) () integer? #:post #f)) (test-name '(->* (integer?) #:pre ... integer? #:post ...) (->* (integer?) () #:pre (= 1 2) integer? #:post #f)) diff --git a/collects/tests/racket/control.rktl b/collects/tests/racket/control.rktl index 480a5130f1..a0618595f4 100644 --- a/collects/tests/racket/control.rktl +++ b/collects/tests/racket/control.rktl @@ -19,17 +19,17 @@ (test expect 'expr expr)])) ;----------------------------------------------------------------------- -; Shift tests +; Shift tests (ctest (+ 10 (reset (+ 2 (shift k (+ 100 (k (k 3))))))) 117) (ctest (* 10 (reset (* 2 (shift g (reset - (* 5 (shift f (+ (f 1) 1)))))))) + (* 5 (shift f (+ (f 1) 1)))))))) 60) (ctest (let ((f (lambda (x) (shift k (k (k x)))))) - (+ 1 (reset (+ 10 (f 100))))) + (+ 1 (reset (+ 10 (f 100))))) 121) (ctest (reset @@ -44,10 +44,10 @@ (define traverse (lambda (xs) (letrec ((visit - (lambda (xs) - (if (null? xs) - '() - (visit (shift k + (lambda (xs) + (if (null? xs) + '() + (visit (shift k (cons (car xs) (k (cdr xs))))))))) (reset @@ -57,7 +57,7 @@ '(1 2 3 4 5)) ;----------------------------------------------------------------------- -; Control tests +; Control tests ; Example from Sitaram, Felleisen (define (abort v) (control k v)) @@ -71,10 +71,10 @@ (define traverse (lambda (xs) (letrec ((visit - (lambda (xs) - (if (null? xs) - '() - (visit (control k + (lambda (xs) + (if (null? xs) + '() + (visit (control k (cons (car xs) (k (cdr xs))))))))) (prompt @@ -103,7 +103,7 @@ #t) ;------------------------------------------------------------------------ -; shift0/control0 tests +; shift0/control0 tests (ctest (+ 10 (prompt0 (+ 2 (control k (+ 100 (k (k 3))))))) 117) diff --git a/collects/tests/racket/param.rktl b/collects/tests/racket/param.rktl index 6a0a72a20b..4c62b3b553 100644 --- a/collects/tests/racket/param.rktl +++ b/collects/tests/racket/param.rktl @@ -348,7 +348,7 @@ '(load "tmp5") exn:fail? (list "bad setting" zero-arg-proc one-arg-proc)) - (list current-eval + (list current-eval (list (current-eval) erroring-eval) '(begin (set! erroring-set? #t) diff --git a/collects/tests/racket/struct.rktl b/collects/tests/racket/struct.rktl index 7de5306977..641d766ce5 100644 --- a/collects/tests/racket/struct.rktl +++ b/collects/tests/racket/struct.rktl @@ -613,7 +613,7 @@ x12 'one12 x13 'one13 x33 'base3 - x132 'two132)) + x132 'two132)) (letrec ([bundle (lambda (l f) diff --git a/collects/tests/srfi/13/string-test.rkt b/collects/tests/srfi/13/string-test.rkt index 8273d0fa54..7ef72cd4d8 100644 --- a/collects/tests/srfi/13/string-test.rkt +++ b/collects/tests/srfi/13/string-test.rkt @@ -30,43 +30,43 @@ (require rackunit) (require srfi/13/string srfi/14/char-set - ) + ) (provide string-tests) (define-syntax-rule (expect a e) (check-equal? a e)) (define string-tests (let ((abc null) - (cba null) - (test-string "This is a simple test string to generate a very simple char set!") - ) - + (cba null) + (test-string "This is a simple test string to generate a very simple char set!") + ) + (test-suite "String tests" (test-case "string? test 1" - (check-true (string? test-string))) + (check-true (string? test-string))) (test-case "string? test 2" - (check-true (not (string? 'hello)))) - + (check-true (not (string? 'hello)))) + (test-case "string-null? test 1" - (check-true (string-null? ""))) - + (check-true (string-null? ""))) + (test-case "string-null? test 2" - (check-true (not (string-null? "not empty")))) + (check-true (not (string-null? "not empty")))) (test-case "string-every test 1 (all #\a)" - (check-true (string-every #\a "aaaaaaaa"))) + (check-true (string-every #\a "aaaaaaaa"))) (test-case "string-every test 2 (charset a b c)" - (check-true (string-every - (char-set #\a #\b #\c) - "baacaaaabbaa"))) + (check-true (string-every + (char-set #\a #\b #\c) + "baacaaaabbaa"))) (test-case "string-every test 3 (pred vowel?)" - (check-true (string-every vowel? "aeiou"))) + (check-true (string-every vowel? "aeiou"))) - + ;; string-every char/char-set/pred s [start end] -> value ;; string-any char/char-set/pred s [start end] -> value @@ -95,7 +95,7 @@ (expect (string-concatenate-reverse '() sample 0) "") (expect (string-concatenate-reverse '() sample (string-length sample)) sample) - (check-not-eq? sample ; the result must be a fresh string + (check-not-eq? sample ; the result must be a fresh string (string-concatenate-reverse '() sample (string-length sample))) (expect (string-concatenate-reverse (list sample) "" 0) sample) (check-not-eq? sample @@ -112,7 +112,7 @@ (let ((sample "0123456789+")) (expect (string-concatenate-reverse/shared '()) "") (expect (string-concatenate-reverse/shared (list sample)) sample) - (check-eq? sample ; Return the original string + (check-eq? sample ; Return the original string (string-concatenate-reverse/shared (list sample))) (expect (string-concatenate-reverse/shared (list sample "")) sample) (expect (string-concatenate-reverse/shared (list "" sample)) sample) @@ -280,7 +280,7 @@ (define vowel? (lambda (v) (and (char? v) - (or (char=? v #\a) (char=? v #\e) (char=? v #\i) (char=? v #\o) (char=? v #\u))))) + (or (char=? v #\a) (char=? v #\e) (char=? v #\i) (char=? v #\o) (char=? v #\u))))) ;; Build a string out of components diff --git a/collects/tests/srfi/2/and-let-test.rkt b/collects/tests/srfi/2/and-let-test.rkt index 430925bbde..e5826cfa91 100644 --- a/collects/tests/srfi/2/and-let-test.rkt +++ b/collects/tests/srfi/2/and-let-test.rkt @@ -34,161 +34,158 @@ (test-suite "and-let* tests" (test-case "empty body 1" - ;; check-true, check-eqv?, etc. - (check-eqv? (and-let* () ) #t)) + ;; check-true, check-eqv?, etc. + (check-eqv? (and-let* () ) #t)) (test-case "empty claws 1" - (check-eqv? (and-let* () 1) 1)) + (check-eqv? (and-let* () 1) 1)) (test-case "empty claws 2" - (check-eqv? (and-let* () 1 2) 2)) + (check-eqv? (and-let* () 1 2) 2)) (test-case "singleton claw 1" - (check-eqv? (let ((x #f)) - (and-let* (x))) - #f)) + (check-eqv? (let ((x #f)) + (and-let* (x))) + #f)) (test-case "singleton claw 2" - (check-eqv? (let ((x 1)) - (and-let* (x))) - 1)) + (check-eqv? (let ((x 1)) + (and-let* (x))) + 1)) (test-case "let-like assignment 1" - (check-eqv? (and-let* ((x #f))) #f)) + (check-eqv? (and-let* ((x #f))) #f)) (test-case "let-like assignment 2" - (check-eqv? (and-let* ((x 1))) 1)) + (check-eqv? (and-let* ((x 1))) 1)) ;;(test-case "gotta break 1" - ;; (check-true (and-let* (#f (x 1))))) + ;; (check-true (and-let* (#f (x 1))))) (test-case "mixed claws 1" - (check-eqv? (and-let* ((#f) (x 1))) #f)) + (check-eqv? (and-let* ((#f) (x 1))) #f)) ;; (test-case "gotta break 2" - ;; (check-true (and-let* (2 (x 1))))) + ;; (check-true (and-let* (2 (x 1))))) (test-case "mixed claws 2" - (check-eqv? (and-let* ((2) (x 1))) 1)) + (check-eqv? (and-let* ((2) (x 1))) 1)) (test-case "mixed claws 3" - (check-eqv? (and-let* ((x 1) (2))) 2)) + (check-eqv? (and-let* ((x 1) (2))) 2)) (test-case "simple claw 1" - (check-eqv? - (let ((x #f)) - (and-let* (x) x)) - #f)) + (check-eqv? + (let ((x #f)) + (and-let* (x) x)) + #f)) (test-case "simple claw 2" - (check-equal? - (let ((x "")) - (and-let* (x) x)) - "")) + (check-equal? + (let ((x "")) + (and-let* (x) x)) + "")) (test-case "simple claw 3" - (check-equal? - (let ((x "")) - (and-let* (x))) - "")) + (check-equal? + (let ((x "")) + (and-let* (x))) + "")) (test-case "simple claw 4" - (check-eqv? - (let ((x 1)) - (and-let* (x) (+ x 1))) - 2)) + (check-eqv? + (let ((x 1)) + (and-let* (x) (+ x 1))) + 2)) (test-case "simple claw 5" - (check-eqv? - (let ((x #f)) - (and-let* (x) (+ x 1))) - #f)) + (check-eqv? + (let ((x #f)) + (and-let* (x) (+ x 1))) + #f)) (test-case "simple claw 6" - (check-eqv? - (let ((x 1)) - (and-let* (((positive? x))) (+ x 1))) - 2)) + (check-eqv? + (let ((x 1)) + (and-let* (((positive? x))) (+ x 1))) + 2)) (test-case "simple claw 7" - (check-eqv? - (let ((x 1)) - (and-let* (((positive? x))))) - #t)) + (check-eqv? + (let ((x 1)) + (and-let* (((positive? x))))) + #t)) (test-case "simple claw 8" - (check-eqv? - (let ((x 0)) - (and-let* (((positive? x))) (+ x 1))) - #f)) + (check-eqv? + (let ((x 0)) + (and-let* (((positive? x))) (+ x 1))) + #f)) (test-case "simple claw 9" - (check-eqv? - (let ((x 1)) - (and-let* (((positive? x)) (x (+ x 1))) (+ x 1))) - 3)) + (check-eqv? + (let ((x 1)) + (and-let* (((positive? x)) (x (+ x 1))) (+ x 1))) + 3)) ;; (test-case "gotta break 3" - ;; (check-true (and-let* (((positive? x)) (x (+ x 1)) (x (+ x 1))) (+ x 1)))) + ;; (check-true (and-let* (((positive? x)) (x (+ x 1)) (x (+ x 1))) (+ x 1)))) (test-case "complex claw 1" - (check-eqv? - (let ((x 1)) - (and-let* (x ((positive? x))) (+ x 1))) - 2)) + (check-eqv? + (let ((x 1)) + (and-let* (x ((positive? x))) (+ x 1))) + 2)) (test-case "complex claw 2" - (check-eqv? - (let ((x 1)) - (and-let* (((begin x)) ((positive? x))) (+ x 1))) - 2)) + (check-eqv? + (let ((x 1)) + (and-let* (((begin x)) ((positive? x))) (+ x 1))) + 2)) (test-case "complex claw 3" - (check-eqv? - (let ((x 0)) - (and-let* (x ((positive? x))) (+ x 1))) - #f)) + (check-eqv? + (let ((x 0)) + (and-let* (x ((positive? x))) (+ x 1))) + #f)) (test-case "complex claw 4" - (check-eqv? - (let ((x #f)) - (and-let* (x ((positive? x))) (+ x 1))) - #f)) + (check-eqv? + (let ((x #f)) + (and-let* (x ((positive? x))) (+ x 1))) + #f)) (test-case "complex claw 5" - (check-eqv? - (let ((x #f)) - (and-let* (((begin x)) ((positive? x))) (+ x 1))) - #f)) + (check-eqv? + (let ((x #f)) + (and-let* (((begin x)) ((positive? x))) (+ x 1))) + #f)) (test-case "funky claw 1" - (check-eqv? - (let ((x 1)) - (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) - #f)) + (check-eqv? + (let ((x 1)) + (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) + #f)) (test-case "funky claw 2" - (check-eqv? - (let ((x 0)) - (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) - #f)) + (check-eqv? + (let ((x 0)) + (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) + #f)) (test-case "funky claw 3" - (check-eqv? - (let ((x #f)) - (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) - #f)) + (check-eqv? + (let ((x #f)) + (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) + #f)) (test-case "funky claw 4" - (check-eqv? - (let ((x 3)) - (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) - 3/2)) + (check-eqv? + (let ((x 3)) + (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) + 3/2)) )) - ) - - ;;; and-let-test.rkt ends here diff --git a/collects/tests/stepper/test-cases.rkt b/collects/tests/stepper/test-cases.rkt index be305019b3..3a80298171 100644 --- a/collects/tests/stepper/test-cases.rkt +++ b/collects/tests/stepper/test-cases.rkt @@ -83,11 +83,11 @@ :: {((lambda (x) x) 3)} -> {3}) ; (m:mz "((lambda (x) x) (begin (+ 3 4) (+ 4 5)))" -; `((before-after ((begin (hilite (+ 3 4)) (+ 4 5))) -; ((begin (hilite 7) (+ 4 5)))) -; (before-after ((hilite (begin 7 (+ 4 5)))) ((hilite (+ 4 5)))) +; `((before-after ((begin (hilite (+ 3 4)) (+ 4 5))) +; ((begin (hilite 7) (+ 4 5)))) +; (before-after ((hilite (begin 7 (+ 4 5)))) ((hilite (+ 4 5)))) ; (before-after ((hilite (+ 4 5))) ((hilite 9))) -; (finished-stepping))) +; (finished-stepping))) (t 'curried m:mz ((lambda (a) (lambda (b) (+ a b))) 14) diff --git a/collects/texpict/private/texpict-extra.rkt b/collects/texpict/private/texpict-extra.rkt index 1ddb20ef23..56dab0a04b 100644 --- a/collects/texpict/private/texpict-extra.rkt +++ b/collects/texpict/private/texpict-extra.rkt @@ -287,7 +287,7 @@ [else (let-values ([(s l) (search-h dh dv 1 0)]) (if s (values s l) - (best-of-two + (best-of-two (lambda () (best-of-two (lambda () (find-slope dh (add1 dv) max-slope-num h-within (sub1 v-within))) (lambda () (find-slope dh (sub1 dv) max-slope-num h-within (sub1 v-within))))) @@ -318,7 +318,7 @@ [c (if (procedure? (draw-bezier-lines)) ((draw-bezier-lines) (get-len)) #f)]) - `((qbezier ,c ,x1 ,y1 ,(quotient (+ x1 x2) 2) ,(quotient (+ y1 y2) 2) ,x2 ,y2))) + `((qbezier ,c ,x1 ,y1 ,(quotient (+ x1 x2) 2) ,(quotient (+ y1 y2) 2) ,x2 ,y2))) (let* ([dh (- x2 x1)] [dv (- y2 y1)] [s diff --git a/collects/unstable/scribblings/syntax.scrbl b/collects/unstable/scribblings/syntax.scrbl index 01c57bcef8..339b8a11e3 100644 --- a/collects/unstable/scribblings/syntax.scrbl +++ b/collects/unstable/scribblings/syntax.scrbl @@ -75,11 +75,11 @@ op @addition{@author+email["Vincent St-Amour" "stamourv@racket-lang.org"]} @defproc[(format-unique-id [lctx (or/c syntax? #f)] - [fmt string?] - [v (or/c string? symbol? identifier? keyword? char? number?)] ... - [#:source src (or/c syntax? #f) #f] - [#:props props (or/c syntax? #f) #f] - [#:cert cert (or/c syntax? #f) #f]) + [fmt string?] + [v (or/c string? symbol? identifier? keyword? char? number?)] ... + [#:source src (or/c syntax? #f) #f] + [#:props props (or/c syntax? #f) #f] + [#:cert cert (or/c syntax? #f) #f]) identifier?]{ Like @racket[format-id], but returned identifiers are guaranteed to be unique. } diff --git a/collects/web-server/scribblings/tutorial/continue.scrbl b/collects/web-server/scribblings/tutorial/continue.scrbl index fe4c957dcc..ccfa8f2bf2 100644 --- a/collects/web-server/scribblings/tutorial/continue.scrbl +++ b/collects/web-server/scribblings/tutorial/continue.scrbl @@ -106,7 +106,7 @@ representing the desired HTML. An @xexpr is defined as (flat-rec-contract xexpr (or/c string? - (cons/c symbol? (listof xexpr)) + (cons/c symbol? (listof xexpr)) (cons/c symbol? (cons/c (listof (list/c symbol? string?)) (listof xexpr))))))] diff --git a/doc/release-notes/teachpack/HISTORY.txt b/doc/release-notes/teachpack/HISTORY.txt index a2479a554a..e4def0fb17 100644 --- a/doc/release-notes/teachpack/HISTORY.txt +++ b/doc/release-notes/teachpack/HISTORY.txt @@ -1,237 +1,236 @@ -Version 5.3.1 [Wed Oct 31 14:52:48 EDT 2012] +Version 5.3.1 [Wed Oct 31 14:52:48 EDT 2012] -* bug fixes +* bug fixes ------------------------------------------------------------------------ -Version 5.2.1 [Thu Jan 19 11:36:19 EST 2012] +Version 5.2.1 [Thu Jan 19 11:36:19 EST 2012] -* added: universe.rkt now comes with a game-pad simulation option - A game-pad is a special-purpose key handler plus an icon that - maps out the legal key strokes. +* added: universe.rkt now comes with a game-pad simulation option + A game-pad is a special-purpose key handler plus an icon that + maps out the legal key strokes. * fixed -- wheel-left and wheel-right events work properly as key events now - -- on-receive doesn't have to exist for universe/world interactions - -- name clause accepts strings and symbols - -- doc typos + -- on-receive doesn't have to exist for universe/world interactions + -- name clause accepts strings and symbols + -- doc typos ------------------------------------------------------------------------ -Version 5.2 [Tue Oct 18 12:34:16 EDT 2011] +Version 5.2 [Tue Oct 18 12:34:16 EDT 2011] -* bug fixes in 2htdp/universe -* also, on-release now works without presence of an on-key clause +* bug fixes in 2htdp/universe +* also, on-release now works without presence of an on-key clause ------------------------------------------------------------------------ -Version 5.1.2 [Fri Jul 22 15:27:37 EDT 2011] +Version 5.1.2 [Fri Jul 22 15:27:37 EDT 2011] -* The error messages of the image and universe teachpacks have been - revised substantially. They will be improved again next release. +* The error messages of the image and universe teachpacks have been + revised substantially. They will be improved again next release. + +* 5.1.3: the on-tick clause now takes a max number of ticks -* 5.1.3: the on-tick clause now takes a max number of ticks - ------------------------------------------------------------------------ -Version 5.1.1 [Tue Apr 26 22:38:44 EDT 2011] +Version 5.1.1 [Tue Apr 26 22:38:44 EDT 2011] -* bug fix in registration process for universe - implies incompatibility of protocols between 5.1 programs and +* bug fix in registration process for universe + implies incompatibility of protocols between 5.1 programs and predecessors ------------------------------------------------------------------------ -Version 5.1 [Tue Feb 8 13:05:17 EST 2011] +Version 5.1 [Tue Feb 8 13:05:17 EST 2011] -* to-draw (old name: on-draw) is now required for big-bang expressions -* bug fixes in world, image, etc +* to-draw (old name: on-draw) is now required for big-bang expressions +* bug fixes in world, image, etc ------------------------------------------------------------------------ -Version 5.0.2. [Wed Oct 27 18:30:26 EDT 2010] +Version 5.0.2. [Wed Oct 27 18:30:26 EDT 2010] -* fixed stepper-universe interaction (on my side) -* record? allows specification of a directory -* small bug fixes -* small doc fixes +* fixed stepper-universe interaction (on my side) +* record? allows specification of a directory +* small bug fixes +* small doc fixes * batch-io is now in shape to be used (somewhat) in 2e -* robby added pinholes to his image teachpack +* robby added pinholes to his image teachpack ------------------------------------------------------------------------ -Version 5.0.1. [Tue Jul 20 20:52:09 EDT 2010] +Version 5.0.1. [Tue Jul 20 20:52:09 EDT 2010] -* typos in documentation +* typos in documentation ------------------------------------------------------------------------ -Version 5.0 [Fri May 28 13:43:21 EDT 2010] +Version 5.0 [Fri May 28 13:43:21 EDT 2010] * added to-draw to universe to prepare the switch to the new terminoloy ------------------------------------------------------------------------ -Version 4.2.5 [Fri Mar 26 10:02:11 EDT 2010] +Version 4.2.5 [Fri Mar 26 10:02:11 EDT 2010] -* "release" is no longer a key event; use "release" handler instead +* "release" is no longer a key event; use "release" handler instead ------------------------------------------------------------------------ -Version 4.2.4 [Thu Jan 28 12:02:01 EST 2010] +Version 4.2.4 [Thu Jan 28 12:02:01 EST 2010] * separated 2htdp/universe from htdp/image -* 2htdp/universe contains some stupid hacks to improve performance - -- to be changed with Matthew's advice -* error modified -* added a bunch of primitives for JPR -* fixed some other bugs +* 2htdp/universe contains some stupid hacks to improve performance + -- to be changed with Matthew's advice +* error modified +* added a bunch of primitives for JPR +* fixed some other bugs ------------------------------------------------------------------------ -Version 4.2.3 [Sun Nov 22 19:25:01 EST 2009] +Version 4.2.3 [Sun Nov 22 19:25:01 EST 2009] -* bug fixes in universe +* bug fixes in universe * 2htdp/image (first draft) ------------------------------------------------------------------------ -Version 4.2.2 [Sat Aug 29 15:44:41 EDT 2009] +Version 4.2.2 [Sat Aug 29 15:44:41 EDT 2009] -* universe API: - -- added a (state Boolean) option for world and server programs - to display their actual state in a separate window - -- added a mechanism for displaying a final scene - when the world is about to come to an end +* universe API: + -- added a (state Boolean) option for world and server programs + to display their actual state in a separate window + -- added a mechanism for displaying a final scene + when the world is about to come to an end ------------------------------------------------------------------------ -Version 4.2.1 [Wed Jul 22 11:15:54 EDT 2009] +Version 4.2.1 [Wed Jul 22 11:15:54 EDT 2009] * universe API: added launch-many-worlds, fixed numerous small bugs concerning symbol and char elimination ------------------------------------------------------------------------ -Version 4.2 [Thu May 21 08:51:15 EDT 2009] +Version 4.2 [Thu May 21 08:51:15 EDT 2009] * the universe API has changed. It no longer uses chars or symbols - for the callbacks but one-letter strings, except for arrow keys - and special events, which are arbitrarily long strings. + for the callbacks but one-letter strings, except for arrow keys + and special events, which are arbitrarily long strings. ------------------------------------------------------------------------ -Version 4.1.5 [Sat Feb 14 20:12:23 EST 2009] +Version 4.1.5 [Sat Feb 14 20:12:23 EST 2009] * the universe teachpack exports iworld, not world now ------------------------------------------------------------------------ -Version 4.1.4 [Sun Jan 18 21:18:34 EST 2009] +Version 4.1.4 [Sun Jan 18 21:18:34 EST 2009] -* introduces 2htdp/universe +* introduces 2htdp/universe * small bug fixes in world.ss ------------------------------------------------------------------------ -Version 4.1.3 [Wed Nov 19 10:20:41 EST 2008] +Version 4.1.3 [Wed Nov 19 10:20:41 EST 2008] -tiny bug fixes +tiny bug fixes ------------------------------------------------------------------------ -Version 4.1.2 [Sat Oct 25 10:31:05 EDT 2008] +Version 4.1.2 [Sat Oct 25 10:31:05 EDT 2008] nothing new to report ------------------------------------------------------------------------ -Version 4.1.1 [Tue Sep 30 10:17:26 EDT 2008] +Version 4.1.1 [Tue Sep 30 10:17:26 EDT 2008] * world.ss: big-bang can now be re-run after the world has stopped ------------------------------------------------------------------------ -Version 4.1 [Sun Aug 10 12:56:58 EDT 2008] +Version 4.1 [Sun Aug 10 12:56:58 EDT 2008] -* world docs include line to HtDP/2e Prologue +* world docs include line to HtDP/2e Prologue ------------------------------------------------------------------------ -Version 4.0.1 [Fri Jun 20 10:35:32 EDT 2008] +Version 4.0.1 [Fri Jun 20 10:35:32 EDT 2008] * world.ss: replaced 'end-of-world' with a hook called 'stop-when' ------------------------------------------------------------------------ -VERSION 4.0 [Thu May 8 11:03:30 EDT 2008] +VERSION 4.0 [Thu May 8 11:03:30 EDT 2008] * small bug fixes in world * added matrix.ss (requires a write up) - ------------------------------------------------------------------------ -VERSION 371 [Tue Aug 7 17:49:47 EDT 2007] +VERSION 371 [Tue Aug 7 17:49:47 EDT 2007] * changed world.ss so that it exports both add-line from image.ss and - scene+image. + scene+image. ------------------------------------------------------------------------ -VERSION 370 [Mon May 7 09:54:19 EDT 2007] +VERSION 370 [Mon May 7 09:54:19 EDT 2007] -* Added testing.ss teachpack. +* Added testing.ss teachpack. * The world.ss teachpack now has a IMAGE capturing functionality, including - animated GIFs. It also supports simple simulations now. + animated GIFs. It also supports simple simulations now. * The world.ss and image.ss support real numbers for sizes and coordinates - now. + now. -* The ProfessorJ wizard doesn't support templates for now. +* The ProfessorJ wizard doesn't support templates for now. ------------------------------------------------------------------------ -VERSION 360 [Tue Nov 7 12:45:48 EST 2006] +VERSION 360 [Tue Nov 7 12:45:48 EST 2006] - * The world.ss teachpack has now callback hooks for mouse clicks. + * The world.ss teachpack has now callback hooks for mouse clicks. - * The image.ss teachpack now includes a star primitive. + * The image.ss teachpack now includes a star primitive. * Fixed bugs in world.ss, graphing.ss, image.ss ------------------------------------------------------------------------ -VERSION 351 [Tue Jul 18 14:11:29 EDT 2006] +VERSION 351 [Tue Jul 18 14:11:29 EDT 2006] - * The libraries for ProfessorJ are now organized as four packages: - draw, idraw, geometry, and colors. + * The libraries for ProfessorJ are now organized as four packages: + draw, idraw, geometry, and colors. * Fixed small problems with master.ss and image.ss teachpacks and their - docs. + docs. ------------------------------------------------------------------------ -VERSION 350 [Fri Jun 16 20:37:38 EDT 2006] +VERSION 350 [Fri Jun 16 20:37:38 EDT 2006] - * The draw package (ProfJ) spawns a new Canvas per new Canvas. + * The draw package (ProfJ) spawns a new Canvas per new Canvas. The implementation of draw.ss has changed for that, though the visible - interface should remain the same. - - * The idraw package provides imperative versions of World and Canvas. + interface should remain the same. - * Small bugs in world.ss and image.ss fixed. + * The idraw package provides imperative versions of World and Canvas. + + * Small bugs in world.ss and image.ss fixed. * servlet.ss and servlet2.ss are still missing. Expect their arrival - for 351. + for 351. ------------------------------------------------------------------------ -VERSION 300 [Mon Dec 12 15:59:02 EST 2005] +VERSION 300 [Mon Dec 12 15:59:02 EST 2005] - * The world.ss teachpack has changed. It no longer supports - (update ... produce ...) but instead provides a function - on-redraw. + * The world.ss teachpack has changed. It no longer supports + (update ... produce ...) but instead provides a function + on-redraw. * servlet.ss and servlet2.ss are still missing. Expect their arrival - for 301. + for 301. ------------------------------------------------------------------------ -VERSION 299.200 [Tue Aug 2 17:37:24 EDT 2005] +VERSION 299.200 [Tue Aug 2 17:37:24 EDT 2005] * servlet.ss and servlet2.ss are still missing. Expect their arrival - for 300. + for 300. * draw.ss in the HtDCH teachpack collection has radically changed. See - the doc.txt file for the new arrangement. + the doc.txt file for the new arrangement. ------------------------------------------------------------------------ -VERSION 209 [Fri Dec 17 10:19:52 EST 2004] +VERSION 209 [Fri Dec 17 10:19:52 EST 2004] * fixed small bugs in image.ss and world.ss concerning colors and the - location of pinholes + location of pinholes * The interface of the draw teachpack (package) for ProfessorJ has changed. A World now supports draw and erase methods. The onTick and onKeyEvent methods call erase on the current world, create the next - world, and then call draw on the new world. + world, and then call draw on the new world. ------------------------------------------------------------------------ VERSION 208p1 @@ -240,12 +239,12 @@ VERSION 208p1 relative to the pinhole. Misc image.ss docs improvements. ------------------------------------------------------------------------ -VERSION 208 [Fri Jul 30 10:07:21 EDT 2004] +VERSION 208 [Fri Jul 30 10:07:21 EDT 2004] * image.ss introduces images as algebraic values. Students can create basic images such as rectangles, circles, and they can compose them via an overlay function. There are also primitives for finding one picture in - another one and so on. Testing with drawing is now feasible. + another one and so on. Testing with drawing is now feasible. * world.ss enriches image.ss with animation functions. Like draw.ss, it comes with big-bang, on-key-event, on-tick, end-of-time for creating a @@ -253,67 +252,66 @@ VERSION 208 [Fri Jul 30 10:07:21 EDT 2004] ending time. It also comes with a mechanism for display movies. It does *not* yet provide primitives for dealing with mouse clicks. - The performance problems from the TS! workshops have been eliminated. + The performance problems from the TS! workshops have been eliminated. ------------------------------------------------------------------------ -VERSION 207 [Fri May 14 12:52:43 EDT 2004] +VERSION 207 [Fri May 14 12:52:43 EDT 2004] * draw.ss now comes with functional callbacks for maintaining a visual - world: big-bang, on-key-event, on-tick, end-of-time + world: big-bang, on-key-event, on-tick, end-of-time -* draw also comes now as a ProfessorJ implementation in the htdch +* draw also comes now as a ProfessorJ implementation in the htdch collects directory. This is an experimental teachpack. Docs are available via doc.txt. Experiences with students may change this teachpack - significantly. - ------------------------------------------------------------------------- -VERSION 203 [Thu Dec 5 09:10:40 EST 2002] - -* added get-key-event to draw.ss + significantly. ------------------------------------------------------------------------ -VERSION 201 [Wed Jul 24 22:44:19 EDT 2002] +VERSION 203 [Thu Dec 5 09:10:40 EST 2002] -* added servlet.ss and servlet2.ss +* added get-key-event to draw.ss + +------------------------------------------------------------------------ +VERSION 201 [Wed Jul 24 22:44:19 EDT 2002] + +* added servlet.ss and servlet2.ss * all exported functions are primitive operators or higher order primitives this improves error reporting behavior in the Beginner languages (before higher-order functions are introduced) -* removed: - pingp-play.ss - pingp.ss - protect-play.ss - rectangle.ss - these teachpacks aren't mentioned in htdp, and aren't used for any +* removed: + pingp-play.ss + pingp.ss + protect-play.ss + rectangle.ss + these teachpacks aren't mentioned in htdp, and aren't used for any of the additional exercises ------------------------------------------------------------------------ -VERSION 200alpha1 [Wed Nov 21 13:07:43 EST 2001] +VERSION 200alpha1 [Wed Nov 21 13:07:43 EST 2001] -* Robby converted to modules +* Robby converted to modules -* Fixed bug in convert.ss +* Fixed bug in convert.ss ------------------------------------------------------------------------ -VERSION 103 [] +VERSION 103 [] * modified draw.ss interface so that colors are symbols - use 'red instead of RED + use 'red instead of RED ------------------------------------------------------------------------ -VERSION 102 [Thu Jun 22 18:22:48 CDT 2000] +VERSION 102 [Thu Jun 22 18:22:48 CDT 2000] * Added "convert.ss" to teachpacks/htdp * Fixed error messages for some arity tests -* Fixed documentation +* Fixed documentation ------------------------------------------------------------------------ -VERSION 101 [Tue Oct 26 22:28:38 CDT 1999] - +VERSION 101 [Tue Oct 26 22:28:38 CDT 1999] * TERMINOLOGY: We decided to eliminate the terminology "teaching library", because it is easily confused with a plain library. As of @@ -330,23 +328,23 @@ VERSION 101 [Tue Oct 26 22:28:38 CDT 1999] PLTHOME is the location of the PLT software The htdp subdirectory contains those files that matter to students who - use HtDP. + use HtDP. * CHANGES in individual teachpacks: The most important and most visible change in the teachpack support concerns - hangman.ss + hangman.ss It now provides two GUI interfaces: (1) hangman for three-letter words and (2) hangman-list for words of arbitrary length. See the teachpack - documentation for details. + documentation for details. - The teachpack + The teachpack master.ss now exports the procedure _master_, which is exactly like the procedure - _repl_ in the old master-lib.ss library. + _repl_ in the old master-lib.ss library. The corresponding exercises in HtDP have been rewritten and are posted on the HtDP Web site. @@ -354,14 +352,14 @@ VERSION 101 [Tue Oct 26 22:28:38 CDT 1999] * REMINDER: The *purpose* of teachpacks is to supplement student programs with code that is beyond the teaching languages (Beginner, Intermediate, Advanced). For example, to enable students to play hangman, we supply a - teachpack that - - implements the random choosing of a word - - maintains the state variable of how many guesses have gone wrong - - manages the GUI. + teachpack that + - implements the random choosing of a word + - maintains the state variable of how many guesses have gone wrong + - manages the GUI. All these tasks are beyond students in the third week and/or impose - nothing memorization of currently useless knowledge on students. + nothing memorization of currently useless knowledge on students. - A teachpack is a signed unit that imports the interface: + A teachpack is a signed unit that imports the interface: plt:userspace^ @@ -377,20 +375,20 @@ graphics library. In order to use the graphics library in your teachpacks, use a compound unit and link in graphics directly. For example: (require-library "graphics.ss" "graphics") - + (define-signature my-teachpack^ (four)) - + (define my-teachpack (unit/sig my-teachpack^ - - (import plt:userspace^ + + (import plt:userspace^ graphics^) - + '... - + (define four 4))) - - (compound-unit/sig + + (compound-unit/sig (import [P : plt:userspace^]) (link [G : graphics^ ((require-library "graphicr.ss" "graphics") (P : mzlib:file^) From 1e55f71f8a58da1f9600c40c1bece74b929f419e Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 7 Nov 2012 11:34:33 -0500 Subject: [PATCH 202/221] Two more `#lang racket' -> `#lang racket/base'. --- collects/2htdp/private/clauses-spec-aux.rkt | 4 ++-- collects/lang/private/sl-eval.rkt | 3 ++- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/collects/2htdp/private/clauses-spec-aux.rkt b/collects/2htdp/private/clauses-spec-aux.rkt index 28487df29a..b3837451e0 100644 --- a/collects/2htdp/private/clauses-spec-aux.rkt +++ b/collects/2htdp/private/clauses-spec-aux.rkt @@ -1,4 +1,4 @@ -#lang racket +#lang racket/base ;; --------------------------------------------------------------------------------------------------- ;; provides constants and functions for specifying the shape of clauses in big-bang and universe @@ -6,7 +6,7 @@ (provide nat> nat? proc> bool> num> ip> string> symbol> string-or-symbol> any> K False True) (require htdp/error "check-aux.rkt") - + (define (K w . r) w) (define (False w) #f) (define (True w) #t) diff --git a/collects/lang/private/sl-eval.rkt b/collects/lang/private/sl-eval.rkt index 106a37d158..84f7509797 100644 --- a/collects/lang/private/sl-eval.rkt +++ b/collects/lang/private/sl-eval.rkt @@ -1,6 +1,7 @@ -#lang racket +#lang racket/base (require teachpack/2htdp/scribblings/img-eval + racket/pretty racket/sandbox mzlib/pconvert file/convertible From 056c1aaff44918a4e2439aa84c6b931e1afd4473 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 7 Nov 2012 09:34:57 -0500 Subject: [PATCH 203/221] Chars are compared with `eqv?`. --- collects/typed-racket/typecheck/tc-app/tc-app-eq.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-eq.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-eq.rkt index 1a817035d6..9730290363 100644 --- a/collects/typed-racket/typecheck/tc-app/tc-app-eq.rkt +++ b/collects/typed-racket/typecheck/tc-app/tc-app-eq.rkt @@ -40,7 +40,7 @@ ;; identifier expr expr -> tc-results (define (tc/eq comparator v1 v2) (define (eq?-able e) (or (boolean? e) (keyword? e) (symbol? e) (eof-object? e))) - (define (eqv?-able e) (or (eq?-able e) (number? e))) + (define (eqv?-able e) (or (eq?-able e) (number? e) (char? e))) (define (equal?-able e) #t) (define (ok? val) (define-syntax-rule (alt nm pred ...) From 0a0ac35ee6a427d3ca8341eb04a844a4ae7b8514 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 7 Nov 2012 12:20:29 -0500 Subject: [PATCH 204/221] Correctly bind `place?` for contract generation. --- collects/typed-racket/types/abbrev.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-racket/types/abbrev.rkt b/collects/typed-racket/types/abbrev.rkt index 517b645184..df0a3a2bdd 100644 --- a/collects/typed-racket/types/abbrev.rkt +++ b/collects/typed-racket/types/abbrev.rkt @@ -18,7 +18,7 @@ (except-in racket/contract/base ->* -> one-of/c) (prefix-in c: racket/contract/base) (for-syntax racket/base syntax/parse racket/list) - (for-template racket/base racket/contract/base racket/promise racket/tcp racket/flonum racket/udp) + (for-template racket/base racket/contract/base racket/promise racket/tcp racket/flonum racket/udp '#%place) racket/pretty racket/udp ;; for base type predicates racket/promise racket/tcp racket/flonum) From facea9fe43ef37bd3c2f0f42a35ba12bd1bc88b7 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 7 Nov 2012 11:24:06 -0600 Subject: [PATCH 205/221] make the position and position-token structs transparent (these seem to only not be transparent because that is the default) --- collects/parser-tools/private-lex/token.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/parser-tools/private-lex/token.rkt b/collects/parser-tools/private-lex/token.rkt index 1d2dc0d60a..6618a57e81 100644 --- a/collects/parser-tools/private-lex/token.rkt +++ b/collects/parser-tools/private-lex/token.rkt @@ -83,7 +83,7 @@ (define-syntax define-tokens (make-define-tokens #f)) (define-syntax define-empty-tokens (make-define-tokens #t)) - (define-struct position (offset line col)) - (define-struct position-token (token start-pos end-pos)) + (define-struct position (offset line col) #f) + (define-struct position-token (token start-pos end-pos) #f) ) From 5c6498b3550ab0b5a128d6d26d20fe32b783ddff Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Mon, 5 Nov 2012 11:53:47 -0700 Subject: [PATCH 206/221] Fix for PR 13234. xexpr-core: added more test cases to correct-xexpr?. Inverted the logic and replaced the continuation-passing style with simpler test-for-error logic. Also corrected typo in attribute symbol checker that could otherwise lead to a contract error. (taking the cadr of a non-cadrable value) --- collects/tests/xml/test.rkt | 21 +++- collects/xml/private/xexpr-core.rkt | 182 ++++++++++++++++------------ 2 files changed, 124 insertions(+), 79 deletions(-) diff --git a/collects/tests/xml/test.rkt b/collects/tests/xml/test.rkt index 2bed28d40b..66c6afc110 100644 --- a/collects/tests/xml/test.rkt +++ b/collects/tests/xml/test.rkt @@ -123,6 +123,7 @@ END (test-xexpr? 'nbsp) (test-xexpr? 10) (test-not-xexpr? 0) + (test-not-xexpr? '(a ((b)) c)) (test-xexpr? (make-cdata #f #f "unquoted ")) (test-xexpr? (make-comment "Comment!")) (test-xexpr? (make-pcdata #f #f "quoted ")) @@ -130,7 +131,8 @@ END (test-not-xexpr? (list 'a (list (list 'href)) "content")) (test-not-xexpr? +) - (test-not-xexpr? #f)) + (test-not-xexpr? #f) + (test-not-xexpr? '())) (test-not-false "xexpr/c" (contract? xexpr/c)) @@ -637,8 +639,23 @@ END (test-validate-xexpr/exn 4 4) (test-validate-xexpr/exn + +) (test-validate-xexpr/exn '(a ([href foo]) bar) 'foo) - (test-validate-xexpr/exn '("foo" bar) '("foo" bar)))) + (test-validate-xexpr/exn '("foo" bar) '("foo" bar)) + (test-validate-xexpr/exn '(x (("not-a-symbol" "42"))) + "not-a-symbol") + (test-validate-xexpr/exn '(x (("also-not-a-symbol"))) + "also-not-a-symbol"))) + (test-suite + "correct-xexpr?" + (parameterize ([permissive-xexprs #f]) + (test-equal? "null is not an xexpr" + (correct-xexpr? '() (lambda () 'no) (lambda (exn) 'yes)) + 'yes) + (test-true "malformed xexpr" + (correct-xexpr? '(a ((b)) c) + (lambda () #f) + (lambda (exn) #t))))) + ; XXX correct-xexpr? (test-suite diff --git a/collects/xml/private/xexpr-core.rkt b/collects/xml/private/xexpr-core.rkt index 1f31fdaf16..c2211213ed 100644 --- a/collects/xml/private/xexpr-core.rkt +++ b/collects/xml/private/xexpr-core.rkt @@ -11,7 +11,7 @@ [xexpr/c contract?] [xexpr? (any/c . -> . boolean?)] [validate-xexpr (any/c . -> . (one-of/c #t))] - [correct-xexpr? (any/c (-> any/c) (exn:invalid-xexpr? . -> . any/c) . -> . any/c)]) + [rename correct-xexpr/k? correct-xexpr? (any/c (-> any/c) (exn:invalid-xexpr? . -> . any/c) . -> . any/c)]) (struct-out exn:invalid-xexpr)) ;; Xexpr ::= String @@ -31,10 +31,14 @@ comment? p-i? cdata? pcdata?)) (define (xexpr? x) - (correct-xexpr? x (lambda () #t) (lambda (exn) #f))) + (not (incorrect-xexpr? x))) (define (validate-xexpr x) - (correct-xexpr? x (lambda () #t) (lambda (exn) (raise exn)))) + (define maybe-exn (incorrect-xexpr? x)) + (if maybe-exn + (raise maybe-exn) + #t)) + (define xexpr/c (make-flat-contract @@ -59,89 +63,113 @@ (define-struct (exn:invalid-xexpr exn:fail) (code)) -;; correct-xexpr? : any (-> a) (exn -> a) -> a -(define (correct-xexpr? x true false) - (cond - ((string? x) (true)) - ((symbol? x) (true)) - ((valid-char? x) (true)) - ((comment? x) (true)) - ((p-i? x) (true)) - ((cdata? x) (true)) - ((pcdata? x) (true)) - ((list? x) - (or (null? x) - (if (symbol? (car x)) - (if (has-attribute? x) - (and (attribute-pairs? (cadr x) true false) - (andmap (lambda (part) - (correct-xexpr? part true false)) - (cddr x)) - (true)) - (andmap (lambda (part) - (correct-xexpr? part true false)) - (cdr x))) - (false (make-exn:invalid-xexpr - (format - "Expected a symbol as the element name, given ~s" - (car x)) - (current-continuation-marks) - x))))) - [(permissive-xexprs) (true)] - (else (false - (make-exn:invalid-xexpr - (format (string-append - "Expected a string, symbol, valid numeric entity, comment, " - "processing instruction, or list, given ~s") - x) - (current-continuation-marks) - x))))) -;; has-attribute? : List -> Boolean -;; True if the Xexpr provided has an attribute list. -(define (has-attribute? x) + +;; correct-xexpr/k? : any (-> a) (exn -> a) -> a +;; Calls true-k if x is a correct-xexpr. Otherwise, calls the +;; failure continuation false-k with an exn:invalid-xexpr instance. +(define (correct-xexpr/k? x true-k false-k) + (define maybe-exn (incorrect-xexpr? x)) + (if maybe-exn + (false-k maybe-exn) + (true-k))) + + +;; incorrect-xexpr?: any -> (or/c #f exn:invalid-xexpr) +;; Returns an exn:invalid-xexpr if the xexpr has incorrect structure. +;; Otherwise, returns #f. +(define (incorrect-xexpr? x) + (cond + [(string? x) #f] + [(symbol? x) #f] + [(valid-char? x) #f] + [(comment? x) #f] + [(p-i? x) #f] + [(cdata? x) #f] + [(pcdata? x) #f] + [(list? x) + (cond [(null? x) + (make-exn:invalid-xexpr + "Expected a symbol as the element name, given nothing" + (current-continuation-marks) + x)] + [else + (if (symbol? (car x)) + (cond [(has-attribute-pairs? x) + (define maybe-exn (erroneous-attribute-pairs? (cadr x))) + (cond [maybe-exn maybe-exn] + [else + (for/or ([elt (in-list (cddr x))]) + (incorrect-xexpr? elt))])] + + [else + (for/or ([elt (in-list (cdr x))]) + (incorrect-xexpr? elt))]) + (make-exn:invalid-xexpr + (format + "Expected a symbol as the element name, given ~s" + (car x)) + (current-continuation-marks) + x))])] + [(permissive-xexprs) #f] + [else (make-exn:invalid-xexpr + (format (string-append + "Expected a string, symbol, valid numeric entity, comment, " + "processing instruction, or list, given ~s") + x) + (current-continuation-marks) + x)])) + +;; has-attribute-pairs? : List -> Boolean +;; True if the Xexpr provided has an attribute list. The attribute list is not +;; checked for correct structure here. +(define (has-attribute-pairs? x) (and (> (length x) 1) (list? (cadr x)) - (andmap (lambda (attr) - (pair? attr)) - (cadr x)))) + (for/and ([attr (in-list (cadr x))]) + (pair? attr)))) -;; attribute-pairs? : List (-> a) (exn -> a) -> a -;; True if the list is a list of pairs. -(define (attribute-pairs? attrs true false) - (if (null? attrs) - (true) - (let ((attr (car attrs))) - (if (pair? attr) - (and (attribute-symbol-string? attr true false) - (attribute-pairs? (cdr attrs) true false ) - (true)) - (false - (make-exn:invalid-xexpr - (format "Expected an attribute pair, given ~s" attr) - (current-continuation-marks) - attr)))))) -;; attribute-symbol-string? : List (-> a) (exn -> a) -> a -;; True if the list is a list of String,Symbol pairs. -(define (attribute-symbol-string? attr true false) +;; erroneous-attribute-pairs? : List -> (or/c #f exn:invalid-xexpr) +;; Returns exn:invalid-expr if the attribute pair list is not correctly structured. +(define (erroneous-attribute-pairs? attrs) + (cond [(null? attrs) + #f] + [else + (define attr (car attrs)) + (cond [(pair? attr) + (define maybe-exn (erroneous-attribute-symbol-string? attr)) + (cond + [maybe-exn maybe-exn] + [else + (erroneous-attribute-pairs? (cdr attrs))])] + [else + (make-exn:invalid-xexpr + (format "Expected an attribute pair, given ~s" attr) + (current-continuation-marks) + attr)])])) + + +;; erroneous-attribute-symbol-string? : List -> (or/c #f exn:invalid-xexpr) +;; Returns exn:invalid-expr if the list is not a (String, Symbol) pair. +(define (erroneous-attribute-symbol-string? attr) (if (symbol? (car attr)) (if (pair? (cdr attr)) (if (or (string? (cadr attr)) (permissive-xexprs)) - (true) - (false (make-exn:invalid-xexpr - (format "Expected an attribute value string, given ~v" (cadr attr)) - (current-continuation-marks) - (cadr attr)))) - (false (make-exn:invalid-xexpr - (format "Expected an attribute value string for attribute ~s, given nothing" attr) - (current-continuation-marks) - attr))) - (false (make-exn:invalid-xexpr - (format "Expected an attribute symbol, given ~s" (car attr)) - (current-continuation-marks) - (cadr attr))))) + #f + (make-exn:invalid-xexpr + (format "Expected an attribute value string, given ~v" (cadr attr)) + (current-continuation-marks) + (cadr attr))) + (make-exn:invalid-xexpr + (format "Expected an attribute value string for attribute ~s, given nothing" attr) + (current-continuation-marks) + attr)) + (make-exn:invalid-xexpr + (format "Expected an attribute symbol, given ~s" (car attr)) + (current-continuation-marks) + (car attr)))) ;; ; end xexpr? helpers ;; ;; ;; ;; ;; ;; ;; ;; From d15059ada7882d5139e1df713e156e25f91b11ca Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 7 Nov 2012 14:50:24 -0500 Subject: [PATCH 207/221] v5.3.1 stuff --- collects/meta/web/download/installers.txt | 24 +++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/collects/meta/web/download/installers.txt b/collects/meta/web/download/installers.txt index 7b1a4f721e..499c65c725 100644 --- a/collects/meta/web/download/installers.txt +++ b/collects/meta/web/download/installers.txt @@ -212,6 +212,30 @@ 16601808 5.2/racket/racket-5.2-src-mac.dmg 16260740 5.2/racket/racket-5.2-src-unix.tgz 19575041 5.2/racket/racket-5.2-src-win.zip +11552351 5.3.1/racket-textual/racket-textual-5.3.1-bin-i386-linux-f12.sh +11570689 5.3.1/racket-textual/racket-textual-5.3.1-bin-i386-linux-ubuntu-karmic.sh +12143855 5.3.1/racket-textual/racket-textual-5.3.1-bin-i386-osx-mac.dmg +8803203 5.3.1/racket-textual/racket-textual-5.3.1-bin-i386-win32.exe +12081255 5.3.1/racket-textual/racket-textual-5.3.1-bin-ppc-osx-mac.dmg +11748331 5.3.1/racket-textual/racket-textual-5.3.1-bin-x86_64-linux-debian-squeeze.sh +11757467 5.3.1/racket-textual/racket-textual-5.3.1-bin-x86_64-linux-f14.sh +12278659 5.3.1/racket-textual/racket-textual-5.3.1-bin-x86_64-osx-mac.dmg +9171125 5.3.1/racket-textual/racket-textual-5.3.1-bin-x86_64-win32.exe +6254337 5.3.1/racket-textual/racket-textual-5.3.1-src-mac.dmg +6134415 5.3.1/racket-textual/racket-textual-5.3.1-src-unix.tgz +7252130 5.3.1/racket-textual/racket-textual-5.3.1-src-win.zip +64527997 5.3.1/racket/racket-5.3.1-bin-i386-linux-f12.sh +64562401 5.3.1/racket/racket-5.3.1-bin-i386-linux-ubuntu-karmic.sh +67179194 5.3.1/racket/racket-5.3.1-bin-i386-osx-mac.dmg +43655604 5.3.1/racket/racket-5.3.1-bin-i386-win32.exe +67981764 5.3.1/racket/racket-5.3.1-bin-ppc-osx-mac.dmg +64911589 5.3.1/racket/racket-5.3.1-bin-x86_64-linux-debian-squeeze.sh +64927156 5.3.1/racket/racket-5.3.1-bin-x86_64-linux-f14.sh +67721160 5.3.1/racket/racket-5.3.1-bin-x86_64-osx-mac.dmg +44343519 5.3.1/racket/racket-5.3.1-bin-x86_64-win32.exe +19042596 5.3.1/racket/racket-5.3.1-src-mac.dmg +18296513 5.3.1/racket/racket-5.3.1-src-unix.tgz +21668825 5.3.1/racket/racket-5.3.1-src-win.zip 11235593 5.3/racket-textual/racket-textual-5.3-bin-i386-linux-f12.sh 11248024 5.3/racket-textual/racket-textual-5.3-bin-i386-linux-ubuntu-karmic.sh 11806657 5.3/racket-textual/racket-textual-5.3-bin-i386-osx-mac.dmg From 7b04571facdafe778bfb05f9c54d7da6d467b05d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 7 Nov 2012 14:23:09 -0700 Subject: [PATCH 208/221] racket/gui: add `get-current-mouse-state' --- collects/mred/mred-sig.rkt | 1 + collects/mred/private/mred.rkt | 1 + collects/mred/private/wx/cocoa/platform.rkt | 1 + collects/mred/private/wx/cocoa/procs.rkt | 31 ++++++++++++++++++-- collects/mred/private/wx/gtk/frame.rkt | 31 +++++++++++++++++++- collects/mred/private/wx/gtk/platform.rkt | 1 + collects/mred/private/wx/platform.rkt | 1 + collects/mred/private/wx/win32/platform.rkt | 1 + collects/mred/private/wx/win32/procs.rkt | 24 +++++++++++++++ collects/scribblings/gui/miscwin-funcs.scrbl | 9 ++++++ collects/tests/gracket/item.rkt | 26 ++++++++++++++++ doc/release-notes/racket/HISTORY.txt | 3 ++ 12 files changed, 127 insertions(+), 3 deletions(-) diff --git a/collects/mred/mred-sig.rkt b/collects/mred/mred-sig.rkt index bc49ba6e45..8d7ecd83e1 100644 --- a/collects/mred/mred-sig.rkt +++ b/collects/mred/mred-sig.rkt @@ -78,6 +78,7 @@ frame% gauge% get-choices-from-user get-color-from-user +get-current-mouse-state get-default-shortcut-prefix get-directory get-display-count diff --git a/collects/mred/private/mred.rkt b/collects/mred/private/mred.rkt index 6e26e1b20c..8f49d9fc2a 100644 --- a/collects/mred/private/mred.rkt +++ b/collects/mred/private/mred.rkt @@ -116,6 +116,7 @@ event-dispatch-handler eventspace? flush-display + get-current-mouse-state get-highlight-background-color get-highlight-text-color get-the-editor-data-class-list diff --git a/collects/mred/private/wx/cocoa/platform.rkt b/collects/mred/private/wx/cocoa/platform.rkt index 6ec950eba9..1567a0c7d4 100644 --- a/collects/mred/private/wx/cocoa/platform.rkt +++ b/collects/mred/private/wx/cocoa/platform.rkt @@ -63,6 +63,7 @@ display-origin display-count flush-display + get-current-mouse-state fill-private-color cancel-quit get-control-font-face diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index 1d1400d10b..63a656ec73 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -6,6 +6,7 @@ ffi/unsafe ffi/unsafe/objc "utils.rkt" + "const.rkt" "types.rkt" "frame.rkt" "window.rkt" @@ -63,9 +64,10 @@ file-creator-and-type file-selector key-symbol-to-menu-key - needs-grow-box-spacer?) + needs-grow-box-spacer? + get-current-mouse-state) -(import-class NSScreen NSCursor NSMenu) +(import-class NSScreen NSCursor NSMenu NSEvent) (define (find-graphical-system-path what) #f) @@ -192,3 +194,28 @@ (define (needs-grow-box-spacer?) (not (version-10.7-or-later?))) + +;; ------------------------------------------------------------ +;; Mouse and modifier-key state + +(define (get-current-mouse-state) + (define posn (tell #:type _NSPoint NSEvent mouseLocation)) + (define buttons (tell #:type _NSUInteger NSEvent pressedMouseButtons)) + (define mods (tell #:type _NSUInteger NSEvent modifierFlags)) + (define (maybe v mask sym) + (if (zero? (bitwise-and v mask)) + null + (list sym))) + (define h (let ([f (tell #:type _NSRect (tell NSScreen mainScreen) frame)]) + (NSSize-height (NSRect-size f)))) + (values (make-object point% + (->long (NSPoint-x posn)) + (->long (- (- h (NSPoint-y posn)) (get-menu-bar-height)))) + (append + (maybe buttons #x1 'left) + (maybe buttons #x2 'right) + (maybe mods NSShiftKeyMask 'shift) + (maybe mods NSCommandKeyMask 'meta) + (maybe mods NSAlternateKeyMask 'alt) + (maybe mods NSControlKeyMask 'control) + (maybe mods NSAlphaShiftKeyMask 'caps)))) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index d46279c9a5..59fa99636c 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -22,7 +22,8 @@ display-origin display-size display-count - location->window)) + location->window + get-current-mouse-state)) ;; ---------------------------------------- @@ -57,6 +58,13 @@ (define-gtk gtk_window_resize (_fun _GtkWidget _int _int -> _void)) (define-gdk gdk_window_set_cursor (_fun _GdkWindow _pointer -> _void)) +(define-gdk gdk_screen_get_root_window (_fun _GdkScreen -> _GdkWindow)) +(define-gdk gdk_window_get_pointer (_fun _GdkWindow + (x : (_ptr o _int)) + (y : (_ptr o _int)) + (mods : (_ptr o _uint)) + -> _GdkWindow + -> (values x y mods))) (define-gtk gtk_window_iconify (_fun _GtkWindow -> _void)) (define-gtk gtk_window_deiconify (_fun _GtkWindow -> _void)) @@ -543,3 +551,24 @@ [fh (send f get-height)]) (<= fy y (+ fy fh))) f)))) + +;; ---------------------------------------- + +(define (get-current-mouse-state) + (define-values (x y mods) (gdk_window_get_pointer + (gdk_screen_get_root_window + (gdk_screen_get_default)))) + (define (maybe mask sym) + (if (zero? (bitwise-and mods mask)) + null + (list sym))) + (values (make-object point% x y) + (append + (maybe GDK_BUTTON1_MASK 'left) + (maybe GDK_BUTTON2_MASK 'middle) + (maybe GDK_BUTTON3_MASK 'right) + (maybe GDK_SHIFT_MASK 'shift) + (maybe GDK_LOCK_MASK 'caps) + (maybe GDK_CONTROL_MASK 'control) + (maybe GDK_MOD1_MASK 'alt) + (maybe GDK_META_MASK 'meta)))) diff --git a/collects/mred/private/wx/gtk/platform.rkt b/collects/mred/private/wx/gtk/platform.rkt index a54adf28b5..1194feef74 100644 --- a/collects/mred/private/wx/gtk/platform.rkt +++ b/collects/mred/private/wx/gtk/platform.rkt @@ -64,6 +64,7 @@ display-origin display-count flush-display + get-current-mouse-state fill-private-color cancel-quit get-control-font-face diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index 352f6366a9..5c2e0654e1 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -50,6 +50,7 @@ display-origin display-count flush-display + get-current-mouse-state fill-private-color cancel-quit get-control-font-face diff --git a/collects/mred/private/wx/win32/platform.rkt b/collects/mred/private/wx/win32/platform.rkt index 0a70c3d3b2..e3d775ef3f 100644 --- a/collects/mred/private/wx/win32/platform.rkt +++ b/collects/mred/private/wx/win32/platform.rkt @@ -64,6 +64,7 @@ display-origin display-count flush-display + get-current-mouse-state fill-private-color cancel-quit get-control-font-face diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 7c7f6d8752..81ef379e7a 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -43,6 +43,7 @@ get-highlight-text-color check-for-break) flush-display + get-current-mouse-state fill-private-color play-sound location->window @@ -116,3 +117,26 @@ (define (check-for-break) #f) (define (needs-grow-box-spacer?) #f) + +(define-user32 GetCursorPos (_wfun (p : (_ptr o _POINT)) -> (r : _BOOL) + -> (if r + p + (failed 'GetCursorPos)))) +(define-user32 GetAsyncKeyState (_wfun _int -> _SHORT)) +(define-user32 GetSystemMetrics (_wfun _int -> _int)) +(define SM_SWAPBUTTON 23) +(define (get-current-mouse-state) + (define p (GetCursorPos)) + (define (maybe vk sym) + (if (negative? (GetAsyncKeyState vk)) + (list sym) + null)) + (define swapped? (not (zero? (GetSystemMetrics SM_SWAPBUTTON)))) + (values (make-object point% (POINT-x p) (POINT-y p)) + (append + (maybe (if swapped? VK_RBUTTON VK_LBUTTON) 'left) + (maybe (if swapped? VK_LBUTTON VK_RBUTTON) 'right) + (maybe VK_LSHIFT 'shift) + (maybe VK_CONTROL 'control) + (maybe VK_MENU 'alt) + (maybe VK_CAPITAL 'caps)))) diff --git a/collects/scribblings/gui/miscwin-funcs.scrbl b/collects/scribblings/gui/miscwin-funcs.scrbl index 441b46b541..a777274f4e 100644 --- a/collects/scribblings/gui/miscwin-funcs.scrbl +++ b/collects/scribblings/gui/miscwin-funcs.scrbl @@ -194,6 +194,15 @@ break is sent (via @racket[break-thread]) to the created eventspace's @tech{handler thread}.} +@defproc[(get-current-mouse-state) (values (is-a?/c point%) + (listof (or/c 'left 'middle 'right + 'shift 'control 'alt 'meta 'caps)))]{ + +Returns the current location of the mouse in screen coordinates, +and returns a list of symbols for mouse buttons and modifier keys +that are currently pressed.} + + @defproc[(hide-cursor-until-moved) void?]{ Hides the cursor until the user moves the mouse or clicks the mouse diff --git a/collects/tests/gracket/item.rkt b/collects/tests/gracket/item.rkt index 8566a95198..dbc19149f6 100644 --- a/collects/tests/gracket/item.rkt +++ b/collects/tests/gracket/item.rkt @@ -2289,6 +2289,30 @@ '(arrow bullseye cross hand ibeam watch blank size-n/s size-e/w size-ne/sw size-nw/se)) (send f show #t)) +;---------------------------------------------------------------------- + +(define (mouse) + (define f (new frame% + [label "Mouse"] + [width 300] + [height 200])) + (define m (new message% + [parent f] + [label ""] + [stretchable-width #t])) + (send f show #t) + (thread (lambda () + (let loop () + (when (send f is-shown?) + (sleep 0.1) + (define-values (pos keys) (get-current-mouse-state)) + (queue-callback + (lambda () (send m set-label + (format "~a,~a ~a" + (send pos get-x) + (send pos get-y) + keys)))) + (loop)))))) ;---------------------------------------------------------------------- @@ -2370,6 +2394,8 @@ (make-object vertical-pane% crp) ; filler (make-object button% "Cursors" crp (lambda (b e) (cursors))) (make-object vertical-pane% crp) ; filler +(make-object button% "Mouse" crp (lambda (b e) (mouse))) +(make-object vertical-pane% crp) ; filler (make-object button% "Make Radiobox Frame" crp (lambda (b e) (radiobox-frame))) (define cp (make-object horizontal-pane% ap)) (send cp stretchable-width #f) diff --git a/doc/release-notes/racket/HISTORY.txt b/doc/release-notes/racket/HISTORY.txt index 2faafc9d63..5cf717187d 100644 --- a/doc/release-notes/racket/HISTORY.txt +++ b/doc/release-notes/racket/HISTORY.txt @@ -1,3 +1,6 @@ +Version 5.3.1.5 +racket/gui: added get-current-mouse-state + Version 5.3.1.2 compiler/zo-structs: added a constantness field to module-variable From 741be85f07f6d9fc66f3fa7ea9f679a2d9ad2c2a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 7 Nov 2012 16:06:43 -0600 Subject: [PATCH 209/221] make the log follower always available in DrRacket --- collects/framework/private/follow-log.rkt | 151 ++++++++++++++++++++++ collects/framework/private/frame.rkt | 18 ++- 2 files changed, 165 insertions(+), 4 deletions(-) create mode 100644 collects/framework/private/follow-log.rkt diff --git a/collects/framework/private/follow-log.rkt b/collects/framework/private/follow-log.rkt new file mode 100644 index 0000000000..e45f9354a9 --- /dev/null +++ b/collects/framework/private/follow-log.rkt @@ -0,0 +1,151 @@ +#lang racket/base + +(require racket/list + racket/class + racket/match + racket/pretty + racket/gui/base + framework/private/logging-timer) + +#| + +This file sets up a log receiver and then +starts up DrRacket. It catches log messages and +organizes them on event boundaries, printing +out the ones that take the longest +(possibly dropping those where a gc occurs) + +The result shows, for each gui event, the +log messages that occured during its dynamic +extent as well as the number of milliseconds +from the start of the gui event before the +log message was reported. + +|# + + +(define lr (make-log-receiver (current-logger) + 'debug 'racket/engine + 'debug 'GC + 'debug 'gui-event + 'debug 'framework/colorer + 'debug 'timeline)) + +(define top-n-events 50) +(define drop-gc? #t) +(define start-right-away? #f) + +(define done-chan (make-channel)) +(define start-chan (make-channel)) +(void + (thread + (λ () + (let loop () + (sync start-chan) + (let loop ([events '()]) + (sync + (handle-evt + lr + (λ (info) + (loop (cons info events)))) + (handle-evt + done-chan + (λ (resp-chan) + (channel-put resp-chan events))))) + (loop))))) + +(define controller-frame-eventspace (make-eventspace)) +(define f (parameterize ([current-eventspace controller-frame-eventspace]) + (new frame% [label "Log Follower"]))) +(define sb (new button% [label "Start"] [parent f] + [callback + (λ (_1 _2) + (sb-callback))])) +(define db (new button% [label "Stop && Dump"] [parent f] [enabled #f] + [callback + (λ (_1 _2) + (define resp (make-channel)) + (channel-put done-chan resp) + (show-results (channel-get resp)) + (send db enable #f) + (send sb enable #t))])) +(define (sb-callback) + (send sb enable #f) + (send db enable #t) + (channel-put start-chan #t)) +(send f show #t) + +(struct gui-event (start end name) #:prefab) + +(define (show-results evts) + (define gui-events (filter (λ (x) + (define i (vector-ref x 2)) + (and (gui-event? i) + (number? (gui-event-end i)))) + evts)) + (define interesting-gui-events + (take (sort gui-events > #:key (λ (x) + (define i (vector-ref x 2)) + (- (gui-event-end i) + (gui-event-start i)))) + top-n-events)) + + (define with-other-events + (for/list ([gui-evt (in-list interesting-gui-events)]) + (match (vector-ref gui-evt 2) + [(gui-event start end name) + (define in-the-middle + (append (map (λ (x) (list (list 'δ (- (get-start-time x) start)) x)) + (sort + (filter (λ (x) (and (not (gui-event? (vector-ref x 2))) + (<= start (get-start-time x) end))) + evts) + < + #:key get-start-time)) + (list (list (list 'δ (- end start)) 'end-of-gui-event)))) + (list* (- end start) + gui-evt + in-the-middle)]))) + + (define (has-a-gc-event? x) + (define in-the-middle (cddr x)) + (ormap (λ (x) + (and (vector? (list-ref x 1)) + (gc-info? (vector-ref (list-ref x 1) 2)))) + in-the-middle)) + + (pretty-print + (if drop-gc? + (filter (λ (x) (not (has-a-gc-event? x))) + with-other-events) + with-other-events))) + +(struct gc-info (major? pre-amount pre-admin-amount code-amount + post-amount post-admin-amount + start-process-time end-process-time + start-time end-time) + #:prefab) +(struct engine-info (msec name) #:prefab) + +(define (get-start-time x) + (cond + [(gc-info? (vector-ref x 2)) + (gc-info-start-time (vector-ref x 2))] + [(engine-info? (vector-ref x 2)) + (engine-info-msec (vector-ref x 2))] + [(regexp-match #rx"framework" (vector-ref x 1)) + (vector-ref x 2)] + [(timeline-info? (vector-ref x 2)) + (timeline-info-milliseconds (vector-ref x 2))] + [else + (unless (regexp-match #rx"^GC: 0:MST @" (vector-ref x 1)) + (eprintf "unk: ~s\n" x)) + 0])) + + +(module+ main + (when start-right-away? + (parameterize ([current-eventspace controller-frame-eventspace]) + (queue-callback sb-callback))) + (dynamic-require 'drracket #f)) + diff --git a/collects/framework/private/frame.rkt b/collects/framework/private/frame.rkt index 215dab0786..1464406f3a 100644 --- a/collects/framework/private/frame.rkt +++ b/collects/framework/private/frame.rkt @@ -796,9 +796,14 @@ [ec (new position-canvas% [parent panel] [button-up - (λ () - (collect-garbage) - (update-memory-text))] + (λ (evt) + (cond + [(or (send evt get-alt-down) + (send evt get-control-down)) + (dynamic-require 'framework/private/follow-log #f)] + [else + (collect-garbage) + (update-memory-text)]))] [init-width "99.99 MB"])]) (set! memory-canvases (cons ec memory-canvases)) (update-memory-text) @@ -890,6 +895,7 @@ (inherit min-client-height min-client-width get-dc get-client-size refresh) (init init-width) (init-field [button-up #f]) + (init-field [char-typed void]) (define str "") (define/public (set-str _str) (set! str _str) @@ -913,7 +919,11 @@ (let-values ([(cw ch) (get-client-size)]) (when (and (<= (send evt get-x) cw) (<= (send evt get-y) ch)) - (button-up)))))) + (if (procedure-arity-includes? button-up 1) + (button-up evt) + (button-up))))))) + (define/override (on-char evt) + (char-typed evt)) (super-new (style '(transparent no-focus))) (let ([dc (get-dc)]) (let-values ([(_1 th _2 _3) (send dc get-text-extent str)]) From fb3a95f9d524ea43893c1f652ce15e8fac300de2 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Wed, 7 Nov 2012 15:32:44 -0700 Subject: [PATCH 210/221] Replace fprintf with explicit display for performance. Replace fprintf with explicit display for performance. --- collects/xml/private/xexpr.rkt | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/collects/xml/private/xexpr.rkt b/collects/xml/private/xexpr.rkt index dfdec61a78..549e3d010b 100644 --- a/collects/xml/private/xexpr.rkt +++ b/collects/xml/private/xexpr.rkt @@ -135,8 +135,12 @@ (display name out) ; Write attributes (for ([att (in-list attrs)]) - (fprintf out " ~a=\"~a\"" (car att) - (escape (cadr att) escape-attribute-table))) + (display " " out) + (display (car att) out) + (display "=" out) + (display "\"" out) + (display (escape (cadr att) escape-attribute-table) out) + (display "\"" out)) ; Write end of opening tag (if (and (null? content) (let ([short (empty-tag-shorthand)]) @@ -159,9 +163,13 @@ (display (escape x escape-table) out)] ; Entities [(symbol? x) - (fprintf out "&~a;" x)] + (display "&" out) + (display x out) + (display ";" out)] [(valid-char? x) - (fprintf out "&#~a;" x)] + (display "&#" out) + (display x out) + (display ";" out)] ; Embedded XML [(cdata? x) (write-xml-cdata x 0 void out)] From 6d189287a9e5c71dc5a56395d279fe9dbd5d2e60 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Wed, 7 Nov 2012 15:39:27 -0700 Subject: [PATCH 211/221] Add let loop for recursion and slight performance increase. --- collects/xml/private/xexpr.rkt | 115 +++++++++++++++++---------------- 1 file changed, 58 insertions(+), 57 deletions(-) diff --git a/collects/xml/private/xexpr.rkt b/collects/xml/private/xexpr.rkt index 549e3d010b..697f630193 100644 --- a/collects/xml/private/xexpr.rkt +++ b/collects/xml/private/xexpr.rkt @@ -120,60 +120,61 @@ [write-xexpr (->* (xexpr/c) (output-port?) void)] ) (define (write-xexpr x [out (current-output-port)]) - (cond - ; Element - [(cons? x) - (define name (car x)) - (define-values (attrs content) - (if (and (pair? (cdr x)) - (or (null? (cadr x)) - (and (pair? (cadr x)) (pair? (caadr x))))) - (values (cadr x) (cddr x)) - (values null (cdr x)))) - ; Write opening tag - (display "<" out) - (display name out) - ; Write attributes - (for ([att (in-list attrs)]) - (display " " out) - (display (car att) out) - (display "=" out) - (display "\"" out) - (display (escape (cadr att) escape-attribute-table) out) - (display "\"" out)) - ; Write end of opening tag - (if (and (null? content) - (let ([short (empty-tag-shorthand)]) - (case short - [(always) #t] - [(never) #f] - [else (memq (lowercase-symbol name) short)]))) - (display " />" out) - (begin - (display ">" out) - ; Write body - (for ([xe (in-list content)]) - (write-xexpr xe out)) - ; Write closing tag - (display "" out)))] - ; PCData - [(string? x) - (display (escape x escape-table) out)] - ; Entities - [(symbol? x) - (display "&" out) - (display x out) - (display ";" out)] - [(valid-char? x) - (display "&#" out) - (display x out) - (display ";" out)] - ; Embedded XML - [(cdata? x) - (write-xml-cdata x 0 void out)] - [(comment? x) - (write-xml-comment x 0 void out)] - [(p-i? x) - (write-xml-p-i x 0 void out)])) + (let loop ([x x]) + (cond + ; Element + [(cons? x) + (define name (car x)) + (define-values (attrs content) + (if (and (pair? (cdr x)) + (or (null? (cadr x)) + (and (pair? (cadr x)) (pair? (caadr x))))) + (values (cadr x) (cddr x)) + (values null (cdr x)))) + ; Write opening tag + (display "<" out) + (display name out) + ; Write attributes + (for ([att (in-list attrs)]) + (display " " out) + (display (car att) out) + (display "=" out) + (display "\"" out) + (display (escape (cadr att) escape-attribute-table) out) + (display "\"" out)) + ; Write end of opening tag + (if (and (null? content) + (let ([short (empty-tag-shorthand)]) + (case short + [(always) #t] + [(never) #f] + [else (memq (lowercase-symbol name) short)]))) + (display " />" out) + (begin + (display ">" out) + ; Write body + (for ([xe (in-list content)]) + (loop xe)) + ; Write closing tag + (display "" out)))] + ; PCData + [(string? x) + (display (escape x escape-table) out)] + ; Entities + [(symbol? x) + (display "&" out) + (display x out) + (display ";" out)] + [(valid-char? x) + (display "&#" out) + (display x out) + (display ";" out)] + ; Embedded XML + [(cdata? x) + (write-xml-cdata x 0 void out)] + [(comment? x) + (write-xml-comment x 0 void out)] + [(p-i? x) + (write-xml-p-i x 0 void out)]))) From 40116eb16dc351a94507cb9e41e42516dd711f32 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Wed, 7 Nov 2012 15:42:26 -0700 Subject: [PATCH 212/221] Lift out empty-tag-shorthand parameter lookup out of the hot spot. --- collects/xml/private/xexpr.rkt | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/xml/private/xexpr.rkt b/collects/xml/private/xexpr.rkt index 697f630193..67112dbaa2 100644 --- a/collects/xml/private/xexpr.rkt +++ b/collects/xml/private/xexpr.rkt @@ -120,6 +120,7 @@ [write-xexpr (->* (xexpr/c) (output-port?) void)] ) (define (write-xexpr x [out (current-output-port)]) + (define short (empty-tag-shorthand)) (let loop ([x x]) (cond ; Element @@ -144,11 +145,10 @@ (display "\"" out)) ; Write end of opening tag (if (and (null? content) - (let ([short (empty-tag-shorthand)]) - (case short + (case short [(always) #t] [(never) #f] - [else (memq (lowercase-symbol name) short)]))) + [else (memq (lowercase-symbol name) short)])) (display " />" out) (begin (display ">" out) From 5cb2f3eb58a48c22bd4e56bdfd89e0591232295e Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Wed, 7 Nov 2012 16:03:04 -0700 Subject: [PATCH 213/221] Avoid regexp-replace* unless the string really contains escapable characters. --- collects/xml/private/writer.rkt | 8 ++++++++ collects/xml/private/xexpr.rkt | 4 ++-- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/collects/xml/private/writer.rkt b/collects/xml/private/writer.rkt index 7443ccf236..4b06e7611f 100644 --- a/collects/xml/private/writer.rkt +++ b/collects/xml/private/writer.rkt @@ -168,7 +168,15 @@ (define (escape x table) (regexp-replace* table x replace-escaped)) +(define (display/escape x table out) + (cond [(regexp-match table x) + (display (escape x table) out)] + [else + (display x out)])) + + (provide escape + display/escape escape-table escape-attribute-table lowercase-symbol diff --git a/collects/xml/private/xexpr.rkt b/collects/xml/private/xexpr.rkt index 67112dbaa2..349a1a60df 100644 --- a/collects/xml/private/xexpr.rkt +++ b/collects/xml/private/xexpr.rkt @@ -141,7 +141,7 @@ (display (car att) out) (display "=" out) (display "\"" out) - (display (escape (cadr att) escape-attribute-table) out) + (display/escape (cadr att) escape-attribute-table out) (display "\"" out)) ; Write end of opening tag (if (and (null? content) @@ -161,7 +161,7 @@ (display ">" out)))] ; PCData [(string? x) - (display (escape x escape-table) out)] + (display/escape x escape-table out)] ; Entities [(symbol? x) (display "&" out) From d20f9a88666dd981c1836593d5b932dc22b18914 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 7 Nov 2012 21:51:36 -0600 Subject: [PATCH 214/221] should have been removed in an earlier commit, but I wrote the wrong git commandline --- collects/drracket/private/follow-log.rkt | 149 ----------------------- 1 file changed, 149 deletions(-) delete mode 100644 collects/drracket/private/follow-log.rkt diff --git a/collects/drracket/private/follow-log.rkt b/collects/drracket/private/follow-log.rkt deleted file mode 100644 index bc3f52efc0..0000000000 --- a/collects/drracket/private/follow-log.rkt +++ /dev/null @@ -1,149 +0,0 @@ -#lang racket/base - -(require racket/list - racket/class - racket/match - racket/pretty - racket/gui/base - framework/private/logging-timer) - -#| - -This file sets up a log receiver and then -starts up DrRacket. It catches log messages and -organizes them on event boundaries, printing -out the ones that take the longest -(possibly dropping those where a gc occurs) - -The result shows, for each gui event, the -log messages that occured during its dynamic -extent as well as the number of milliseconds -from the start of the gui event before the -log message was reported. - -|# - - -(define lr (make-log-receiver (current-logger) - 'debug 'racket/engine - 'debug 'GC - 'debug 'gui-event - 'debug 'framework/colorer - 'debug 'timeline)) - -(define top-n-events 50) -(define drop-gc? #t) -(define start-right-away? #f) - -(define done-chan (make-channel)) -(define start-chan (make-channel)) -(void - (thread - (λ () - (let loop () - (sync start-chan) - (let loop ([events '()]) - (sync - (handle-evt - lr - (λ (info) - (loop (cons info events)))) - (handle-evt - done-chan - (λ (resp-chan) - (channel-put resp-chan events))))) - (loop))))) - -(define controller-frame-eventspace (make-eventspace)) -(define f (parameterize ([current-eventspace controller-frame-eventspace]) - (new frame% [label ""]))) -(define sb (new button% [label "Start"] [parent f] - [callback - (λ (_1 _2) - (sb-callback))])) -(define db (new button% [label "Stop && Dump"] [parent f] [enabled #f] - [callback - (λ (_1 _2) - (define resp (make-channel)) - (channel-put done-chan resp) - (show-results (channel-get resp)) - (send db enable #f) - (send sb enable #t))])) -(define (sb-callback) - (send sb enable #f) - (send db enable #t) - (channel-put start-chan #t)) -(send f show #t) - -(struct gui-event (start end name) #:prefab) - -(define (show-results evts) - (define gui-events (filter (λ (x) - (define i (vector-ref x 2)) - (and (gui-event? i) - (number? (gui-event-end i)))) - evts)) - (define interesting-gui-events - (take (sort gui-events > #:key (λ (x) - (define i (vector-ref x 2)) - (- (gui-event-end i) - (gui-event-start i)))) - top-n-events)) - - (define with-other-events - (for/list ([gui-evt (in-list interesting-gui-events)]) - (match (vector-ref gui-evt 2) - [(gui-event start end name) - (define in-the-middle - (append (map (λ (x) (list (list 'δ (- (get-start-time x) start)) x)) - (sort - (filter (λ (x) (and (not (gui-event? (vector-ref x 2))) - (<= start (get-start-time x) end))) - evts) - < - #:key get-start-time)) - (list (list (list 'δ (- end start)) 'end-of-gui-event)))) - (list* (- end start) - gui-evt - in-the-middle)]))) - - (define (has-a-gc-event? x) - (define in-the-middle (cddr x)) - (ormap (λ (x) - (and (vector? (list-ref x 1)) - (gc-info? (vector-ref (list-ref x 1) 2)))) - in-the-middle)) - - (pretty-print - (if drop-gc? - (filter (λ (x) (not (has-a-gc-event? x))) - with-other-events) - with-other-events))) - -(struct gc-info (major? pre-amount pre-admin-amount code-amount - post-amount post-admin-amount - start-process-time end-process-time - start-time end-time) - #:prefab) -(struct engine-info (msec name) #:prefab) - -(define (get-start-time x) - (cond - [(gc-info? (vector-ref x 2)) - (gc-info-start-time (vector-ref x 2))] - [(engine-info? (vector-ref x 2)) - (engine-info-msec (vector-ref x 2))] - [(regexp-match #rx"framework" (vector-ref x 1)) - (vector-ref x 2)] - [(timeline-info? (vector-ref x 2)) - (timeline-info-milliseconds (vector-ref x 2))] - [else - (unless (regexp-match #rx"^GC: 0:MST @" (vector-ref x 1)) - (eprintf "unk: ~s\n" x)) - 0])) - - -(when start-right-away? - (parameterize ([current-eventspace controller-frame-eventspace]) - (queue-callback sb-callback))) -(dynamic-require 'drracket #f) From 5589bcb2783716ca4c93bb9b571bd846a7d3c0b2 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 8 Nov 2012 03:30:18 -0500 Subject: [PATCH 215/221] New Racket version 5.3.1.5. --- 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.manifest | 2 +- src/worksp/racket/racket.rc | 8 ++++---- src/worksp/starters/start.rc | 8 ++++---- 7 files changed, 21 insertions(+), 21 deletions(-) diff --git a/src/worksp/gracket/gracket.manifest b/src/worksp/gracket/gracket.manifest index be453af939..c9e8b1af11 100644 --- a/src/worksp/gracket/gracket.manifest +++ b/src/worksp/gracket/gracket.manifest @@ -1,6 +1,6 @@ - diff --git a/src/worksp/gracket/gracket.rc b/src/worksp/gracket/gracket.rc index 2a01d35cc1..be3c764846 100644 --- a/src/worksp/gracket/gracket.rc +++ b/src/worksp/gracket/gracket.rc @@ -11,8 +11,8 @@ APPLICATION ICON DISCARDABLE "gracket.ico" // VS_VERSION_INFO VERSIONINFO - FILEVERSION 5,3,1,4 - PRODUCTVERSION 5,3,1,4 + FILEVERSION 5,3,1,5 + PRODUCTVERSION 5,3,1,5 FILEFLAGSMASK 0x3fL #ifdef _DEBUG FILEFLAGS 0x1L @@ -30,11 +30,11 @@ BEGIN VALUE "CompanyName", "PLT Scheme Inc.\0" VALUE "FileDescription", "Racket GUI application\0" VALUE "InternalName", "GRacket\0" - VALUE "FileVersion", "5, 3, 1, 4\0" + VALUE "FileVersion", "5, 3, 1, 5\0" VALUE "LegalCopyright", "Copyright 1995-2012\0" VALUE "OriginalFilename", "GRacket.exe\0" VALUE "ProductName", "Racket\0" - VALUE "ProductVersion", "5, 3, 1, 4\0" + VALUE "ProductVersion", "5, 3, 1, 5\0" END END BLOCK "VarFileInfo" diff --git a/src/worksp/mzcom/mzcom.rc b/src/worksp/mzcom/mzcom.rc index 49894811a4..707e542cfe 100644 --- a/src/worksp/mzcom/mzcom.rc +++ b/src/worksp/mzcom/mzcom.rc @@ -53,8 +53,8 @@ END // VS_VERSION_INFO VERSIONINFO - FILEVERSION 5,3,1,4 - PRODUCTVERSION 5,3,1,4 + FILEVERSION 5,3,1,5 + PRODUCTVERSION 5,3,1,5 FILEFLAGSMASK 0x3fL #ifdef _DEBUG FILEFLAGS 0x1L @@ -70,12 +70,12 @@ BEGIN BLOCK "040904b0" BEGIN VALUE "FileDescription", "MzCOM Module" - VALUE "FileVersion", "5, 3, 1, 4" + VALUE "FileVersion", "5, 3, 1, 5" VALUE "InternalName", "MzCOM" VALUE "LegalCopyright", "Copyright 2000-2012 PLT (Paul Steckler)" VALUE "OriginalFilename", "MzCOM.EXE" VALUE "ProductName", "MzCOM Module" - VALUE "ProductVersion", "5, 3, 1, 4" + VALUE "ProductVersion", "5, 3, 1, 5" END END BLOCK "VarFileInfo" diff --git a/src/worksp/mzcom/mzobj.rgs b/src/worksp/mzcom/mzobj.rgs index 53dd11f37d..fb73d24bad 100644 --- a/src/worksp/mzcom/mzobj.rgs +++ b/src/worksp/mzcom/mzobj.rgs @@ -1,19 +1,19 @@ HKCR { - MzCOM.MzObj.5.3.1.4 = s 'MzObj Class' + MzCOM.MzObj.5.3.1.5 = s 'MzObj Class' { CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}' } MzCOM.MzObj = s 'MzObj Class' { CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}' - CurVer = s 'MzCOM.MzObj.5.3.1.4' + CurVer = s 'MzCOM.MzObj.5.3.1.5' } NoRemove CLSID { ForceRemove {A3B0AF9E-2AB0-11D4-B6D2-0060089002FE} = s 'MzObj Class' { - ProgID = s 'MzCOM.MzObj.5.3.1.4' + ProgID = s 'MzCOM.MzObj.5.3.1.5' VersionIndependentProgID = s 'MzCOM.MzObj' ForceRemove 'Programmable' LocalServer32 = s '%MODULE%' diff --git a/src/worksp/racket/racket.manifest b/src/worksp/racket/racket.manifest index 47847c2b36..1e773674af 100644 --- a/src/worksp/racket/racket.manifest +++ b/src/worksp/racket/racket.manifest @@ -1,6 +1,6 @@ - diff --git a/src/worksp/racket/racket.rc b/src/worksp/racket/racket.rc index 8662cd5d4d..cec69a26dd 100644 --- a/src/worksp/racket/racket.rc +++ b/src/worksp/racket/racket.rc @@ -11,8 +11,8 @@ APPLICATION ICON DISCARDABLE "racket.ico" // VS_VERSION_INFO VERSIONINFO - FILEVERSION 5,3,1,4 - PRODUCTVERSION 5,3,1,4 + FILEVERSION 5,3,1,5 + PRODUCTVERSION 5,3,1,5 FILEFLAGSMASK 0x3fL #ifdef _DEBUG FILEFLAGS 0x1L @@ -30,11 +30,11 @@ BEGIN VALUE "CompanyName", "PLT Scheme Inc.\0" VALUE "FileDescription", "Racket application\0" VALUE "InternalName", "Racket\0" - VALUE "FileVersion", "5, 3, 1, 4\0" + VALUE "FileVersion", "5, 3, 1, 5\0" VALUE "LegalCopyright", "Copyright 1995-2012\0" VALUE "OriginalFilename", "racket.exe\0" VALUE "ProductName", "Racket\0" - VALUE "ProductVersion", "5, 3, 1, 4\0" + VALUE "ProductVersion", "5, 3, 1, 5\0" END END BLOCK "VarFileInfo" diff --git a/src/worksp/starters/start.rc b/src/worksp/starters/start.rc index 6473fddb25..7685133da9 100644 --- a/src/worksp/starters/start.rc +++ b/src/worksp/starters/start.rc @@ -22,8 +22,8 @@ APPLICATION ICON DISCARDABLE "mzstart.ico" // VS_VERSION_INFO VERSIONINFO - FILEVERSION 5,3,1,4 - PRODUCTVERSION 5,3,1,4 + FILEVERSION 5,3,1,5 + PRODUCTVERSION 5,3,1,5 FILEFLAGSMASK 0x3fL #ifdef _DEBUG FILEFLAGS 0x1L @@ -45,7 +45,7 @@ BEGIN #ifdef MZSTART VALUE "FileDescription", "Racket Launcher\0" #endif - VALUE "FileVersion", "5, 3, 1, 4\0" + VALUE "FileVersion", "5, 3, 1, 5\0" #ifdef MRSTART VALUE "InternalName", "mrstart\0" #endif @@ -60,7 +60,7 @@ BEGIN VALUE "OriginalFilename", "MzStart.exe\0" #endif VALUE "ProductName", "Racket\0" - VALUE "ProductVersion", "5, 3, 1, 4\0" + VALUE "ProductVersion", "5, 3, 1, 5\0" END END BLOCK "VarFileInfo" From fae660b0e43d4fbc2074a01c73ad76cc956de993 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 7 Nov 2012 21:29:58 -0700 Subject: [PATCH 216/221] Release Planet 2 (beta) This was developed in a different repository, so the history will be archived there: https://github.com/jeapostrophe/galaxy --- collects/meta/planet2-index/basic/main.rkt | 44 + .../meta/planet2-index/official/.gitignore | 1 + .../meta/planet2-index/official/gravatar.rkt | 52 ++ collects/meta/planet2-index/official/main.rkt | 652 ++++++++++++++ .../official/static/sorttable.js | 515 +++++++++++ .../planet2-index/official/static/style.css | 148 ++++ .../planet2-index/planet-compat/.gitignore | 1 + .../meta/planet2-index/planet-compat/info.rkt | 3 + .../meta/planet2-index/planet-compat/main.rkt | 395 +++++++++ collects/meta/planet2-index/sync.sh | 12 + collects/meta/props | 6 + collects/planet2/.gitignore | 1 + collects/planet2/commands.rkt | 101 +++ collects/planet2/info.rkt | 7 + collects/planet2/lib.rkt | 809 ++++++++++++++++++ collects/planet2/main.rkt | 91 ++ collects/planet2/raco.rkt | 2 + collects/planet2/scribblings/planet2.scrbl | 667 +++++++++++++++ collects/planet2/util-plt.rkt | 46 + collects/planet2/util.rkt | 68 ++ collects/tests/planet2/info.rkt | 3 + collects/tests/planet2/shelly.rkt | 134 +++ collects/tests/planet2/test-pkgs/.gitignore | 5 + .../test-pkgs/pkg-a-first/pkg-a/main.rkt | 3 + .../test-pkgs/pkg-a-second/pkg-a/main.rkt | 4 + .../test-pkgs/pkg-a-third/pkg-a/main.rkt | 3 + .../test-pkgs/pkg-a-third/pkg-b/main.rkt | 2 + .../test-pkgs/pkg-b-first/pkg-b/main.rkt | 3 + .../test-pkgs/pkg-b-second/METADATA.rktd | 1 + .../pkg-b-second/pkg-b/contains-dep.rkt | 9 + .../test-pkgs/pkg-b-second/pkg-b/main.rkt | 3 + .../planet2-test1/conflict.rkt | 2 + .../planet2-test1/main.rkt | 4 + .../planet2-test1/conflict.rkt | 2 + .../planet2-test1/main.rkt | 4 + .../planet2-test1/update.rkt | 2 + .../planet2-test1-not-conflict/README | 1 + .../test-pkgs/planet2-test1-staging/a.rkt | 4 + .../planet2-test1/conflict.rkt | 2 + .../planet2-test1-v2/planet2-test1/main.rkt | 4 + .../planet2-test1-v2/planet2-test1/update.rkt | 2 + .../planet2/test-pkgs/planet2-test1/README | 1 + .../planet2-test1/planet2-test1/conflict.rkt | 2 + .../planet2-test1/planet2-test1/main.rkt | 4 + .../planet2-test1/planet2-test1/update.rkt | 2 + .../test-pkgs/planet2-test2/METADATA.rktd | 1 + .../planet2-test2/contains-dep.rkt | 3 + .../planet2-test2/planet2-test2/main.rkt | 4 + .../test-pkgs/racket-conflict/racket/list.rkt | 2 + .../test-pkgs/raco-pkg/raco-pkg/info.rkt | 5 + .../test-pkgs/raco-pkg/raco-pkg/main.rkt | 3 + collects/tests/planet2/test.rkt | 42 + collects/tests/planet2/tests-basic.rkt | 25 + collects/tests/planet2/tests-checksums.rkt | 72 ++ collects/tests/planet2/tests-config.rkt | 11 + collects/tests/planet2/tests-conflicts.rkt | 61 ++ collects/tests/planet2/tests-create.rkt | 59 ++ collects/tests/planet2/tests-deps.rkt | 119 +++ collects/tests/planet2/tests-install.rkt | 98 +++ collects/tests/planet2/tests-locking.rkt | 42 + collects/tests/planet2/tests-main-server.rkt | 10 + collects/tests/planet2/tests-network.rkt | 21 + collects/tests/planet2/tests-overwrite.rkt | 16 + collects/tests/planet2/tests-planet.rkt | 22 + collects/tests/planet2/tests-raco.rkt | 30 + collects/tests/planet2/tests-remove.rkt | 72 ++ collects/tests/planet2/tests-update-auto.rkt | 71 ++ collects/tests/planet2/tests-update-deps.rkt | 110 +++ collects/tests/planet2/tests-update.rkt | 100 +++ collects/tests/planet2/util.rkt | 150 ++++ 70 files changed, 4976 insertions(+) create mode 100644 collects/meta/planet2-index/basic/main.rkt create mode 100644 collects/meta/planet2-index/official/.gitignore create mode 100644 collects/meta/planet2-index/official/gravatar.rkt create mode 100644 collects/meta/planet2-index/official/main.rkt create mode 100644 collects/meta/planet2-index/official/static/sorttable.js create mode 100644 collects/meta/planet2-index/official/static/style.css create mode 100644 collects/meta/planet2-index/planet-compat/.gitignore create mode 100644 collects/meta/planet2-index/planet-compat/info.rkt create mode 100644 collects/meta/planet2-index/planet-compat/main.rkt create mode 100755 collects/meta/planet2-index/sync.sh create mode 100644 collects/planet2/.gitignore create mode 100644 collects/planet2/commands.rkt create mode 100644 collects/planet2/info.rkt create mode 100644 collects/planet2/lib.rkt create mode 100644 collects/planet2/main.rkt create mode 100644 collects/planet2/raco.rkt create mode 100644 collects/planet2/scribblings/planet2.scrbl create mode 100644 collects/planet2/util-plt.rkt create mode 100644 collects/planet2/util.rkt create mode 100644 collects/tests/planet2/info.rkt create mode 100644 collects/tests/planet2/shelly.rkt create mode 100644 collects/tests/planet2/test-pkgs/.gitignore create mode 100644 collects/tests/planet2/test-pkgs/pkg-a-first/pkg-a/main.rkt create mode 100644 collects/tests/planet2/test-pkgs/pkg-a-second/pkg-a/main.rkt create mode 100644 collects/tests/planet2/test-pkgs/pkg-a-third/pkg-a/main.rkt create mode 100644 collects/tests/planet2/test-pkgs/pkg-a-third/pkg-b/main.rkt create mode 100644 collects/tests/planet2/test-pkgs/pkg-b-first/pkg-b/main.rkt create mode 100644 collects/tests/planet2/test-pkgs/pkg-b-second/METADATA.rktd create mode 100644 collects/tests/planet2/test-pkgs/pkg-b-second/pkg-b/contains-dep.rkt create mode 100644 collects/tests/planet2/test-pkgs/pkg-b-second/pkg-b/main.rkt create mode 100644 collects/tests/planet2/test-pkgs/planet2-test1-conflict/planet2-test1/conflict.rkt create mode 100644 collects/tests/planet2/test-pkgs/planet2-test1-conflict/planet2-test1/main.rkt create mode 100644 collects/tests/planet2/test-pkgs/planet2-test1-manifest-error/planet2-test1/conflict.rkt create mode 100644 collects/tests/planet2/test-pkgs/planet2-test1-manifest-error/planet2-test1/main.rkt create mode 100644 collects/tests/planet2/test-pkgs/planet2-test1-manifest-error/planet2-test1/update.rkt create mode 100644 collects/tests/planet2/test-pkgs/planet2-test1-not-conflict/README create mode 100644 collects/tests/planet2/test-pkgs/planet2-test1-staging/a.rkt create mode 100644 collects/tests/planet2/test-pkgs/planet2-test1-v2/planet2-test1/conflict.rkt create mode 100644 collects/tests/planet2/test-pkgs/planet2-test1-v2/planet2-test1/main.rkt create mode 100644 collects/tests/planet2/test-pkgs/planet2-test1-v2/planet2-test1/update.rkt create mode 100644 collects/tests/planet2/test-pkgs/planet2-test1/README create mode 100644 collects/tests/planet2/test-pkgs/planet2-test1/planet2-test1/conflict.rkt create mode 100644 collects/tests/planet2/test-pkgs/planet2-test1/planet2-test1/main.rkt create mode 100644 collects/tests/planet2/test-pkgs/planet2-test1/planet2-test1/update.rkt create mode 100644 collects/tests/planet2/test-pkgs/planet2-test2/METADATA.rktd create mode 100644 collects/tests/planet2/test-pkgs/planet2-test2/planet2-test2/contains-dep.rkt create mode 100644 collects/tests/planet2/test-pkgs/planet2-test2/planet2-test2/main.rkt create mode 100644 collects/tests/planet2/test-pkgs/racket-conflict/racket/list.rkt create mode 100644 collects/tests/planet2/test-pkgs/raco-pkg/raco-pkg/info.rkt create mode 100644 collects/tests/planet2/test-pkgs/raco-pkg/raco-pkg/main.rkt create mode 100644 collects/tests/planet2/test.rkt create mode 100644 collects/tests/planet2/tests-basic.rkt create mode 100644 collects/tests/planet2/tests-checksums.rkt create mode 100644 collects/tests/planet2/tests-config.rkt create mode 100644 collects/tests/planet2/tests-conflicts.rkt create mode 100644 collects/tests/planet2/tests-create.rkt create mode 100644 collects/tests/planet2/tests-deps.rkt create mode 100644 collects/tests/planet2/tests-install.rkt create mode 100644 collects/tests/planet2/tests-locking.rkt create mode 100644 collects/tests/planet2/tests-main-server.rkt create mode 100644 collects/tests/planet2/tests-network.rkt create mode 100644 collects/tests/planet2/tests-overwrite.rkt create mode 100644 collects/tests/planet2/tests-planet.rkt create mode 100644 collects/tests/planet2/tests-raco.rkt create mode 100644 collects/tests/planet2/tests-remove.rkt create mode 100644 collects/tests/planet2/tests-update-auto.rkt create mode 100644 collects/tests/planet2/tests-update-deps.rkt create mode 100644 collects/tests/planet2/tests-update.rkt create mode 100644 collects/tests/planet2/util.rkt diff --git a/collects/meta/planet2-index/basic/main.rkt b/collects/meta/planet2-index/basic/main.rkt new file mode 100644 index 0000000000..f864ae269d --- /dev/null +++ b/collects/meta/planet2-index/basic/main.rkt @@ -0,0 +1,44 @@ +#lang racket/base +(require racket/list + racket/contract + web-server/http + web-server/dispatch) + +(define (response/sexpr v) + (response 200 #"Okay" (current-seconds) + #"text/s-expr" empty + (λ (op) (write v op)))) + +(define (planet2-index/basic get-pkgs pkg-name->info) + (define (write-info req pkg-name) + (response/sexpr (pkg-name->info pkg-name))) + (define (display-info req pkg-name) + (define info (pkg-name->info pkg-name)) + (response/xexpr + `(html + (body + (h1 ,pkg-name) + (p (a ([href ,(hash-ref info 'source)]) ,(hash-ref info 'source))) + (p ,(hash-ref info 'checksum)))))) + (define (list-pkgs req) + (response/xexpr + `(html + (body + (table + (tr (th "Package")) + ,@(for/list ([n (in-list (sort (get-pkgs) string<=?))]) + `(tr + (td (a ([href ,(get-url display-info n)]) ,n))))))))) + (define-values (dispatch get-url) + (dispatch-rules + [() list-pkgs] + [("") list-pkgs] + [("pkg" (string-arg) "display") display-info] + [("pkg" (string-arg)) write-info])) + dispatch) + +(provide/contract + [planet2-index/basic + (-> (-> (listof string?)) + (-> string? (hash/c symbol? any/c)) + (-> request? response?))]) diff --git a/collects/meta/planet2-index/official/.gitignore b/collects/meta/planet2-index/official/.gitignore new file mode 100644 index 0000000000..cd3d01855c --- /dev/null +++ b/collects/meta/planet2-index/official/.gitignore @@ -0,0 +1 @@ +/root diff --git a/collects/meta/planet2-index/official/gravatar.rkt b/collects/meta/planet2-index/official/gravatar.rkt new file mode 100644 index 0000000000..067243cfb7 --- /dev/null +++ b/collects/meta/planet2-index/official/gravatar.rkt @@ -0,0 +1,52 @@ +#lang racket/base +(require racket/string + racket/contract + xml + xml/path + racket/port + net/url + file/md5 + planet2/util) + +(define (gravatar-hash email) + (bytes->string/utf-8 + (md5 + (string-downcase + (string-trim email))))) + +(module+ test + (require rackunit) + (check-equal? (gravatar-hash "MyEmailAddress@example.com ") + "0bc83cb571cd1c50ba6f3e8a78ef1346") + (check-equal? (gravatar-hash "MyEmailAddress@example.com ") + (gravatar-hash " MyEmailAddress@example.com "))) + +(define (gravatar-image-url email) + (format "https://secure.gravatar.com/avatar/~a.jpg?d=retro" + (gravatar-hash email))) + +(define (gravatar-profile email) + (parameterize ([collapse-whitespace #t] + [xexpr-drop-empty-attributes #t]) + (call/input-url+200 + (string->url + (format "http://www.gravatar.com/~a.xml" + (gravatar-hash email))) + (compose string->xexpr port->string)))) + +(define (gravatar-display-name email) + (define profile (gravatar-profile email)) + (and profile + (se-path* '(response entry displayName) + profile))) + +(module+ test + (check-equal? (gravatar-display-name "jay.mccarthy@gmail.com") + "Jay McCarthy") + (check-equal? (gravatar-display-name "jay@racket-lang.org") + #f)) + +(provide/contract + [gravatar-display-name (-> string? (or/c string? false/c))] + [gravatar-profile (-> string? xexpr?)] + [gravatar-image-url (-> string? string?)]) diff --git a/collects/meta/planet2-index/official/main.rkt b/collects/meta/planet2-index/official/main.rkt new file mode 100644 index 0000000000..daea39eff8 --- /dev/null +++ b/collects/meta/planet2-index/official/main.rkt @@ -0,0 +1,652 @@ +#lang racket/base +(require web-server/http + web-server/servlet-env + racket/file + racket/function + racket/runtime-path + web-server/dispatch + planet2/util + racket/match + racket/package + racket/system + racket/date + racket/string + web-server/servlet + web-server/formlets + racket/bool + racket/list + net/sendmail + meta/planet2-index/basic/main + web-server/http/id-cookie + file/sha1) + +(define-syntax-rule (while cond e ...) + (let loop () + (when cond + e ... + (loop)))) + +(define (snoc l x) + (append l (list x))) + +(define (salty str) + (sha1 (open-input-string str))) + +(define-runtime-path src ".") + +(define-runtime-path root "root") +(make-directory* root) +(define secret-key + (make-secret-salt/file + (build-path root "secret.key"))) +(define users-path (build-path root "users")) +(make-directory* users-path) + +(module+ main + (define users-old-path (build-path root "users.old")) + (when (directory-exists? users-old-path) + (for ([u (in-list (directory-list users-old-path))]) + (define uop (build-path users-old-path u)) + (display-to-file (salty (file->string uop)) + (build-path users-path u)) + (delete-file uop)) + (delete-directory users-old-path))) + +(define pkgs-path (build-path root "pkgs")) +(make-directory* pkgs-path) + +(define id-cookie-name "id") + +;; XXX Add a caching system +(define (package-list) + (sort (map path->string (directory-list pkgs-path)) + string-ci<=?)) +(define (package-exists? pkg-name) + (file-exists? (build-path pkgs-path pkg-name))) +(define (package-remove! pkg-name) + (delete-file (build-path pkgs-path pkg-name))) +(define (package-info pkg-name) + (file->value (build-path pkgs-path pkg-name))) +(define (package-info-set! pkg-name i) + (write-to-file i (build-path pkgs-path pkg-name) + #:exists 'replace)) + +(define (package-ref pkg-info key) + (hash-ref pkg-info key + (λ () + (match key + [(or 'author 'checksum 'source) + (error 'planet2 "Package ~e is missing a required field: ~e" + (hash-ref pkg-info 'name) key)] + ['tags + empty] + [(or 'last-checked 'last-edit 'last-updated) + -inf.0])))) + +(define-values (main-dispatch main-url) + (dispatch-rules + [() page/main] + [("") page/main] + [("info" (string-arg)) page/info] + [("search" (string-arg) ...) page/search] + [("query" "search" (string-arg) ...) page/search/query] + [("account" "login") page/login] + [("account" "logout") page/logout] + [("manage") page/manage] + [("manage" "update") page/manage/update] + [("manage" "edit" (string-arg)) page/manage/edit] + [("manage" "upload") page/manage/upload] + [else basic-start])) + +(define (page/main req) + (redirect-to (main-url page/search empty))) + +(define (format-time s) + (if s + (parameterize ([date-display-format 'rfc2822]) + (date->string (seconds->date s #f) #t)) + "")) + +(define (package-url->useful-url pkg-url-str) + (define pkg-url + (string->url pkg-url-str)) + (match (url-scheme pkg-url) + ["github" + (match-define (list* user repo branch path) + (url-path pkg-url)) + (url->string + (struct-copy url pkg-url + [scheme "http"] + [path (list* user repo (path/param "tree" empty) branch path)]))] + [_ + pkg-url-str])) + +(define (page/info req pkg-name) + (page/info-like + (list (cons "Packages" (main-url page/main)) + pkg-name) + #f + (λ (embed/url t) + (main-url page/search (list t))) + req pkg-name)) + +(define (search-term-eval pkg-name info term) + (match term + [(regexp #rx"^author:(.*?)$" (list _ author)) + (equal? author (package-ref info 'author))] + [_ + (define term-rx (regexp-quote term)) + (for/or ([tag (list* pkg-name (package-ref info 'tags))]) + (regexp-match? term-rx tag))])) + +(define breadcrumb->string + (match-lambda + [(? string? label) + label] + [(cons (? string? label) + (? string? url)) + label])) +(define breadcrumb->xexpr + (match-lambda + [(? string? label) + `(span ,label)] + [(cons (? string? label) + (? string? url)) + `(span (a ([href ,url]) ,label))])) + +(define (template req #:breadcrumb bc . xexpr-forest) + (send/back + (response/xexpr + `(html + (head + (script ([src "/sorttable.js"]) " ") + (link ([rel "stylesheet"] + [type "text/css"] + [href "/style.css"])) + (title ,@(add-between (map breadcrumb->string bc) " > "))) + (body + (div ([class "breadcrumb"]) + ,@(add-between (map breadcrumb->xexpr bc) " > ") + ,(cond + [(current-user req #f) + => (λ (user) + `(span ([id "logout"]) + ,user + " | " + (a ([href ,(main-url page/logout)]) "logout")))] + [else + ""])) + ,@xexpr-forest + (div ([id "footer"]) + "Powered by " + (a ([href "http://racket-lang.org/"]) "Racket") ". " + "Written by " + (a ([href "http://faculty.cs.byu.edu/~jay"]) "Jay McCarthy") + ".")))))) + +(define (page/logout req) + (redirect-to + (main-url page/main) + #:headers + (list (cookie->header (logout-id-cookie id-cookie-name))))) + +(define (package-list/search ts) + (filter + (λ (p) + (define i (package-info p)) + (for/and ([t (in-list ts)]) + (search-term-eval p i t))) + (package-list))) + +(define search-formlet + (formlet + ,{(to-string (required (text-input))) + . => . new-terms} + (string-split new-terms))) + +(define (page/search/query req old-terms) + (define terms (formlet-process search-formlet req)) + (redirect-to (main-url page/search (append old-terms terms)))) + +(define (page/search req terms) + (define pkgs (package-list/search terms)) + (template + req + #:breadcrumb + (list* (cons "Packages" (main-url page/main)) + "Search" + (for/list ([t (in-list terms)]) + (cons t (main-url page/search (remove* (list t) terms))))) + `(div ([id "menu"]) + (form ([action ,(main-url page/search/query terms)]) + (span ([class "menu_option"]) + ,@(formlet-display search-formlet) + (input ([type "submit"] [value "Search"]))) + (span ([class "menu_option"]) + (a ([href ,(main-url page/manage)]) + ,(if (current-user req #f) + "Manage Your Packages" + "Contribute a Package"))))) + (package-table page/info pkgs #:terms terms))) + +(define (page/login req) + (login req) + (redirect-to (main-url page/main))) + +(define (login req [last-error #f]) + (define login-formlet + (formlet + (table + (tr (td "Email Address:") + (td ,{(to-string (required (text-input))) . => . email})) + (tr (td "Password:") + (td ,{(to-string (required (password-input))) . => . passwd}))) + (values email passwd))) + (define log-req + (send/suspend + (λ (k-url) + (template + req + #:breadcrumb + (list "Login") + `(div ([id "login"]) + (form ([action ,k-url] [method "post"]) + ,@(formlet-display login-formlet) + (input ([type "submit"] [value "Log in"]))) + (p "If you enter an unclaimed email address, then an account will be created.") + (p "Passwords are stored in the delicious SHA1 format, but transfered as plain-text over the HTTPS connection.") + ,@(if last-error + `((h1 ([class "error"]) ,last-error)) + '())))))) + (define-values + (email passwd) + (formlet-process login-formlet log-req)) + + (define (authenticated!) + (redirect/get + #:headers + (list + (cookie->header + (make-id-cookie id-cookie-name secret-key email))))) + + (when (regexp-match (regexp-quote "/") email) + (send/back + (template + log-req + #:breadcrumb + (list "Login" "Account Registration Error") + `(p "Email addresses may not contain / on Planet2:" + (tt ,email))))) + + (define password-path (build-path users-path email)) + + (cond + [(not (file-exists? password-path)) + (send/suspend + (λ (k-url) + (send-mail-message + "planet2@racket-lang.org" + "Account confirmation for Planet2" + (list email) + empty empty + (list "Someone tried to register your email address for an account on Planet2. If you want to authorize this registration and log in, please click the following link:" + "" + (format "https://plt-etc.byu.edu:9004~a" k-url) + "" + "This link will expire, so if it is not available, you'll have to try to register again.")) + (template + log-req + #:breadcrumb + (list "Login" "Account Registration") + `(p "An email has been sent to " + (tt ,email) + ", please click the link it contains to register and log in.")))) + (display-to-file (salty passwd) password-path) + (authenticated!)] + [(not (bytes=? (string->bytes/utf-8 (salty passwd)) + (file->bytes password-path))) + (login req (format "The given password is incorrect for email address ~e" + email))] + [else + (authenticated!)])) + +(define (current-user req required?) + (define id + (request-id-cookie id-cookie-name secret-key req)) + (cond + [id + id] + [required? + (current-user (login req) required?)] + [else + #f])) + +(define (package-list/mine req) + (define u (current-user req #t)) + (package-list/search (list (format "author:~a" u)))) + +(define (package-table page/package pkgs + #:terms [terms empty]) + `(table + ([class "packages sortable"]) + (thead + (tr (th "Package") (th "Author") (th "Description") (th "Tags"))) + (tbody + ,@(for/list ([p (in-list pkgs)]) + (define i (package-info p)) + (define author (package-ref i 'author)) + `(tr + ([class ,(if (< (- (current-seconds) (* 2 24 60 60)) + (package-ref i 'last-updated)) + "recent" + "")]) + (td (a ([href ,(main-url page/package p)]) + ,p)) + (td (a ([href ,(main-url page/search + (snoc terms + (format "author:~a" author)))]) + ,author)) + (td ,(package-ref i 'description)) + (td ,@(for/list ([t (in-list (package-ref i 'tags))]) + `(span (a ([href ,(main-url page/search (snoc terms t))]) + ,t) + " ")))))))) + +(define (page/manage req) + (define pkgs (package-list/mine req)) + (template + req + #:breadcrumb + (list (cons "Packages" (main-url page/main)) + (current-user req #t) + "Manage") + `(div ([id "menu"]) + (span ([class "menu_option"]) + (a ([href ,(main-url page/manage/upload)]) + "Upload a new package")) + (span ([class "menu_option"]) + (a ([href ,(main-url page/manage/update)]) + "Update checksums"))) + (package-table page/manage/edit pkgs))) + +(define (page/manage/upload req) + (page/manage/edit req #f)) + +(define (request-binding/string req id [fail? #t]) + (define res + (bindings-assq (string->bytes/utf-8 id) + (request-bindings/raw req))) + (cond + [res + (bytes->string/utf-8 + (binding:form-value + res))] + [fail? + (error 'planet2 "Missing field ~e" id)] + [else + #f])) + +(define (page/manage/edit req pkg) + (define (edit-details pkg-req) + (define new-pkg (request-binding/string pkg-req "name")) + (when (string=? new-pkg "") + (error 'planet2 "Name must not be empty: ~e" new-pkg)) + (define new-source (request-binding/string pkg-req "source")) + (when (string=? new-source "") + (error 'planet2 "Source must not be empty: ~e" new-source)) + (define new-desc (request-binding/string pkg-req "description")) + + (when (regexp-match #rx"[^a-zA-Z0-9_\\-]" new-pkg) + (error 'planet2 + "Illegal character in name; only alphanumerics, plus '-' and '_' allowed: ~e" + new-pkg)) + + (when (and (not (equal? pkg new-pkg)) + (or (regexp-match #rx"^[Pp][Ll][Tt]" new-pkg) + (regexp-match #rx"^[Pp][Ll][Aa][Nn][Ee][Tt]" new-pkg) + (regexp-match #rx"^[Rr][Aa][Cc][Kk][Ee][Tt]" new-pkg))) + (error 'planet2 + "Packages that start with plt, planet, and racket are not allowed without special permission. Please create your package with a different name, then email curation to request a rename: ~e" + new-pkg)) + + (when (and (package-exists? new-pkg) + (not (equal? (package-ref (package-info new-pkg) 'author) + (current-user pkg-req #t)))) + (error 'planet2 + "Packages may only be modified by their authors: ~e" + new-pkg)) + + (package-begin + (define* i + (if pkg + (package-info pkg) + (hasheq))) + + (define* i + (hash-set i 'name new-pkg)) + (define* i + (hash-set i 'source new-source)) + (define* i + (hash-set i 'author (current-user pkg-req #t))) + (define* i + (hash-set i 'description new-desc)) + (define* i + (hash-set i 'last-edit (current-seconds))) + (define* i + (if pkg + i + (hash-set i 'checksum ""))) + + (package-info-set! new-pkg i)) + + (unless (or (not pkg) (equal? new-pkg pkg)) + (package-remove! pkg)) + + (update-checksum new-pkg) + + (define new-tag + (request-binding/string pkg-req "tag" #f)) + (add-tag! new-pkg new-tag) + + (redirect-to + (main-url page/manage/edit new-pkg))) + + (page/info-like + (list* (cons "Packages" (main-url page/main)) + (current-user req #t) + (cons "Manage" (main-url page/manage)) + (if pkg + (list pkg + "Edit") + (list "Upload"))) + edit-details + (λ (embed/url t) + (embed/url (remove-tag-handler pkg t))) + req pkg)) + + +(define (tags-normalize ts) + (remove-duplicates (sort ts string-ciuseful-url (package-ref i 'source))]) + ,(package-ref i 'source))))) + (tr + (td "Checksum") + (td ,(package-ref* i 'checksum ""))) + (tr + (td "Last Update") + (td ,(format-time (package-ref* i 'last-updated #f)))) + (tr + (td "Last Checked") + (td ,(format-time (package-ref* i 'last-checked #f)))) + (tr + (td "Description") + (td ,(if edit-details + `(textarea ([name "description"]) + ,(package-ref* i 'description "")) + (package-ref i 'description)))) + (tr + (td "Last Edit") + (td ,(format-time (package-ref* i 'last-edit #f)))) + (tr + (td "Tags") + (td + (ul + ,@(for/list ([t (in-list (package-ref* i 'tags empty))]) + `(li (a ([href ,(tag-url embed/url t)]) + ,t))) + ,(if pkg-name + `(li (input ([name "tag"] [type "text"]))) + "")))) + `(tr (td ([class "submit"] [colspan "2"]) + (input ([type "submit"] [value "Submit"])))))) + (template + req + #:breadcrumb + bc + `(div + ([class "package"]) + (form ([action ,(embed/url form-handler)] [method "post"]) + ,the-table)))))) + +(define (page/manage/update req) + (update-checksums + (package-list/mine req)) + (redirect-to (main-url page/manage))) + +(define (update-checksums pkgs) + (for-each update-checksum pkgs)) + +(define (update-checksum pkg-name) + (define i (package-info pkg-name)) + (define old-checksum + (package-ref i 'checksum)) + (define now (current-seconds)) + (define new-checksum + (package-url->checksum (package-ref i 'source))) + (package-begin + (define* i + (hash-set i 'checksum + (or new-checksum + old-checksum))) + (define* i + (hash-set i 'last-checked now)) + (define* i + (if (and new-checksum (equal? new-checksum old-checksum)) + i + (hash-set i 'last-updated now))) + (package-info-set! pkg-name i))) + +(define basic-start + (planet2-index/basic package-list package-info)) + +(define (go port) + (printf "launching on port ~a\n" port) + (thread + (λ () + (while true + (printf "updating checksums\n") + (update-checksums (package-list)) + ;; update once per day based on whenever the server started + (sleep (* 24 60 60))))) + (serve/servlet + main-dispatch + #:command-line? #t + #:listen-ip #f + #:ssl? #t + #:ssl-cert (build-path root "server-cert.pem") + #:ssl-key (build-path root "private-key.pem") + #:extra-files-paths + (list (build-path src "static") + (build-path root "static")) + #:servlet-regexp #rx"" + #:port port)) + +(module+ main + (go 9004)) diff --git a/collects/meta/planet2-index/official/static/sorttable.js b/collects/meta/planet2-index/official/static/sorttable.js new file mode 100644 index 0000000000..4f74f1e2ea --- /dev/null +++ b/collects/meta/planet2-index/official/static/sorttable.js @@ -0,0 +1,515 @@ +function TocviewToggle(glyphid, id) { + var glyph = document.getElementById(glyphid); + var s = document.getElementById(id).style; + var expand = s.display == "none"; + s.display = expand ? "block" : "none"; + glyph.innerHTML = expand ? "▼" : "►"; +} + +function ToggleOn(id) { + var s = document.getElementById(id).style; + var li = document.getElementById("li" + id); + s.display = "block"; + li.setAttribute("class", "tab-selected"); +} +function ToggleOff(id) { + var s = document.getElementById(id).style; + var li = document.getElementById("li" + id); + s.display = "none"; + li.setAttribute("class", ""); +} + +/* + SortTable + version 2 + 7th April 2007 + Stuart Langridge, http://www.kryogenix.org/code/browser/sorttable/ + + Instructions: + Download this file + Add to your HTML + Add class="sortable" to any table you'd like to make sortable + Click on the headers to sort + + Thanks to many, many people for contributions and suggestions. + Licenced as X11: http://www.kryogenix.org/code/browser/licence.html + This basically means: do what you want with it. +*/ + + +var stIsIE = /*@cc_on!@*/false; + +sorttable = { + init: function() { + // quit if this function has already been called + if (arguments.callee.done) return; + // flag this function so we don't do the same thing twice + arguments.callee.done = true; + // kill the timer + if (_timer) clearInterval(_timer); + + if (!document.createElement || !document.getElementsByTagName) return; + + sorttable.DATE_RE = /^(\d\d?)[\/\.-](\d\d?)[\/\.-]((\d\d)?\d\d)$/; + + forEach(document.getElementsByTagName('table'), function(table) { + if (table.className.search(/\bsortable\b/) != -1) { + sorttable.makeSortable(table); + } + }); + + }, + + makeSortable: function(table) { + if (table.getElementsByTagName('thead').length == 0) { + // table doesn't have a tHead. Since it should have, create one and + // put the first table row in it. + the = document.createElement('thead'); + the.appendChild(table.rows[0]); + table.insertBefore(the,table.firstChild); + } + // Safari doesn't support table.tHead, sigh + if (table.tHead == null) table.tHead = table.getElementsByTagName('thead')[0]; + + if (table.tHead.rows.length != 1) return; // can't cope with two header rows + + // Sorttable v1 put rows with a class of "sortbottom" at the bottom (as + // "total" rows, for example). This is B&R, since what you're supposed + // to do is put them in a tfoot. So, if there are sortbottom rows, + // for backwards compatibility, move them to tfoot (creating it if needed). + sortbottomrows = []; + for (var i=0; i5' : ' ▴'; + this.appendChild(sortrevind); + return; + } + if (this.className.search(/\bsorttable_sorted_reverse\b/) != -1) { + // if we're already sorted by this column in reverse, just + // re-reverse the table, which is quicker + sorttable.reverse(this.sorttable_tbody); + this.className = this.className.replace('sorttable_sorted_reverse', + 'sorttable_sorted'); + this.removeChild(document.getElementById('sorttable_sortrevind')); + sortfwdind = document.createElement('span'); + sortfwdind.id = "sorttable_sortfwdind"; + sortfwdind.innerHTML = stIsIE ? ' 6' : ' ▾'; + this.appendChild(sortfwdind); + return; + } + + // remove sorttable_sorted classes + theadrow = this.parentNode; + forEach(theadrow.childNodes, function(cell) { + if (cell.nodeType == 1) { // an element + cell.className = cell.className.replace('sorttable_sorted_reverse',''); + cell.className = cell.className.replace('sorttable_sorted',''); + } + }); + sortfwdind = document.getElementById('sorttable_sortfwdind'); + if (sortfwdind) { sortfwdind.parentNode.removeChild(sortfwdind); } + sortrevind = document.getElementById('sorttable_sortrevind'); + if (sortrevind) { sortrevind.parentNode.removeChild(sortrevind); } + + this.className += ' sorttable_sorted'; + sortfwdind = document.createElement('span'); + sortfwdind.id = "sorttable_sortfwdind"; + sortfwdind.innerHTML = stIsIE ? ' 6' : ' ▾'; + this.appendChild(sortfwdind); + + // build an array to sort. This is a Schwartzian transform thing, + // i.e., we "decorate" each row with the actual sort key, + // sort based on the sort keys, and then put the rows back in order + // which is a lot faster because you only do getInnerText once per row + row_array = []; + col = this.sorttable_columnindex; + rows = this.sorttable_tbody.rows; + for (var j=0; j 12) { + // definitely dd/mm + return sorttable.sort_ddmm; + } else if (second > 12) { + return sorttable.sort_mmdd; + } else { + // looks like a date, but we can't tell which, so assume + // that it's dd/mm (English imperialism!) and keep looking + sortfn = sorttable.sort_ddmm; + } + } + } + } + return sortfn; + }, + + getInnerText: function(node) { + // gets the text we want to use for sorting for a cell. + // strips leading and trailing whitespace. + // this is *not* a generic getInnerText function; it's special to sorttable. + // for example, you can override the cell text with a customkey attribute. + // it also gets .value for fields. + + hasInputs = (typeof node.getElementsByTagName == 'function') && + node.getElementsByTagName('input').length; + + if (node.getAttribute("sorttable_customkey") != null) { + return node.getAttribute("sorttable_customkey"); + } + else if (typeof node.textContent != 'undefined' && !hasInputs) { + return node.textContent.replace(/^\s+|\s+$/g, ''); + } + else if (typeof node.innerText != 'undefined' && !hasInputs) { + return node.innerText.replace(/^\s+|\s+$/g, ''); + } + else if (typeof node.text != 'undefined' && !hasInputs) { + return node.text.replace(/^\s+|\s+$/g, ''); + } + else { + switch (node.nodeType) { + case 3: + if (node.nodeName.toLowerCase() == 'input') { + return node.value.replace(/^\s+|\s+$/g, ''); + } + case 4: + return node.nodeValue.replace(/^\s+|\s+$/g, ''); + break; + case 1: + case 11: + var innerText = ''; + for (var i = 0; i < node.childNodes.length; i++) { + innerText += sorttable.getInnerText(node.childNodes[i]); + } + return innerText.replace(/^\s+|\s+$/g, ''); + break; + default: + return ''; + } + } + }, + + reverse: function(tbody) { + // reverse the rows in a tbody + newrows = []; + for (var i=0; i=0; i--) { + tbody.appendChild(newrows[i]); + } + delete newrows; + }, + + /* sort functions + each sort function takes two parameters, a and b + you are comparing a[0] and b[0] */ + sort_numeric: function(a,b) { + aa = parseFloat(a[0].replace(/[^0-9.-]/g,'')); + if (isNaN(aa)) aa = 0; + bb = parseFloat(b[0].replace(/[^0-9.-]/g,'')); + if (isNaN(bb)) bb = 0; + return aa-bb; + }, + sort_alpha: function(a,b) { + if (a[0]==b[0]) return 0; + if (a[0] 0 ) { + var q = list[i]; list[i] = list[i+1]; list[i+1] = q; + swap = true; + } + } // for + t--; + + if (!swap) break; + + for(var i = t; i > b; --i) { + if ( comp_func(list[i], list[i-1]) < 0 ) { + var q = list[i]; list[i] = list[i-1]; list[i-1] = q; + swap = true; + } + } // for + b++; + + } // while(swap) + } +} + +/* ****************************************************************** + Supporting functions: bundled here to avoid depending on a library + ****************************************************************** */ + +// Dean Edwards/Matthias Miller/John Resig + +/* for Mozilla/Opera9 */ +if (document.addEventListener) { + document.addEventListener("DOMContentLoaded", sorttable.init, false); +} + +/* for Internet Explorer */ +/*@cc_on @*/ +/*@if (@_win32) + document.write("