From 8ea1487eea4c189e58999424f653f564be4230c2 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 30 Aug 2011 06:48:59 -0500 Subject: [PATCH 001/235] double planet tests timeout --- collects/meta/props | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/meta/props b/collects/meta/props index 7d96ff795d..5f318abb86 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1566,7 +1566,7 @@ path/s is either such a string or a list of them. "collects/tests/planet/examples/dummy-module.rkt" drdr:command-line #f "collects/tests/planet/examples/scribblings-package" drdr:command-line #f "collects/tests/planet/lang.rkt" drdr:command-line (raco "make" *) -"collects/tests/planet/run-all.rkt" drdr:command-line (racket *) drdr:timeout 1000 +"collects/tests/planet/run-all.rkt" drdr:command-line (racket *) drdr:timeout 2000 "collects/tests/planet/test-docs-complete.rkt" drdr:command-line (raco "make" *) "collects/tests/planet/thread-safe-resolver.rkt" drdr:command-line (raco "make" *) drdr:timeout 1000 "collects/tests/planet/version.rkt" drdr:command-line (raco "make" *) From 61aaf584c578fc2865a01f1e8a935371052b521d Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 29 Aug 2011 19:39:22 -0500 Subject: [PATCH 002/235] adjust the threading protocol for compilings files to be kill safe --- collects/compiler/cm.rkt | 141 ++++++++++++++---- collects/drracket/private/expanding-place.rkt | 3 +- collects/drracket/private/module-language.rkt | 3 +- collects/scribblings/raco/make.scrbl | 10 +- collects/tests/racket/cm.rktl | 76 ++++++++++ 5 files changed, 202 insertions(+), 31 deletions(-) diff --git a/collects/compiler/cm.rkt b/collects/compiler/cm.rkt index 1cd80e8340..480e751ed4 100644 --- a/collects/compiler/cm.rkt +++ b/collects/compiler/cm.rkt @@ -675,43 +675,128 @@ (define (make-compile-lock) (define-values (manager-side-chan build-side-chan) (place-channel)) - (struct pending (response-chan bytes)) + (struct pending (response-chan zo-path died-chan-manager-side) #:transparent) + (struct running (zo-path died-chan-manager-side) #:transparent) (define currently-locked-files (make-hash)) (define pending-requests '()) + (define running-compiles '()) (thread (λ () (let loop () - (define req (place-channel-get manager-side-chan)) - (define command (list-ref req 0)) - (define bytes (list-ref req 1)) - (define response-manager-side (list-ref req 2)) - (cond - [(eq? command 'lock) - (cond - [(hash-ref currently-locked-files bytes #f) - (set! pending-requests (cons (pending response-manager-side bytes) - pending-requests)) - (loop)] - [else - (hash-set! currently-locked-files bytes #t) - (place-channel-put response-manager-side #t) - (loop)])] - [(eq? command 'unlock) - (define (same-bytes? pending) (equal? (pending-bytes pending) bytes)) - (define to-unlock (filter same-bytes? pending-requests)) - (set! pending-requests (filter (compose not same-bytes?) pending-requests)) - (for ([pending (in-list to-unlock)]) - (place-channel-put (pending-response-chan pending) #f)) - (hash-remove! currently-locked-files bytes) - (loop)])))) + (apply + sync + (handle-evt + manager-side-chan + (λ (req) + (define command (list-ref req 0)) + (define zo-path (list-ref req 1)) + (define response-manager-side (list-ref req 2)) + (define died-chan-manager-side (list-ref req 3)) + (case command + [(lock) + (cond + [(hash-ref currently-locked-files zo-path #f) + (set! pending-requests (cons (pending response-manager-side zo-path died-chan-manager-side) + pending-requests)) + (loop)] + [else + (hash-set! currently-locked-files zo-path #t) + (place-channel-put response-manager-side #t) + (set! running-compiles (cons (running zo-path died-chan-manager-side) running-compiles)) + (loop)])] + [(unlock) + (define (same-bytes? pending) (equal? (pending-zo-path pending) zo-path)) + (define to-unlock (filter same-bytes? pending-requests)) + (set! pending-requests (filter (compose not same-bytes?) pending-requests)) + (for ([pending (in-list to-unlock)]) + (place-channel-put (pending-response-chan pending) #f)) + (hash-remove! currently-locked-files zo-path) + (loop)]))) + (for/list ([running-compile (in-list running-compiles)]) + (handle-evt + (running-died-chan-manager-side running-compile) + (λ (_) + (define zo-path (running-zo-path running-compile)) + (set! running-compiles (remove running-compile running-compiles)) + (define same-zo-pending + (filter (λ (pending) (equal? zo-path (pending-zo-path pending))) + pending-requests)) + (cond + [(null? same-zo-pending) + (hash-set! currently-locked-files zo-path #f) + (loop)] + [else + (define to-be-running (car same-zo-pending)) + (set! pending-requests (remq to-be-running pending-requests)) + (place-channel-put (pending-response-chan to-be-running) #t) + (set! running-compiles + (cons (running zo-path (pending-died-chan-manager-side to-be-running)) + running-compiles)) + (loop)])))))))) build-side-chan) -(define (compile-lock->parallel-lock-client build-side-chan) +(define (compile-lock->parallel-lock-client build-side-chan [custodian #f]) + (define monitor-threads (make-hash)) + (define add-monitor-chan (make-channel)) + (define kill-monitor-chan (make-channel)) + + (define (clean-up-hash) + (for ([key+val (in-list (hash-map monitor-threads list))]) + (define key (list-ref key+val 0)) + (define val (list-ref key+val 1)) + (unless (weak-box-value val) + (hash-remove! monitor-threads key)))) + + (when custodian + (parameterize ([current-custodian custodian]) + (thread + (λ () + (let loop () + (sync + (if (zero? (hash-count monitor-threads)) + never-evt + (handle-evt (alarm-evt (+ (current-inexact-milliseconds) 500)) + (λ (arg) + (clean-up-hash) + (loop)))) + (handle-evt add-monitor-chan + (λ (arg) + (define-values (zo-path monitor-thread) (apply values arg)) + (hash-set! monitor-threads zo-path (make-weak-box monitor-thread)) + (clean-up-hash) + (loop))) + (handle-evt kill-monitor-chan + (λ (zo-path) + (define thd/f (weak-box-value (hash-ref monitor-threads zo-path))) + (when thd/f (kill-thread thd/f)) + (hash-remove! monitor-threads zo-path) + (clean-up-hash) + (loop))))))))) + (λ (command zo-path) (define-values (response-builder-side response-manager-side) (place-channel)) - (place-channel-put build-side-chan (list command zo-path response-manager-side)) - (when (eq? command 'lock) - (place-channel-get response-builder-side)))) + (define-values (died-chan-compiling-side died-chan-manager-side) (place-channel)) + (place-channel-put build-side-chan (list command zo-path response-manager-side died-chan-manager-side)) + (define compiling-thread (current-thread)) + (cond + [(eq? command 'lock) + (define monitor-thread + (and custodian + (parameterize ([current-custodian custodian]) + (thread + (λ () + (thread-wait compiling-thread) + (place-channel-put died-chan-compiling-side 'dead)))))) + (when monitor-thread (channel-put add-monitor-chan (list zo-path monitor-thread))) + (define res (place-channel-get response-builder-side)) + (when monitor-thread + (unless res ;; someone else finished compilation for us; kill the monitor + (channel-put kill-monitor-chan zo-path))) + res] + [(eq? command 'unlock) + (when custodian + ;; we finished the compilation; kill the monitor + (channel-put kill-monitor-chan zo-path))]))) diff --git a/collects/drracket/private/expanding-place.rkt b/collects/drracket/private/expanding-place.rkt index 1cc8fbd59d..ec4e805a2f 100644 --- a/collects/drracket/private/expanding-place.rkt +++ b/collects/drracket/private/expanding-place.rkt @@ -17,7 +17,8 @@ ;; get the module-language-compile-lock in the initial message (set! module-language-parallel-lock-client (compile-lock->parallel-lock-client - (place-channel-get p))) + (place-channel-get p) + (current-custodian))) ;; get the handlers in a second message (set! handlers (for/list ([lst (place-channel-get p)]) diff --git a/collects/drracket/private/module-language.rkt b/collects/drracket/private/module-language.rkt index dc041a3df6..e1ceed4e85 100644 --- a/collects/drracket/private/module-language.rkt +++ b/collects/drracket/private/module-language.rkt @@ -1396,7 +1396,8 @@ (define module-language-parallel-lock-client (compile-lock->parallel-lock-client - module-language-compile-lock)) + module-language-compile-lock + (current-custodian))) ;; in-module-language : top-level-window<%> -> module-language-settings or #f (define (in-module-language tlw) diff --git a/collects/scribblings/raco/make.scrbl b/collects/scribblings/raco/make.scrbl index 3abbaee883..a39c3a0921 100644 --- a/collects/scribblings/raco/make.scrbl +++ b/collects/scribblings/raco/make.scrbl @@ -389,12 +389,20 @@ result will not call @racket[proc] with @racket['unlock].) ] } -@defproc[(compile-lock->parallel-lock-client [pc place-channel?]) +@defproc[(compile-lock->parallel-lock-client [pc place-channel?] [cust (or/c #f custodian?) #f]) (-> (or/c 'lock 'unlock) bytes? boolean?)]{ Returns a function that follows the @racket[parallel-lock-client] by communicating over @racket[pc]. The argument must have be the result of @racket[make-compile-lock]. + + This communication protocol implementation is not kill safe. To make it kill safe, + it needs a sufficiently powerful custodian, i.e., one that is not subject to + termination (unless all of the participants in the compilation are also terminated). + It uses this custodian to create a thread that monitors the threads that are + doing the compilation. If one of them is terminated, the presence of the + custodian lets another one continue. (The custodian is also used to create + a thread that manages a thread safe table.) } @defproc[(make-compile-lock) place-channel?]{ diff --git a/collects/tests/racket/cm.rktl b/collects/tests/racket/cm.rktl index 036c985649..d199588e0b 100644 --- a/collects/tests/racket/cm.rktl +++ b/collects/tests/racket/cm.rktl @@ -146,6 +146,82 @@ (parameterize ([current-load/use-compiled (make-compilation-manager-load/use-compiled-handler)]) (test (void) dynamic-require 'compiler/cm #f)))) +;; ---------------------------------------- +;; test for make-compile-lock + +(let () + #| + +This test creates a file to compile that, during compilation, conditionally +freezes forever. It first creates a thread to compile the file in freeze-forever +mode, and then, when the thread is stuck, creates a second thread to compile +the file and kills the first thread. The second compile should complete properly +and the test makes sure that it does and that the first thread doesn't complete. + + |# + + (define (sexps=>file file #:lang [lang #f] . sexps) + (call-with-output-file file + (λ (port) + (when lang (fprintf port "~a\n" lang)) + (for ([x (in-list sexps)]) (fprintf port "~s\n" x))) + #:exists 'truncate)) + + (define (poll-file file for) + (let loop ([n 100]) + (when (zero? n) + (error 'compiler/cm::poll-file "never found ~s in ~s" for file)) + (define now (call-with-input-file file (λ (port) (read-line port)))) + (unless (equal? now for) + (sleep .1) + (loop (- n 1))))) + + (define file-to-compile (make-temporary-file "cmtest-file-to-compile~a.rkt")) + (define control-file (make-temporary-file "cmtest-control-file-~a.rktd")) + (define about-to-get-stuck-file (make-temporary-file "cmtest-about-to-get-stuck-file-~a.rktd")) + + (sexps=>file file-to-compile #:lang "#lang racket" + `(define-syntax (m stx) + (call-with-output-file ,(path->string about-to-get-stuck-file) + (λ (port) (fprintf port "about\n")) + #:exists 'truncate) + (if (call-with-input-file ,(path->string control-file) read) + (semaphore-wait (make-semaphore 0)) + #'1)) + '(void (m))) + (sexps=>file control-file #t) + + (define p-l-c (compile-lock->parallel-lock-client (make-compile-lock) (current-custodian))) + (define t1-finished? #f) + (parameterize ([parallel-lock-client p-l-c] + [current-load/use-compiled (make-compilation-manager-load/use-compiled-handler)]) + (define finished (make-channel)) + (define t1 (thread (λ () (dynamic-require file-to-compile #f) (set! t1-finished? #t)))) + (poll-file about-to-get-stuck-file "about") + (sexps=>file control-file #f) + (define t2 (thread (λ () (dynamic-require file-to-compile #f) (channel-put finished #t)))) + (sleep .1) ;; give thread t2 time to get stuck waiting for t1 to compile + (kill-thread t1) + (channel-get finished) + + (test #f 't1-finished? t1-finished?) + + (test #t + 'compile-lock::compiled-file-exists + (file-exists? + (let-values ([(base name dir?) (split-path file-to-compile)]) + (build-path base + "compiled" + (bytes->path (regexp-replace #rx"[.]rkt" (path->bytes name) "_rkt.zo")))))) + + (define compiled-dir + (let-values ([(base name dir?) (split-path file-to-compile)]) + (build-path base "compiled"))) + (delete-file file-to-compile) + (delete-file control-file) + (delete-file about-to-get-stuck-file) + (delete-directory/files compiled-dir))) + ;; ---------------------------------------- (report-errs) From 936b51adf146fc7f5e8b5c69a3fcfafe1934f817 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 30 Aug 2011 08:12:32 -0500 Subject: [PATCH 003/235] double planet tests timeout --- collects/meta/props | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/meta/props b/collects/meta/props index 5f318abb86..1479813b47 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1566,7 +1566,7 @@ path/s is either such a string or a list of them. "collects/tests/planet/examples/dummy-module.rkt" drdr:command-line #f "collects/tests/planet/examples/scribblings-package" drdr:command-line #f "collects/tests/planet/lang.rkt" drdr:command-line (raco "make" *) -"collects/tests/planet/run-all.rkt" drdr:command-line (racket *) drdr:timeout 2000 +"collects/tests/planet/run-all.rkt" drdr:command-line (racket *) drdr:timeout 4000 "collects/tests/planet/test-docs-complete.rkt" drdr:command-line (raco "make" *) "collects/tests/planet/thread-safe-resolver.rkt" drdr:command-line (raco "make" *) drdr:timeout 1000 "collects/tests/planet/version.rkt" drdr:command-line (raco "make" *) From 2dc0098d86a5a1ea2711ec5c52de6611a0356655 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 30 Aug 2011 08:52:34 -0600 Subject: [PATCH 004/235] Changing test phase --- collects/tests/unstable/syntax.rkt | 39 ++++++++++++++++++------------ 1 file changed, 23 insertions(+), 16 deletions(-) diff --git a/collects/tests/unstable/syntax.rkt b/collects/tests/unstable/syntax.rkt index 242a87382f..2ea1317080 100644 --- a/collects/tests/unstable/syntax.rkt +++ b/collects/tests/unstable/syntax.rkt @@ -4,6 +4,7 @@ rackunit rackunit/text-ui racket/syntax + (for-syntax unstable/syntax) unstable/syntax "helpers.rkt") @@ -56,19 +57,25 @@ (with-syntax* ([a #'id] [b #'a]) #'b) #'id)))) - (test-suite "syntax-within?" - (let* ([a #'a] - [b #'b] - [c #'(a b c)] - [c1 (car (syntax->list c))] - [c2 (cadr (syntax->list c))]) - (test-case "reflexive" - (check-equal? (syntax-within? a a) #t)) - (test-case "unrelated" - (check-equal? (syntax-within? a b) #f)) - (test-case "child" - (check-equal? (syntax-within? c1 c) #t)) - (test-case "parent" - (check-equal? (syntax-within? c c1) #f)) - (test-case "sibling" - (check-equal? (syntax-within? c2 c1) #f)))))) + (let () + (define-syntax a #'a) + (define-syntax b #'b) + (define-syntax c #'(a b c)) + (define-syntax c1 (car (syntax->list (syntax-local-value #'c)))) + (define-syntax c2 (cadr (syntax->list (syntax-local-value #'c)))) + (define-syntax (*syntax-within? stx) + (syntax-case stx () + [(_ x y) + #`#,(syntax-within? (syntax-local-value #'x) + (syntax-local-value #'y))])) + (test-suite "syntax-within?" + (test-case "reflexive" + (check-equal? (*syntax-within? a a) #t)) + (test-case "unrelated" + (check-equal? (*syntax-within? a b) #f)) + (test-case "child" + (check-equal? (*syntax-within? c1 c) #t)) + (test-case "parent" + (check-equal? (*syntax-within? c c1) #f)) + (test-case "sibling" + (check-equal? (*syntax-within? c2 c1) #f)))))) From 3e1eb67336617150b546841a0c1c3d2793385b06 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 29 Aug 2011 19:58:56 -0400 Subject: [PATCH 005/235] Make environments much lazier about computing types; remove useless requires. Allow duplicate type annotations when they are the same type. --- collects/tests/typed-scheme/fail/dup-ann.rkt | 2 +- .../base-env/base-env-indexing-abs.rkt | 23 ++++++---------- .../base-env/base-special-env.rkt | 9 ++++--- .../typed-scheme/base-env/base-structs.rkt | 1 - collects/typed-scheme/base-env/env-lang.rkt | 2 +- collects/typed-scheme/env/global-env.rkt | 27 ++++++++++++------- collects/typed-scheme/infer/infer.rkt | 9 +++---- collects/typed-scheme/infer/signatures.rkt | 3 +-- .../typed-scheme/private/type-annotation.rkt | 16 ++++++----- collects/typed-scheme/rep/filter-rep.rkt | 5 ++-- collects/typed-scheme/rep/free-variance.rkt | 15 +++++------ collects/typed-scheme/rep/object-rep.rkt | 4 +-- collects/typed-scheme/rep/rep-utils.rkt | 7 ++--- .../typed-scheme/typecheck/signatures.rkt | 9 +++---- .../typed-scheme/typecheck/tc-structs.rkt | 15 +++++------ .../typed-scheme/typecheck/typechecker.rkt | 9 +++---- collects/typed-scheme/utils/any-wrap.rkt | 4 +-- .../typed-scheme/utils/require-contract.rkt | 1 - collects/typed-scheme/utils/stxclass-util.rkt | 4 +-- collects/typed-scheme/utils/tc-utils.rkt | 4 +-- collects/typed-scheme/utils/unit-utils.rkt | 4 --- collects/typed-scheme/utils/utils.rkt | 12 +++++++-- 22 files changed, 89 insertions(+), 96 deletions(-) delete mode 100644 collects/typed-scheme/utils/unit-utils.rkt diff --git a/collects/tests/typed-scheme/fail/dup-ann.rkt b/collects/tests/typed-scheme/fail/dup-ann.rkt index 84b89f0cd8..7fd2210082 100644 --- a/collects/tests/typed-scheme/fail/dup-ann.rkt +++ b/collects/tests/typed-scheme/fail/dup-ann.rkt @@ -1,5 +1,5 @@ #; -(exn-pred 4) +(exn-pred 2) #lang typed/racket (: bar : (String -> String)) (: bar : (Number -> Number)) diff --git a/collects/typed-scheme/base-env/base-env-indexing-abs.rkt b/collects/typed-scheme/base-env/base-env-indexing-abs.rkt index 9812977fa8..ac1c76c32d 100644 --- a/collects/typed-scheme/base-env/base-env-indexing-abs.rkt +++ b/collects/typed-scheme/base-env/base-env-indexing-abs.rkt @@ -1,24 +1,17 @@ -#lang racket +#lang racket/base (require "../utils/utils.rkt" - (for-template '#%paramz racket/base racket/list - racket/tcp - (only-in rnrs/lists-6 fold-left) - '#%paramz - (only-in '#%kernel [apply kernel:apply]) - racket/promise racket/system - (only-in string-constants/private/only-once maybe-print-message) - (only-in racket/match/runtime match:error matchable? match-equality-test) - racket/unsafe/ops racket/flonum) - (utils tc-utils) - (types union convenience) - (rename-in (types abbrev numeric-tower) [-Number N] [-Boolean B] [-Symbol Sym])) + (for-template racket/base racket/list racket/unsafe/ops racket/flonum) + (utils tc-utils) + (rename-in (types union convenience abbrev numeric-tower) [-Number N] [-Boolean B] [-Symbol Sym])) (provide indexing) +(define-syntax-rule (make-env* [i t] ...) (make-env [i (λ () t)] ...)) + (define-syntax-rule (indexing index-type) - (make-env + (make-env* [build-list (-poly (a) (index-type (-Index . -> . a) . -> . (-lst a)))] [make-list (-poly (a) (index-type a . -> . (-lst a)))] @@ -129,7 +122,7 @@ [N index-type] [?N (-opt index-type)] [-Input (Un -String -Input-Port -Bytes -Path)]) - (-Pattern -Input [N ?N ?outp -Bytes] . ->opt . -Boolean))] + (-Pattern -Input [N ?N ?outp -Bytes] . ->opt . B))] diff --git a/collects/typed-scheme/base-env/base-special-env.rkt b/collects/typed-scheme/base-env/base-special-env.rkt index 37eb392313..17b1e2e67f 100644 --- a/collects/typed-scheme/base-env/base-special-env.rkt +++ b/collects/typed-scheme/base-env/base-special-env.rkt @@ -18,10 +18,12 @@ (define-syntax (define-initial-env stx) (syntax-parse stx - [(_ initialize-env [id-expr ty] ...) + [(_ initialize-env [id-expr ty] ... #:middle [id-expr* ty*] ...) #`(begin - (define initial-env (make-env [id-expr ty] ...)) - (define (initialize-env) (initialize-type-env initial-env)) + (define initial-env (make-env [id-expr (λ () ty)] ... )) + (do-time "finished local-expand types") + (define initial-env* (make-env [id-expr* (λ () ty*)] ...)) + (define (initialize-env) (initialize-type-env initial-env) (initialize-type-env initial-env*)) (provide initialize-env))])) (define-initial-env initialize-special @@ -185,6 +187,7 @@ ;; below here: keyword-argument functions from the base environment ;; FIXME: abstraction to remove duplication here + #:middle [((kw-expander-proc (syntax-local-value #'file->string))) (->key -Pathlike #:mode (one-of/c 'binary 'text) #f -String)] diff --git a/collects/typed-scheme/base-env/base-structs.rkt b/collects/typed-scheme/base-env/base-structs.rkt index 9751c719fb..96139755f6 100644 --- a/collects/typed-scheme/base-env/base-structs.rkt +++ b/collects/typed-scheme/base-env/base-structs.rkt @@ -98,5 +98,4 @@ (define-hierarchy exn:fail:user (#:kernel-maker k:exn:fail:user) ()))) - ;; cce: adding exn:break would require a generic type for continuations (void)) diff --git a/collects/typed-scheme/base-env/env-lang.rkt b/collects/typed-scheme/base-env/env-lang.rkt index 4ed8cda1a0..781ec29cdd 100644 --- a/collects/typed-scheme/base-env/env-lang.rkt +++ b/collects/typed-scheme/base-env/env-lang.rkt @@ -23,7 +23,7 @@ extra (define e (parameterize ([infer-param infer]) - (make-env [id ty] ...))) + (make-env [id (λ () ty)] ...))) (define (init) (initialize-type-env e)) (provide init)))] diff --git a/collects/typed-scheme/env/global-env.rkt b/collects/typed-scheme/env/global-env.rkt index 28b1aa2d78..3bb2577604 100644 --- a/collects/typed-scheme/env/global-env.rkt +++ b/collects/typed-scheme/env/global-env.rkt @@ -5,8 +5,9 @@ (require "../utils/utils.rkt" syntax/id-table + (rep type-rep) (utils tc-utils) - (types utils)) + (types utils comparison)) (provide register-type register-type-if-undefined finish-register-type @@ -31,18 +32,24 @@ (define (register-type-if-undefined id type) (cond [(free-id-table-ref the-mapping id (lambda _ #f)) => (lambda (e) - (tc-error/expr #:stx id "Duplicate type annotation for ~a" (syntax-e id)) + (define t (if (box? e) (unbox e) e)) + (unless (and (Type? t) (type-equal? t type)) + (tc-error/expr #:stx id "Duplicate type annotation of ~a for ~a, previous was ~a" type (syntax-e id) t)) (when (box? e) - (free-id-table-set! the-mapping id (unbox e))))] + (free-id-table-set! the-mapping id t)))] [else (register-type id type)])) ;; add a single type to the mapping ;; identifier type -> void (define (register-type/undefined id type) ;(printf "register-type/undef ~a\n" (syntax-e id)) - (if (free-id-table-ref the-mapping id (lambda _ #f)) - (void (tc-error/expr #:stx id "Duplicate type annotation for ~a" (syntax-e id))) - (free-id-table-set! the-mapping id (box type)))) + (cond [(free-id-table-ref the-mapping id (lambda _ #f)) + => + (λ (t) ;; it's ok to annotate with the same type + (define t* (if (box? t) (unbox t) t)) + (unless (and (Type? t*) (type-equal? type t*)) + (void (tc-error/expr #:stx id "Duplicate type annotation of ~a for ~a, previous was ~a" type (syntax-e id) t*))))] + [else (free-id-table-set! the-mapping id (box type))])) ;; add a bunch of types to the mapping ;; listof[id] listof[type] -> void @@ -52,9 +59,11 @@ ;; given an identifier, return the type associated with it ;; if none found, calls lookup-fail ;; identifier -> type -(define (lookup-type id [fail-handler (lambda () (lookup-type-fail id))]) - (let ([v (free-id-table-ref the-mapping id fail-handler)]) - (if (box? v) (unbox v) v))) +(define (lookup-type id [fail-handler (λ () (lookup-type-fail id))]) + (define v (free-id-table-ref the-mapping id fail-handler)) + (cond [(box? v) (unbox v)] + [(procedure? v) (define t (v)) (register-type id t) t] + [else v])) (define (maybe-finish-register-type id) (let ([v (free-id-table-ref the-mapping id)]) diff --git a/collects/typed-scheme/infer/infer.rkt b/collects/typed-scheme/infer/infer.rkt index c9da680d06..ccf9f1ad58 100644 --- a/collects/typed-scheme/infer/infer.rkt +++ b/collects/typed-scheme/infer/infer.rkt @@ -1,12 +1,11 @@ -#lang scheme/base +#lang racket/base (require (except-in "../utils/utils.rkt" infer)) (require "infer-unit.rkt" "constraints.rkt" "dmap.rkt" "signatures.rkt" "restrict.rkt" "promote-demote.rkt" - mzlib/trace - (only-in scheme/unit provide-signature-elements - define-values/invoke-unit/infer link) - (utils unit-utils)) + racket/trace + (only-in racket/unit provide-signature-elements + define-values/invoke-unit/infer link)) (provide-signature-elements restrict^ infer^) diff --git a/collects/typed-scheme/infer/signatures.rkt b/collects/typed-scheme/infer/signatures.rkt index daff06cebd..342cf045ce 100644 --- a/collects/typed-scheme/infer/signatures.rkt +++ b/collects/typed-scheme/infer/signatures.rkt @@ -1,7 +1,6 @@ #lang racket/base (require racket/unit racket/contract racket/require - "constraint-structs.rkt" - (path-up "utils/utils.rkt" "utils/unit-utils.rkt" "rep/type-rep.rkt")) + "constraint-structs.rkt" (path-up "utils/utils.rkt" "rep/type-rep.rkt")) (provide (all-defined-out)) (define-signature dmap^ diff --git a/collects/typed-scheme/private/type-annotation.rkt b/collects/typed-scheme/private/type-annotation.rkt index 198d316513..4516cb7a21 100644 --- a/collects/typed-scheme/private/type-annotation.rkt +++ b/collects/typed-scheme/private/type-annotation.rkt @@ -1,12 +1,12 @@ -#lang scheme/base +#lang racket/base (require "../utils/utils.rkt" (rep type-rep) (utils tc-utils) (env global-env) - (except-in (types subtype union convenience resolve utils) -> ->*) + (except-in (types subtype union convenience resolve utils comparison) -> ->*) (private parse-type) - (only-in scheme/contract listof ->) + (contract-req) racket/match mzlib/trace) (provide type-annotation get-type @@ -38,10 +38,12 @@ (define (type-annotation stx #:infer [let-binding #f]) (define (pt prop) (when (and (identifier? stx) - let-binding - (lookup-type stx (lambda () #f))) - (maybe-finish-register-type stx) - (tc-error/expr #:stx stx "Duplicate type annotation for ~a" (syntax-e stx))) + let-binding) + (define t1 (parse-type/id stx prop)) + (define t2 (lookup-type stx (lambda () #f))) + (when (and t2 (not (type-equal? t1 t2))) + (maybe-finish-register-type stx) + (tc-error/expr #:stx stx "Duplicate type annotation of ~a for ~a, previous was ~a" t1 (syntax-e stx) t2))) (if (syntax? prop) (parse-type prop) (parse-type/id stx prop))) diff --git a/collects/typed-scheme/rep/filter-rep.rkt b/collects/typed-scheme/rep/filter-rep.rkt index f25334dd33..ecf00a6fa5 100644 --- a/collects/typed-scheme/rep/filter-rep.rkt +++ b/collects/typed-scheme/rep/filter-rep.rkt @@ -1,7 +1,6 @@ -#lang scheme/base +#lang racket/base -(require racket/match scheme/contract) -(require "rep-utils.rkt" "free-variance.rkt") +(require "rep-utils.rkt" "free-variance.rkt" racket/contract/base) (define (Filter/c-predicate? e) (and (Filter? e) (not (NoFilter? e)) (not (FilterSet? e)))) diff --git a/collects/typed-scheme/rep/free-variance.rkt b/collects/typed-scheme/rep/free-variance.rkt index 7f113da345..480bb38404 100644 --- a/collects/typed-scheme/rep/free-variance.rkt +++ b/collects/typed-scheme/rep/free-variance.rkt @@ -1,8 +1,5 @@ -#lang scheme/base -(require "../utils/utils.rkt" - (for-syntax scheme/base) - (utils tc-utils) scheme/list - mzlib/etc scheme/contract) +#lang racket/base +(require "../utils/utils.rkt" (for-syntax racket/base) (contract-req)) (provide Covariant Contravariant Invariant Constant Dotted combine-frees flip-variances without-below unless-in-table @@ -52,10 +49,10 @@ ;; frees -> frees (define (flip-variances vs) (for/hasheq ([(k v) (in-hash vs)]) - (values k (evcase v - [Covariant Contravariant] - [Contravariant Covariant] - [v v])))) + (values k + (cond [(eq? v Covariant) Contravariant] + [(eq? v Contravariant) Covariant] + [else v])))) (define (make-invariant vs) (for/hasheq ([(k v) (in-hash vs)]) diff --git a/collects/typed-scheme/rep/object-rep.rkt b/collects/typed-scheme/rep/object-rep.rkt index a48085fb43..7582635d39 100644 --- a/collects/typed-scheme/rep/object-rep.rkt +++ b/collects/typed-scheme/rep/object-rep.rkt @@ -1,6 +1,6 @@ -#lang scheme/base +#lang racket/base -(require racket/match scheme/contract "rep-utils.rkt" "free-variance.rkt" "filter-rep.rkt") +(require "rep-utils.rkt" "free-variance.rkt" "filter-rep.rkt" "../utils/utils.rkt" (contract-req)) (provide object-equal?) (def-pathelem CarPE () [#:fold-rhs #:base]) diff --git a/collects/typed-scheme/rep/rep-utils.rkt b/collects/typed-scheme/rep/rep-utils.rkt index 3a365f930f..c23a3a0757 100644 --- a/collects/typed-scheme/rep/rep-utils.rkt +++ b/collects/typed-scheme/rep/rep-utils.rkt @@ -1,13 +1,11 @@ #lang scheme/base (require "../utils/utils.rkt") -(require mzlib/struct mzlib/pconvert +(require mzlib/pconvert racket/match - syntax/boundmap "free-variance.rkt" "interning.rkt" - racket/syntax unstable/match unstable/struct - mzlib/etc + unstable/match unstable/struct racket/stxparam scheme/contract (for-syntax @@ -17,7 +15,6 @@ (except-in syntax/parse id identifier keyword) scheme/base syntax/struct - syntax/stx scheme/contract racket/syntax (rename-in (except-in (utils utils stxclass-util) bytes byte-regexp regexp byte-pregexp pregexp) diff --git a/collects/typed-scheme/typecheck/signatures.rkt b/collects/typed-scheme/typecheck/signatures.rkt index 5795e4c94f..a2d5bb6264 100644 --- a/collects/typed-scheme/typecheck/signatures.rkt +++ b/collects/typed-scheme/typecheck/signatures.rkt @@ -1,9 +1,6 @@ -#lang scheme/base -(require scheme/unit scheme/contract - "../utils/utils.rkt" - (rep type-rep) - (utils unit-utils) - (types utils)) +#lang racket/base +(require racket/unit racket/contract + "../utils/utils.rkt" (rep type-rep) (types utils)) (provide (all-defined-out)) (define-signature tc-expr^ diff --git a/collects/typed-scheme/typecheck/tc-structs.rkt b/collects/typed-scheme/typecheck/tc-structs.rkt index d93761c364..015c9af11e 100644 --- a/collects/typed-scheme/typecheck/tc-structs.rkt +++ b/collects/typed-scheme/typecheck/tc-structs.rkt @@ -25,7 +25,7 @@ (require (for-template scheme/base "internal-forms.rkt")) -(provide tc/struct tc/poly-struct names-of-struct tc/builtin-struct d-s) +(provide tc/struct tc/poly-struct names-of-struct d-s) (define (names-of-struct stx) (define (parent? stx) @@ -284,20 +284,17 @@ ;; register a struct type ;; convenience function for built-in structs ;; tc/builtin-struct : identifier Maybe[identifier] Listof[identifier] Listof[Type] Maybe[identifier] Listof[Type] -> void -(define/cond-contract (tc/builtin-struct nm parent flds tys kernel-maker #;parent-tys) +;; FIXME - figure out how to make this lots lazier +(define/cond-contract (tc/builtin-struct nm parent flds tys kernel-maker) (c-> identifier? (or/c #f identifier?) (listof identifier?) - (listof Type/c) (or/c #f identifier?) #;(listof fld?) + (listof Type/c) (or/c #f identifier?) any/c) (define parent-name (if parent (make-Name parent) #f)) (define parent-flds (if parent (get-parent-flds parent-name) null)) (define parent-tys (map fld-t parent-flds)) (define defs (mk/register-sty nm flds parent-name parent-flds tys #:mutable #t)) - (if kernel-maker - (let* ([result-type (lookup-type-name nm)] - [ty (->* (append parent-tys tys) result-type)]) - (register-type kernel-maker ty) - (cons (make-def-binding kernel-maker ty) defs)) - defs)) + (when kernel-maker + (register-type kernel-maker (λ () (->* (append parent-tys tys) (lookup-type-name nm)))))) ;; syntax for tc/builtin-struct diff --git a/collects/typed-scheme/typecheck/typechecker.rkt b/collects/typed-scheme/typecheck/typechecker.rkt index 9a2d29622b..efd70847c2 100644 --- a/collects/typed-scheme/typecheck/typechecker.rkt +++ b/collects/typed-scheme/typecheck/typechecker.rkt @@ -1,9 +1,8 @@ -#lang scheme/base +#lang racket/base -(require "../utils/utils.rkt") -(require (utils unit-utils) - mzlib/trace - (only-in scheme/unit +(require "../utils/utils.rkt" + racket/trace + (only-in racket/unit provide-signature-elements define-values/invoke-unit/infer link) "signatures.rkt" diff --git a/collects/typed-scheme/utils/any-wrap.rkt b/collects/typed-scheme/utils/any-wrap.rkt index 3e88dc2e87..9974543c2e 100644 --- a/collects/typed-scheme/utils/any-wrap.rkt +++ b/collects/typed-scheme/utils/any-wrap.rkt @@ -1,6 +1,6 @@ -#lang scheme/base +#lang racket/base -(require racket/match scheme/vector scheme/contract) +(require racket/match racket/vector racket/contract/base racket/contract/combinator) (define-struct any-wrap (val) #:property prop:custom-write diff --git a/collects/typed-scheme/utils/require-contract.rkt b/collects/typed-scheme/utils/require-contract.rkt index 10a1451953..4b0dec2569 100644 --- a/collects/typed-scheme/utils/require-contract.rkt +++ b/collects/typed-scheme/utils/require-contract.rkt @@ -4,7 +4,6 @@ syntax/location (for-syntax scheme/base syntax/parse - racket/syntax (prefix-in tr: "../private/typed-renaming.rkt"))) (provide require/contract define-ignored) diff --git a/collects/typed-scheme/utils/stxclass-util.rkt b/collects/typed-scheme/utils/stxclass-util.rkt index f939bfae83..a3efaec137 100644 --- a/collects/typed-scheme/utils/stxclass-util.rkt +++ b/collects/typed-scheme/utils/stxclass-util.rkt @@ -1,8 +1,8 @@ -#lang scheme/base +#lang racket/base (require (except-in syntax/parse id keyword) (for-syntax syntax/parse - scheme/base + racket/base (only-in racket/syntax generate-temporary))) (provide (except-out (all-defined-out) id keyword) diff --git a/collects/typed-scheme/utils/tc-utils.rkt b/collects/typed-scheme/utils/tc-utils.rkt index 7b8b88db7b..2ad3a20c17 100644 --- a/collects/typed-scheme/utils/tc-utils.rkt +++ b/collects/typed-scheme/utils/tc-utils.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base #| This file is for utilities that are only useful for Typed Racket, but @@ -7,7 +7,7 @@ don't depend on any other portion of the system (provide (all-defined-out)) (require "syntax-traversal.rkt" racket/dict - syntax/parse (for-syntax scheme/base syntax/parse) racket/match) + syntax/parse (for-syntax racket/base syntax/parse) racket/match) ;; a parameter representing the original location of the syntax being ;; currently checked diff --git a/collects/typed-scheme/utils/unit-utils.rkt b/collects/typed-scheme/utils/unit-utils.rkt deleted file mode 100644 index f4f5c11b62..0000000000 --- a/collects/typed-scheme/utils/unit-utils.rkt +++ /dev/null @@ -1,4 +0,0 @@ -#lang scheme/base - - - diff --git a/collects/typed-scheme/utils/utils.rkt b/collects/typed-scheme/utils/utils.rkt index 0ed49bfa16..db37a19d7a 100644 --- a/collects/typed-scheme/utils/utils.rkt +++ b/collects/typed-scheme/utils/utils.rkt @@ -6,7 +6,7 @@ at least theoretically. |# (require (for-syntax racket/base syntax/parse racket/string) - racket/contract racket/require-syntax + racket/contract/base racket/require-syntax racket/provide-syntax racket/unit (prefix-in d: unstable/debug) racket/struct-info racket/pretty mzlib/pconvert syntax/parse) @@ -104,7 +104,7 @@ at least theoretically. #'(void))) ;; some macros to do some timing, only when `timing?' is #t -(define-for-syntax timing? #f) +(define-for-syntax timing? #t) (define last-time #f) (define initial-time #f) (define (set!-initial-time t) (set! initial-time t)) @@ -178,8 +178,16 @@ at least theoretically. cond-contracted define-struct/cond-contract define/cond-contract + contract-req define/cond-contract/provide) +(define-require-syntax contract-req + (if enable-contracts? + (syntax-rules () + [(_) racket/contract]) + (syntax-rules () + [(_) (combine-in)]))) + (define-syntax-rule (define/cond-contract/provide (name . args) c . body) (begin (define/cond-contract name c (begin From 534d89b983a2c2c81f20cabf68b7c9ed7f930ec8 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 30 Aug 2011 10:43:54 -0400 Subject: [PATCH 006/235] Fix type of `make-temporary-file'. --- .../special-env-typecheck-tests.rkt | 6 ++ .../unit-tests/typecheck-tests.rkt | 5 -- collects/typed-scheme/base-env/base-env.rkt | 86 +------------------ .../base-env/base-special-env.rkt | 6 +- 4 files changed, 12 insertions(+), 91 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/special-env-typecheck-tests.rkt b/collects/tests/typed-scheme/unit-tests/special-env-typecheck-tests.rkt index ff0d1af2c2..f8a639a7e5 100644 --- a/collects/tests/typed-scheme/unit-tests/special-env-typecheck-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/special-env-typecheck-tests.rkt @@ -113,6 +113,12 @@ [tc-e (with-handlers ([void (λ (x) (values 0 0))]) (values "" "")) #:ret (ret (list (t:Un -Zero -String) (t:Un -Zero -String)))] + (tc-e (make-temporary-file) -Path) + (tc-e (make-temporary-file "ee~a") -Path) + (tc-e (make-temporary-file "ee~a" 'directory) -Path) + (tc-e (make-temporary-file "ee~a" "temp" "here") -Path) + + )) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt index 5c6cb4be16..4a2d805ef6 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt @@ -1096,11 +1096,6 @@ (tc-e (make-directory* "tmp/a/b/c") -Void) - (tc-e (make-temporary-file) -Path) - (tc-e (make-temporary-file "ee~a") -Path) - (tc-e (make-temporary-file "ee~a" 'directory) -Path) - (tc-e (make-temporary-file "ee~a" "temp" "here") -Path) - (tc-e (put-preferences (list 'sym 'sym2) (list 'v1 'v2)) -Void) diff --git a/collects/typed-scheme/base-env/base-env.rkt b/collects/typed-scheme/base-env/base-env.rkt index 5b1d921730..42efb05ade 100644 --- a/collects/typed-scheme/base-env/base-env.rkt +++ b/collects/typed-scheme/base-env/base-env.rkt @@ -738,43 +738,6 @@ ;Section 14.2.5 ;racket/file -#| -[file->string (->key -Pathlike #:mode (one-of/c 'binary 'text) #f -String)] -[file->bytes (->key -Pathlike #:mode (one-of/c 'binary 'text) #f -Bytes)] -[file->value (->key -Pathlike #:mode (one-of/c 'binary 'text) #f Univ)] -[file->list - (-poly (a) - (cl->* (->key -Pathlike #:mode (one-of/c 'binary 'text) #f (-lst Univ)) - (->key -Pathlike (-> -Input-Port a) #:mode (one-of/c 'binary 'text) #f (-lst a))))] - -[file->lines - (->key -Pathlike #:mode (one-of/c 'binary 'text) #f - #:line-mode (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one) #f - (-lst -String))] -[file->bytes-lines - (->key -Pathlike #:mode (one-of/c 'binary 'text) #f - #:line-mode (one-of/c 'linefeed 'return 'return-linefeed 'any 'any-one) #f - (-lst -Bytes))] - -[display-to-file - (->key Univ -Pathlike - #:mode (one-of/c 'binary 'text) #f - #:exists (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace) #f - -Void)] -[write-to-file - (->key Univ -Pathlike - #:mode (one-of/c 'binary 'text) #f - #:exists (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace) #f - -Void)] - -[display-lines-to-file - (->key (-lst Univ) -Pathlike - #:separator Univ #f - #:mode (one-of/c 'binary 'text) #f - #:exists (one-of/c 'error 'append 'update 'replace 'truncate 'truncate/replace) #f - -Void)] -|# - [copy-directory/files (-> -Pathlike -Pathlike -Void)] [delete-directory/files (-> -Pathlike -Void)] @@ -789,59 +752,12 @@ ((Un funarg funarg*) a [(-opt -Pathlike) Univ]. ->opt . a)))] [make-directory* (-> -Pathlike -Void)] -[make-temporary-file (->opt [-String (Un -Pathlike (-val 'directory) (-val #f)) (-opt -Pathlike)] -Path)] +#;[make-temporary-file (->opt [-String (Un -Pathlike (-val 'directory) (-val #f)) (-opt -Pathlike)] -Path)] -#| -[get-preference - (let ((use-lock-type Univ) - (timeout-lock-there-type (-opt (-> -Path Univ))) - (lock-there-type (-opt (-> -Path Univ)))) - (cl->* - (->key Sym - #:use-lock? use-lock-type #f #:timeout-lock-there timeout-lock-there-type #f #:lock-there lock-there-type #f - Univ) - (->key Sym (-> Univ) - #:use-lock? use-lock-type #f #:timeout-lock-there timeout-lock-there-type #f #:lock-there lock-there-type #f - Univ) - (->key Sym (-> Univ) Univ - #:use-lock? use-lock-type #f #:timeout-lock-there timeout-lock-there-type #f #:lock-there lock-there-type #f - Univ) - (->key Sym (-> Univ) Univ (-opt -Pathlike) - #:use-lock? use-lock-type #f #:timeout-lock-there timeout-lock-there-type #f #:lock-there lock-there-type #f - Univ)))] -|# [put-preferences (->opt (-lst -Symbol) (-lst Univ) [(-> -Path Univ) (-opt -Pathlike)] -Void)] [preferences-lock-file-mode (-> (one-of/c 'exists 'file-lock))] -#| -[make-handle-get-preference-locked - (let ((lock-there-type (-opt (-> -Path Univ))) (max-delay-type -Real)) - (cl->* - (->key -Real Sym - #:lock-there lock-there-type #f #:max-delay max-delay-type #f - (-> -Pathlike Univ)) - (->key -Real Sym (-> Univ) - #:lock-there lock-there-type #f #:max-delay max-delay-type #f - (-> -Pathlike Univ)) - (->key -Real Sym (-> Univ) Univ - #:lock-there lock-there-type #f #:max-delay max-delay-type #f - (-> -Pathlike Univ)) - (->key -Real Sym (-> Univ) Univ (-opt -Pathlike) - #:lock-there lock-there-type #f #:max-delay max-delay-type #f - (-> -Pathlike Univ))))] - -[call-with-file-lock/timeout - (-poly (a) - (->key (-opt -Pathlike) - (one-of/c 'shared 'exclusive) - (-> a) - (-> a) - #:lock-file (-opt -Pathlike) #f - #:delay -Real #f - #:max-delay -Real #f - a))] -|# [make-lock-file-name (->opt -Pathlike [-Pathlike] -Pathlike)] diff --git a/collects/typed-scheme/base-env/base-special-env.rkt b/collects/typed-scheme/base-env/base-special-env.rkt index 17b1e2e67f..feca7b9e6a 100644 --- a/collects/typed-scheme/base-env/base-special-env.rkt +++ b/collects/typed-scheme/base-env/base-special-env.rkt @@ -32,7 +32,7 @@ #:context #'make-promise [(_ mp . _) #'mp]) (-poly (a) (-> (-> a) (-Promise a)))] - + ;; language [(syntax-parse (local-expand #'(this-language) 'expression null) #:context #'language @@ -185,6 +185,10 @@ #'with-syntax-fail]) (-> (-Syntax Univ) (Un))] + + [(local-expand #'make-temporary-file 'expression #f) + (->opt [-String (Un -Pathlike (-val 'directory) (-val #f)) (-opt -Pathlike)] -Path)] + ;; below here: keyword-argument functions from the base environment ;; FIXME: abstraction to remove duplication here #:middle From 07c5c076e2195afe69c9c483dc2eadd89134bf96 Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Mon, 29 Aug 2011 12:47:24 -0600 Subject: [PATCH 007/235] Fix cpointer and cstruct tag text --- collects/scribblings/foreign/cpointer.scrbl | 11 ++++++----- collects/scribblings/foreign/types.scrbl | 9 ++++++--- 2 files changed, 12 insertions(+), 8 deletions(-) diff --git a/collects/scribblings/foreign/cpointer.scrbl b/collects/scribblings/foreign/cpointer.scrbl index 4faf57f91a..5c40a00f4d 100644 --- a/collects/scribblings/foreign/cpointer.scrbl +++ b/collects/scribblings/foreign/cpointer.scrbl @@ -22,9 +22,10 @@ to Racket, and accept only such tagged pointers when going to C. An optional @racket[ptr-type] can be given to be used as the base pointer type, instead of @racket[_pointer]. -By convention, tags should be symbols named after the -type they point to. For example, the cpointer @racket[_car] should -be created using @racket['car] as the key. +By convention, tags are symbols named after the +type they point to. For example, the cpointer @racket[_car] would +be created using @racket['car] as the key. However, any symbol can be +used as the tag. Pointer tags are checked with @racket[cpointer-has-tag?] and changed with @racket[cpointer-push-tag!] which means that other tags are preserved. Specifically, if a base @racket[ptr-type] is given and is @@ -46,7 +47,7 @@ are not tagged.} scheme-to-c-expr c-to-scheme-expr)]]{ A macro version of @racket[_cpointer] and @racket[_cpointer/null], -using the defined name for a tag string, and defining a predicate +using the defined name for a tag symbol, and defining a predicate too. The @racket[_id] must start with @litchar{_}. The optional expressions produce optional arguments to @racket[_cpointer]. @@ -56,7 +57,7 @@ In addition to defining @racket[_id] to a type generated by type produced by @racket[_cpointer/null] type. Finally, @racketvarfont{id}@racketidfont{?} is defined as a predicate, and @racketvarfont{id}@racketidfont{-tag} is defined as an accessor to -obtain a tag. The tag is the string form of @racketvarfont{id}.} +obtain a tag. The tag is the symbol form of @racketvarfont{id}.} @defproc*[([(cpointer-has-tag? [cptr any/c] [tag any/c]) boolean?] [(cpointer-push-tag! [cptr any/c] [tag any/c]) void])]{ diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index 91f8b48960..b9b0db7b7a 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -857,8 +857,10 @@ The resulting bindings are as follows: @item{@racketvarfont{id}@racketidfont{?}: a predicate for the new type.} - @item{@racketvarfont{id}@racketidfont{-tag}: the tag string object that is - used with instances.} + @item{@racketvarfont{id}@racketidfont{-tag}: the tag object that is + used with instances. The tag object may be the symbol form of + @racketvarfont{id} or a list of symbols containing the @racketvarfont{id} + symbol and other symbols, such as the @racketvarfont[super-id] symbol.} @item{@racketidfont{make-}@racketvarfont{id} : a constructor, which expects an argument for each type.} @@ -879,7 +881,8 @@ The resulting bindings are as follows: ] Objects of the new type are actually C pointers, with a type tag that -is a list that contains the string form of @racketvarfont{id}. Since +is the symbol form of @racketvarfont{id} or a list that contains the +symbol form of @racketvarfont{id}. Since structs are implemented as pointers, they can be used for a @racket[_pointer] input to a foreign function: their address will be used. To make this a little safer, the corresponding cpointer type is From 50745a8219ed48278100e47265bc8425186df0cc Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Mon, 29 Aug 2011 12:47:53 -0600 Subject: [PATCH 008/235] Accumulate fds for cleanup on exception --- src/racket/src/network.c | 13 ++++ src/racket/src/place.c | 142 +++++++++++++++++++++------------------ src/racket/src/port.c | 13 ++++ src/racket/src/schpriv.h | 2 + 4 files changed, 106 insertions(+), 64 deletions(-) diff --git a/src/racket/src/network.c b/src/racket/src/network.c index c11d8ec563..e579f0a490 100644 --- a/src/racket/src/network.c +++ b/src/racket/src/network.c @@ -2525,6 +2525,19 @@ intptr_t scheme_dup_socket(intptr_t fd) { #endif } +void scheme_close_socket_fd(intptr_t fd) { +# ifdef USE_WINSOCK_TCP + close(fd); +# else + { + intptr_t rc; + do { + rc = close(fd); + } while (rc == -1 && errno == EINTR); + } +# endif +} + /*========================================================================*/ /* UDP */ /*========================================================================*/ diff --git a/src/racket/src/place.c b/src/racket/src/place.c index da45492936..ac5b27654d 100644 --- a/src/racket/src/place.c +++ b/src/racket/src/place.c @@ -856,10 +856,50 @@ static void bad_place_message(Scheme_Object *so) { so); } -static Scheme_Object *make_serialized_tcp_fd(intptr_t fd, intptr_t type) { +static void bad_place_message2(Scheme_Object *so, Scheme_Object *o, int can_raise_exn) { + Scheme_Object *l; + Scheme_Vector *v = (Scheme_Vector *) o; + if (v) { + if (SCHEME_VEC_ELS(v)[0]) { + l = SCHEME_VEC_ELS(v)[0]; + while (SCHEME_PAIRP(l)) { + scheme_close_file_fd(SCHEME_INT_VAL(SCHEME_CAR(l))); + l = SCHEME_CDR(l); + SCHEME_USE_FUEL(1); + } + } + if (SCHEME_VEC_ELS(v)[1]) { + l = SCHEME_VEC_ELS(v)[0]; + while (SCHEME_PAIRP(l)) { + scheme_close_socket_fd(SCHEME_INT_VAL(SCHEME_CAR(l))); + l = SCHEME_CDR(l); + SCHEME_USE_FUEL(1); + } + } + } + if (can_raise_exn) + bad_place_message(so); +} +static void push_duped_fd(Scheme_Object **fd_accumulators, intptr_t slot, intptr_t dupfd) { + Scheme_Object *tmp; + Scheme_Vector *v; + if (fd_accumulators) { + if (!*fd_accumulators) { + tmp = scheme_make_vector(2, scheme_null); + *fd_accumulators = tmp; + } + v = (Scheme_Vector*) *fd_accumulators; + + tmp = scheme_make_pair(scheme_make_integer(dupfd), SCHEME_VEC_ELS(v)[slot]); + SCHEME_VEC_ELS(v)[slot] = tmp; + } +} + +static Scheme_Object *make_serialized_tcp_fd(intptr_t fd, intptr_t type, Scheme_Object **fd_accumulators) { Scheme_Simple_Object *so; int dupfd; dupfd = scheme_dup_socket(fd); + push_duped_fd(fd_accumulators, 1, dupfd); so = scheme_malloc_small_atomic_tagged(sizeof(Scheme_Simple_Object)); so->iso.so.type = scheme_serialized_tcp_fd_type; so->u.two_int_val.int1 = type; @@ -895,7 +935,7 @@ static Scheme_Object *trivial_copy(Scheme_Object *so) return NULL; } -static Scheme_Object *shallow_types_copy(Scheme_Object *so, Scheme_Hash_Table *ht, int copy, int can_raise_exn) { +static Scheme_Object *shallow_types_copy(Scheme_Object *so, Scheme_Hash_Table *ht, Scheme_Object **fd_accumulators,int copy, int can_raise_exn) { Scheme_Object *new_so; new_so = trivial_copy(so); @@ -918,8 +958,8 @@ static Scheme_Object *shallow_types_copy(Scheme_Object *so, Scheme_Hash_Table *h Scheme_Object *d; n = scheme_rational_numerator(so); d = scheme_rational_denominator(so); - n = shallow_types_copy(n, NULL, copy, can_raise_exn); - d = shallow_types_copy(d, NULL, copy, can_raise_exn); + n = shallow_types_copy(n, NULL, fd_accumulators, copy, can_raise_exn); + d = shallow_types_copy(d, NULL, fd_accumulators, copy, can_raise_exn); if (copy) new_so = scheme_make_rational(n, d); } @@ -938,8 +978,8 @@ static Scheme_Object *shallow_types_copy(Scheme_Object *so, Scheme_Hash_Table *h Scheme_Object *i; r = scheme_complex_real_part(so); i = scheme_complex_imaginary_part(so); - r = shallow_types_copy(r, NULL, copy, can_raise_exn); - i = shallow_types_copy(i, NULL, copy, can_raise_exn); + r = shallow_types_copy(r, NULL, fd_accumulators, copy, can_raise_exn); + i = shallow_types_copy(i, NULL, fd_accumulators, copy, can_raise_exn); if (copy) new_so = scheme_make_complex(r, i); } @@ -965,10 +1005,8 @@ static Scheme_Object *shallow_types_copy(Scheme_Object *so, Scheme_Hash_Table *h break; case scheme_symbol_type: if (SCHEME_SYM_UNINTERNEDP(so)) { - if (can_raise_exn) - bad_place_message(so); - else - return NULL; + bad_place_message2(so, *fd_accumulators, can_raise_exn); + return NULL; } else { if (copy) { new_so = scheme_make_sized_offset_byte_string((char *)so, SCHEME_SYMSTR_OFFSET(so), SCHEME_SYM_LEN(so), 1); @@ -1024,16 +1062,16 @@ static Scheme_Object *shallow_types_copy(Scheme_Object *so, Scheme_Hash_Table *h o->type = scheme_cpointer_type; SCHEME_CPTR_FLAGS(o) |= 0x1; SCHEME_CPTR_VAL(o) = SCHEME_CPTR_VAL(so); - o2 = shallow_types_copy(SCHEME_CPTR_TYPE(so), NULL, copy, can_raise_exn); + o2 = shallow_types_copy(SCHEME_CPTR_TYPE(so), NULL, fd_accumulators, copy, can_raise_exn); SCHEME_CPTR_TYPE(o) = o2; new_so = o; } } - else if (can_raise_exn) - bad_place_message(so); - else + else { + bad_place_message2(so, *fd_accumulators, can_raise_exn); return NULL; + } break; case scheme_input_port_type: case scheme_output_port_type: @@ -1041,7 +1079,7 @@ static Scheme_Object *shallow_types_copy(Scheme_Object *so, Scheme_Hash_Table *h intptr_t fd; if(scheme_get_port_socket(so, &fd)) { if (copy) { - new_so = make_serialized_tcp_fd(fd, so->type); + new_so = make_serialized_tcp_fd(fd, so->type, fd_accumulators); } } else if (SCHEME_TRUEP(scheme_file_stream_port_p(1, &so))) { @@ -1053,23 +1091,24 @@ static Scheme_Object *shallow_types_copy(Scheme_Object *so, Scheme_Hash_Table *h sffd->so.type = scheme_serialized_file_fd_type; scheme_get_serialized_fd_flags(so, sffd); if (sffd->name) { - tmp = shallow_types_copy(sffd->name, ht, copy, can_raise_exn); + tmp = shallow_types_copy(sffd->name, ht, fd_accumulators, copy, can_raise_exn); sffd->name = tmp; } dupfd = scheme_dup_file(fd); + push_duped_fd(fd_accumulators, 0, dupfd); sffd->fd = dupfd; sffd->type = so->type; new_so = (Scheme_Object *) sffd; } - else if (can_raise_exn) - bad_place_message(so); - else + else { + bad_place_message2(so, *fd_accumulators, can_raise_exn); return NULL; + } } - else if (can_raise_exn) - bad_place_message(so); - else + else { + bad_place_message2(so, *fd_accumulators, can_raise_exn); return NULL; + } } break; case scheme_serialized_tcp_fd_type: @@ -1256,6 +1295,8 @@ static Scheme_Object *places_deep_copy_worker(Scheme_Object *so, Scheme_Hash_Tab Scheme_Object *inf_stack = NULL; Scheme_Object *reg0 = NULL; uintptr_t inf_stack_depth = 0; + + Scheme_Object *fd_accumulators = NULL; /* lifted variables for xform*/ Scheme_Object *pair; @@ -1292,7 +1333,7 @@ static Scheme_Object *places_deep_copy_worker(Scheme_Object *so, Scheme_Hash_Tab int ctr = 0; /* First, check for simple values that don't need to be hashed: */ - new_so = shallow_types_copy(so, *ht, copy, can_raise_exn); + new_so = shallow_types_copy(so, *ht, &fd_accumulators, copy, can_raise_exn); if (new_so) return new_so; if (*ht) { @@ -1328,7 +1369,7 @@ DEEP_DO: } } - new_so = shallow_types_copy(so, *ht, copy, can_raise_exn); + new_so = shallow_types_copy(so, *ht, &fd_accumulators, copy, can_raise_exn); if (new_so) RETURN; new_so = so; @@ -1429,21 +1470,15 @@ DEEP_VEC2: local_slots = stype->num_slots - (ptype ? ptype->num_slots : 0); if (!stype->prefab_key) { - if (can_raise_exn) - bad_place_message(so); - else { - new_so = NULL; - ABORT; - } + bad_place_message2(so, fd_accumulators, can_raise_exn); + new_so = NULL; + ABORT; } for (i = 0; i < local_slots; i++) { if (!stype->immutables || stype->immutables[i] != 1) { - if (can_raise_exn) - bad_place_message(so); - else { - new_so = NULL; - ABORT; - } + bad_place_message2(so, fd_accumulators, can_raise_exn); + new_so = NULL; + ABORT; } } @@ -1561,12 +1596,9 @@ DEEP_SST2_L: } break; default: - if (can_raise_exn) - bad_place_message(so); - else { - new_so = NULL; - ABORT; - } + bad_place_message2(so, fd_accumulators, can_raise_exn); + new_so = NULL; + ABORT; break; } @@ -1928,19 +1960,10 @@ static void places_deserialize_clean_worker(Scheme_Object **pso, Scheme_Hash_Tab Scheme_Object *in; Scheme_Object *out; int fd = ((Scheme_Simple_Object *) so)->u.two_int_val.int2; -# ifdef USE_WINSOCK_TCP - close(fd); -# else - { - intptr_t rc; - do { - rc = close(fd); - } while (rc == -1 && errno == EINTR); - } -# endif + scheme_close_socket_fd(fd); } else { - tmp = shallow_types_copy(so, NULL, 1, 1); + tmp = shallow_types_copy(so, NULL, NULL, 1, 1); *pso = tmp; } break; @@ -1948,19 +1971,10 @@ static void places_deserialize_clean_worker(Scheme_Object **pso, Scheme_Hash_Tab if (clean) { Scheme_Serialized_File_FD *sffd; sffd = (Scheme_Serialized_File_FD *) so; -#ifdef WINDOWS_FILE_HANDLES - CloseHandle((HANDLE)sffd->fd); -#else - { - intptr_t rc; - do { - rc = close(sffd->fd); - } while (rc == -1 && errno == EINTR); - } -#endif + scheme_close_file_fd(sffd->fd); } else { - tmp = shallow_types_copy(so, NULL, 1, 1); + tmp = shallow_types_copy(so, NULL, NULL, 1, 1); *pso = tmp; } break; diff --git a/src/racket/src/port.c b/src/racket/src/port.c index 0602c4d9e6..ad4d4c7996 100644 --- a/src/racket/src/port.c +++ b/src/racket/src/port.c @@ -1209,6 +1209,19 @@ intptr_t scheme_dup_file(intptr_t fd) { #endif } +void scheme_close_file_fd(intptr_t fd) { +#ifdef WINDOWS_FILE_HANDLES + CloseHandle((HANDLE)fd); +#else + { + intptr_t rc; + do { + rc = close(fd); + } while (rc == -1 && errno == EINTR); + } +#endif +} + /*========================================================================*/ /* Windows thread suspension */ diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index f1368ee924..d01acc9e3b 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -3695,6 +3695,8 @@ typedef struct Scheme_Serialized_File_FD{ int scheme_get_serialized_fd_flags(Scheme_Object* p, Scheme_Serialized_File_FD *so); intptr_t scheme_dup_socket(intptr_t fd); intptr_t scheme_dup_file(intptr_t fd); +void scheme_close_socket_fd(intptr_t fd); +void scheme_close_file_fd(intptr_t fd); #define SCHEME_PLACE_OBJECTP(o) (SCHEME_TYPE(o) == scheme_place_object_type) From d5d28d3357aebec76fac1cff2c5bbe2d6ace4912 Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Tue, 30 Aug 2011 11:27:18 -0600 Subject: [PATCH 009/235] fix [] to {} --- collects/scribblings/foreign/types.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index b9b0db7b7a..6e25c0b553 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -860,7 +860,7 @@ The resulting bindings are as follows: @item{@racketvarfont{id}@racketidfont{-tag}: the tag object that is used with instances. The tag object may be the symbol form of @racketvarfont{id} or a list of symbols containing the @racketvarfont{id} - symbol and other symbols, such as the @racketvarfont[super-id] symbol.} + symbol and other symbols, such as the @racketvarfont{super-id} symbol.} @item{@racketidfont{make-}@racketvarfont{id} : a constructor, which expects an argument for each type.} From c13c22f0e43f088a4e1cb9a5f8a20aa80c7fc2dc Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sat, 27 Aug 2011 19:27:44 -0600 Subject: [PATCH 010/235] fixed missing arg to raise-type-error --- collects/racket/vector.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/racket/vector.rkt b/collects/racket/vector.rkt index 925748c886..e53e8e47e9 100644 --- a/collects/racket/vector.rkt +++ b/collects/racket/vector.rkt @@ -231,7 +231,7 @@ (define-syntax-rule (vm-mk name cmp) (define (name val vec) (unless (vector? vec) - (raise-type-error 'name "vector" 1 vec)) + (raise-type-error 'name "vector" 1 val vec)) (let ([sz (unsafe-vector-length vec)]) (let loop ([k 0]) (cond [(= k sz) #f] From 1c6817426efa56727be7083256ef608e17e1edc3 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sat, 27 Aug 2011 18:13:23 -0600 Subject: [PATCH 011/235] db: added group-rows, #:group arg to query-rows --- collects/db/private/generic/functions.rkt | 176 +++++++++++++++++++++- collects/db/scribblings/config.rkt | 5 +- collects/db/scribblings/query.scrbl | 55 ++++++- collects/tests/db/all-tests.rkt | 6 +- collects/tests/db/gen/query.rkt | 57 +++++++ 5 files changed, 290 insertions(+), 9 deletions(-) create mode 100644 collects/tests/db/gen/query.rkt diff --git a/collects/db/private/generic/functions.rkt b/collects/db/private/generic/functions.rkt index 50514edbef..25fbbbad61 100644 --- a/collects/db/private/generic/functions.rkt +++ b/collects/db/private/generic/functions.rkt @@ -1,9 +1,11 @@ #lang racket/base (require (for-syntax racket/base) racket/contract + racket/vector unstable/prop-contract racket/class - "interfaces.rkt") + "interfaces.rkt" + (only-in "sql-data.rkt" sql-null sql-null?)) ;; == Administrative procedures @@ -84,7 +86,7 @@ (define (query1 c fsym stmt) (send c query fsym stmt)) -;; query/rows : connection symbol Statement nat/#f -> void +;; query/rows : connection symbol Statement nat/#f -> rows-result (define (query/rows c fsym sql want-columns) (let [(result (query1 c fsym sql))] (unless (rows-result? result) @@ -135,9 +137,19 @@ ;; Query API procedures ;; query-rows : connection Statement arg ... -> (listof (vectorof 'a)) -(define (query-rows c sql . args) - (let ([sql (compose-statement 'query-rows c sql args 'rows)]) - (rows-result-rows (query/rows c 'query-rows sql #f)))) +(define (query-rows c sql + #:group [group-fields-list null] + #:group-mode [group-mode null] + . args) + (let* ([sql (compose-statement 'query-rows c sql args 'rows)] + [result (query/rows c 'query-rows sql #f)] + [result + (cond [(pair? group-fields-list) + (group-rows-result* 'query-rows result group-fields-list + (not (memq 'preserve-null-rows group-mode)) + (memq 'list group-mode))] + [else result])]) + (rows-result-rows result))) ;; query-list : connection Statement arg ... -> (listof 'a) ;; Expects to get back a rows-result with one field per row. @@ -392,3 +404,157 @@ [get-tables (-> connection? (listof vector?))] |#) + + +;; ======================================== + +(define (group-rows result + #:group key-fields-list + #:group-mode [group-mode null]) + (when (null? key-fields-list) + (error 'group-rows "expected at least one grouping field set")) + (group-rows-result* 'group-rows + result + key-fields-list + (not (memq 'preserve-null-rows group-mode)) + (memq 'list group-mode))) + +(define (group-rows-result* fsym result key-fields-list invert-outer? as-list?) + (let* ([key-fields-list + (if (list? key-fields-list) key-fields-list (list key-fields-list))] + [total-fields (length (rows-result-headers result))] + [name-map + (for/hash ([header (in-list (rows-result-headers result))] + [i (in-naturals)] + #:when (assq 'name header)) + (values (cdr (assq 'name header)) i))] + [fields-used (make-vector total-fields #f)] + [key-indexes-list + (for/list ([key-fields (in-list key-fields-list)]) + (for/vector ([key-field (in-vector key-fields)]) + (let ([key-index + (cond [(string? key-field) + (hash-ref name-map key-field #f)] + [else key-field])]) + (when (string? key-field) + (unless key-index + (error fsym "grouping field ~s not found" key-field))) + (when (exact-integer? key-field) + (unless (< key-index total-fields) + (error fsym "grouping index ~s out of range [0, ~a]" + key-index (sub1 total-fields)))) + (when (vector-ref fields-used key-index) + (error fsym "grouping field ~s~a used multiple times" + key-field + (if (string? key-field) + (format " (index ~a)" key-index) + ""))) + (vector-set! fields-used key-index #t) + key-index)))] + [residual-length + (for/sum ([x (in-vector fields-used)]) + (if x 0 1))]) + (when (= residual-length 0) + (error fsym "cannot group by all fields")) + (when (and (> residual-length 1) as-list?) + (error fsym + "exactly one residual field expected for #:group-mode 'list, got ~a" + residual-length)) + (let* ([initial-projection + (for/vector #:length total-fields ([i (in-range total-fields)]) i)] + [headers + (group-headers (list->vector (rows-result-headers result)) + initial-projection + key-indexes-list)] + [rows + (group-rows* fsym + (rows-result-rows result) + initial-projection + key-indexes-list + invert-outer? + as-list?)]) + (rows-result headers rows)))) + +(define (group-headers headers projection key-indexes-list) + (define (get-headers vec) + (for/list ([index (in-vector vec)]) + (vector-ref headers index))) + (cond [(null? key-indexes-list) + (get-headers projection)] + [else + (let* ([key-indexes (car key-indexes-list)] + [residual-projection + (vector-filter-not (lambda (index) (vector-member index key-indexes)) + projection)] + [residual-headers + (group-headers headers residual-projection (cdr key-indexes-list))]) + (append (get-headers key-indexes) + (list `((grouped . ,residual-headers)))))])) + +(define (group-rows* fsym rows projection key-indexes-list invert-outer? as-list?) + ;; projection is vector of indexes (actually projection and permutation) + ;; invert-outer? => residual rows with all NULL fields are dropped. + (cond [(null? key-indexes-list) + ;; Apply projection to each row + (cond [as-list? + (unless (= (vector-length projection) 1) + (error/internal + fsym + "list mode requires a single residual column, got ~s" + (vector-length projection))) + (let ([index (vector-ref projection 0)]) + (for/list ([row (in-list rows)]) + (vector-ref row index)))] + [else + (let ([plen (vector-length projection)]) + (for/list ([row (in-list rows)]) + (let ([v (make-vector plen)]) + (for ([i (in-range plen)]) + (vector-set! v i (vector-ref row (vector-ref projection i)))) + v)))])] + [else + (let () + (define key-indexes (car key-indexes-list)) + (define residual-projection + (vector-filter-not (lambda (index) (vector-member index key-indexes)) + projection)) + + (define key-row-length (vector-length key-indexes)) + (define (row->key-row row) + (for/vector #:length key-row-length + ([i (in-vector key-indexes)]) + (vector-ref row i))) + + (define (residual-all-null? row) + (for/and ([i (in-vector residual-projection)]) + (sql-null? (vector-ref row i)))) + + (let* ([key-table (make-hash)] + [r-keys + (for/fold ([r-keys null]) + ([row (in-list rows)]) + (let* ([key-row (row->key-row row)] + [already-seen? (and (hash-ref key-table key-row #f) #t)]) + (unless already-seen? + (hash-set! key-table key-row null)) + (unless (and invert-outer? (residual-all-null? row)) + (hash-set! key-table key-row (cons row (hash-ref key-table key-row)))) + (if already-seen? + r-keys + (cons key-row r-keys))))]) + (for/list ([key (in-list (reverse r-keys))]) + (let ([residuals + (group-rows* fsym + (reverse (hash-ref key-table key)) + residual-projection + (cdr key-indexes-list) + invert-outer? + as-list?)]) + (vector-append key (vector residuals))))))])) + +(provide/contract + [group-rows + (->* (rows-result? + #:group (or/c (vectorof string?) (listof (vectorof string?)))) + (#:group-mode (listof (or/c 'preserve-null-rows 'list))) + rows-result?)]) diff --git a/collects/db/scribblings/config.rkt b/collects/db/scribblings/config.rkt index d7f8479318..33befe0b57 100644 --- a/collects/db/scribblings/config.rkt +++ b/collects/db/scribblings/config.rkt @@ -14,8 +14,11 @@ (void (interaction-eval #:eval the-eval (require racket/class - db + racket/pretty + db/base db/util/datetime)) + (interaction-eval #:eval the-eval + (current-print pretty-print-handler)) (interaction-eval #:eval the-eval (define connection% (class object% (super-new)))) (interaction-eval #:eval the-eval diff --git a/collects/db/scribblings/query.scrbl b/collects/db/scribblings/query.scrbl index 588d22f547..dbe48b7e77 100644 --- a/collects/db/scribblings/query.scrbl +++ b/collects/db/scribblings/query.scrbl @@ -118,7 +118,13 @@ The types of parameters and returned fields are described in @defproc[(query-rows [connection connection?] [stmt statement?] - [arg any/c] ...) + [arg any/c] ... + [#:group grouping-fields + (or/c (vectorof string?) (listof (vectorof string?))) + null] + [#:group-mode group-mode + (listof (or/c 'preserve-null-rows 'list)) + null]) (listof vector?)]{ Executes a SQL query, which must produce rows, and returns the list @@ -130,6 +136,9 @@ The types of parameters and returned fields are described in [(query-rows c "select 17") (list (vector 17))] ] + + If @racket[grouping-fields] is not empty, the result is the same as if + @racket[group-rows] had been called on the result rows. } @defproc[(query-list [connection connection?] @@ -286,6 +295,50 @@ future version of this library (even new minor versions). supports both rows-returning and effect-only queries. } +@defproc[(group-rows [result rows-result?] + [#:group grouping-fields + (or/c (vectorof string?) (listof (vectorof string?)))] + [#:group-mode group-mode + (listof (or/c 'preserve-null-rows 'list)) + null]) + rows-result?]{ + +If @racket[grouping-fields] is a vector, the elements must be names of +fields in @racket[result], and @racket[result]'s rows are regrouped +using the given fields. Each grouped row contains N+1 fields; the +first N fields are the @racket[grouping-fields], and the final field +is a list of ``residual rows'' over the rest of the fields. A residual +row of all NULLs is dropped (for convenient processing of @tt{OUTER +JOIN} results) unless @racket[group-mode] includes +@racket['preserve-null-rows]. If @racket[group-mode] contains +@racket['list], there must be exactly one residual field, and its +values are included without a vector wrapper (similar to +@racket[query-list]). + +@examples[#:eval the-eval +(define vehicles-result + (rows-result + '(((name . "type")) ((name . "maker")) ((name . "model"))) + `(#("car" "honda" "civic") + #("car" "ford" "focus") + #("car" "ford" "pinto") + #("bike" "giant" "boulder") + #("bike" "schwinn" ,sql-null)))) +(group-rows vehicles-result + #:group '(#("type"))) +] + +The @racket[grouping-fields] argument may also be a list of vectors; +in that case, the grouping process is repeated for each set of +grouping fields. The grouping fields must be distinct. + +@examples[#:eval the-eval +(group-rows vehicles-result + #:group '(#("type") #("maker")) + #:group-mode '(list)) +] +} + @section{Prepared Statements} diff --git a/collects/tests/db/all-tests.rkt b/collects/tests/db/all-tests.rkt index cd6bdc5f8d..e5d874721d 100644 --- a/collects/tests/db/all-tests.rkt +++ b/collects/tests/db/all-tests.rkt @@ -13,7 +13,8 @@ "db/sql-types.rkt" "db/concurrent.rkt")) (prefix-in gen- - "gen/sql-types.rkt")) + (combine-in "gen/sql-types.rkt" + "gen/query.rkt"))) (provide (all-defined-out)) #| @@ -157,7 +158,8 @@ Testing profiles are flattened, not hierarchical. (define generic-tests (make-test-suite "Generic tests (no db)" - (list gen-sql-types:test))) + (list gen-sql-types:test + gen-query:test))) ;; ---- diff --git a/collects/tests/db/gen/query.rkt b/collects/tests/db/gen/query.rkt new file mode 100644 index 0000000000..a858816329 --- /dev/null +++ b/collects/tests/db/gen/query.rkt @@ -0,0 +1,57 @@ +#lang racket/base +(require rackunit + racket/class + (prefix-in srfi: srfi/19) + db/base + "../config.rkt") + +(provide query:test) + +(define vehicles-result + (rows-result + '(((name . "type")) ((name . "maker")) ((name . "model"))) + `(#("car" "honda" "civic") + #("car" "ford" "focus") + #("car" "ford" "pinto") + #("bike" "giant" "boulder") + #("bike" "schwinn" ,sql-null)))) + +(define query:test + (test-suite "Query utilities" + (test-suite "group-rows" + (test-case "single grouping" + (check-equal? + (rows-result-rows (group-rows vehicles-result #:group '#("type"))) + `(#("car" (#("honda" "civic") + #("ford" "focus") + #("ford" "pinto"))) + #("bike" (#("giant" "boulder") + #("schwinn" ,sql-null)))))) + (test-case "multiple groupings" + (check-equal? + (rows-result-rows + (group-rows vehicles-result #:group '(#("type") #("maker")))) + `(#("car" (#("honda" (#("civic"))) + #("ford" (#("focus") #("pinto"))))) + #("bike" (#("giant" (#("boulder"))) + #("schwinn" ())))))) + (test-case "multiple groupings, preserve null rows" + (check-equal? + (rows-result-rows + (group-rows vehicles-result + #:group '(#("type") #("maker")) + #:group-mode '(preserve-null-rows))) + `(#("car" (#("honda" (#("civic"))) + #("ford" (#("focus") #("pinto"))))) + #("bike" (#("giant" (#("boulder"))) + #("schwinn" (#(,sql-null)))))))) + (test-case "multiple groupings, list" + (check-equal? + (rows-result-rows + (group-rows vehicles-result + #:group '(#("type") #("maker")) + #:group-mode '(list))) + `(#("car" (#("honda" ("civic")) + #("ford" ("focus" "pinto")))) + #("bike" (#("giant" ("boulder")) + #("schwinn" ()))))))))) From b3e55dc0781ac03ceaf221eaa44cbdd42d028a2a Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 29 Aug 2011 00:26:06 -0600 Subject: [PATCH 012/235] db: added note on sql injection, moved param paras to stmt section --- collects/db/scribblings/query.scrbl | 37 +++++++++++++++++++---------- 1 file changed, 24 insertions(+), 13 deletions(-) diff --git a/collects/db/scribblings/query.scrbl b/collects/db/scribblings/query.scrbl index dbe48b7e77..0f2d9a848c 100644 --- a/collects/db/scribblings/query.scrbl +++ b/collects/db/scribblings/query.scrbl @@ -68,8 +68,7 @@ way to make kill-safe connections. All query functions require both a connection and a @deftech{statement}, which is one of the following: @itemlist[ -@item{a string containing a single SQL statement, possibly with - parameters} +@item{a string containing a single SQL statement} @item{a @tech{prepared statement} produced by @racket[prepare]} @item{a @tech{virtual statement} produced by @racket[virtual-statement]} @@ -78,6 +77,29 @@ All query functions require both a connection and a @item{an instance of a struct type that implements @racket[prop:statement]} ] +A SQL statement may contain parameter placeholders that stand for SQL +scalar values. The parameter values must be supplied when the +statement is executed; the parameterized statement and parameter +values are sent to the database back end, which combines them +correctly and safely. + +Use parameters instead of Racket string interpolation (eg, +@racket[format] or @racket[string-append]) to avoid +@hyperlink["http://xkcd.com/327/"]{SQL injection}, where a string +intended to represent a SQL scalar value is interpreted as---possibly +malicious---SQL code instead. + +The syntax of placeholders varies depending on the database +system. For example: + +@centered{ +@tabbing{ +PostgreSQL: @& @tt{select * from the_numbers where n > $1;} @// +MySQL, ODBC: @& @tt{select * from the_numbers where n > ?;} @// +SQLite: @& supports both syntaxes (plus others) +} +} + @defproc[(statement? [x any/c]) boolean?]{ Returns @racket[#t] if @racket[x] is a @tech{statement}, @racket[#f] @@ -345,17 +367,6 @@ grouping fields. The grouping fields must be distinct. A @deftech{prepared statement} is the result of a call to @racket[prepare]. -The syntax of parameterized queries varies depending on the database -system. For example: - -@centered{ -@tabbing{ -PostgreSQL: @& @tt{select * from the_numbers where n > $1;} @// -MySQL, ODBC: @& @tt{select * from the_numbers where n > ?;} @// -SQLite: @& supports both syntaxes (plus others) -} -} - Any server-side or native-library resources associated with a prepared statement are released when the prepared statement is garbage-collected or when the connection that owns it is closed; From 94456ad0ec3b1d3f0d2aa0b5544d5fad49ad0a88 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 29 Aug 2011 01:25:28 -0600 Subject: [PATCH 013/235] db: moved pg-only code out of interfaces module --- collects/db/private/generic/interfaces.rkt | 11 ----------- collects/db/private/postgresql/connection.rkt | 7 +++++++ 2 files changed, 7 insertions(+), 11 deletions(-) diff --git a/collects/db/private/generic/interfaces.rkt b/collects/db/private/generic/interfaces.rkt index 0fb17ebc46..8dd09def6c 100644 --- a/collects/db/private/generic/interfaces.rkt +++ b/collects/db/private/generic/interfaces.rkt @@ -14,7 +14,6 @@ define-type-table no-cache-prepare<%> - connector<%> locking% transactions% @@ -176,16 +175,6 @@ (list ok? t x))))) -;; == Internal staging interfaces - -;; connector<%> -;; Manages making connections -(define connector<%> - (interface () - attach-to-ports ;; input-port output-port -> void - start-connection-protocol ;; string string string/#f -> void - )) - ;; == Notice/notification handler maker ;; make-handler : output-port/symbol string -> string string -> void diff --git a/collects/db/private/postgresql/connection.rkt b/collects/db/private/postgresql/connection.rkt index 9f036fff11..ded03dffc6 100644 --- a/collects/db/private/postgresql/connection.rkt +++ b/collects/db/private/postgresql/connection.rkt @@ -14,6 +14,13 @@ ;; ======================================== +;; connector<%> +;; Manages making connections +(define connector<%> + (interface () + attach-to-ports ;; input-port output-port -> void + start-connection-protocol)) ;; string string string/#f -> void + (define connection-base% (class* transactions% (connection<%> connector<%>) (init-private notice-handler From 397702808ad5b96f573a9ed7b38c653cbebaea70 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 29 Aug 2011 01:23:17 -0600 Subject: [PATCH 014/235] db: fixed virtual-statement Eliminated interface test (shallow) in favor of method test (correct, recursive). Also made vstmts work with virtual-connections. --- collects/db/private/generic/connect-util.rkt | 10 ++++++-- collects/db/private/generic/functions.rkt | 14 ++++++----- collects/db/private/generic/interfaces.rkt | 17 +++---------- collects/db/private/mysql/connection.rkt | 2 ++ collects/db/private/odbc/connection.rkt | 2 ++ collects/db/private/postgresql/connection.rkt | 2 ++ collects/db/private/sqlite3/connection.rkt | 2 ++ collects/tests/db/db/query.rkt | 25 +++++++++++++++++++ 8 files changed, 52 insertions(+), 22 deletions(-) diff --git a/collects/db/private/generic/connect-util.rkt b/collects/db/private/generic/connect-util.rkt index 9dc8cda696..6d4074fbcc 100644 --- a/collects/db/private/generic/connect-util.rkt +++ b/collects/db/private/generic/connect-util.rkt @@ -61,6 +61,7 @@ (get-dbsystem) (query fsym stmt) (prepare fsym stmt close-on-exec?) + (get-base) (free-statement stmt) (transaction-status fsym) (start-transaction fsym isolation) @@ -80,7 +81,7 @@ ;; Virtual connection (define virtual-connection% - (class* object% (connection<%> no-cache-prepare<%>) + (class* object% (connection<%>) (init-private connector ;; called from client thread get-key ;; called from client thread timeout) @@ -178,6 +179,9 @@ (#f #f (transaction-status fsym)) (#t '_ (list-tables fsym schema))) + (define/public (get-base) + (get-connection #t)) + (define/public (disconnect) (let ([c (get-connection #f)] [key (get-key)]) @@ -187,7 +191,8 @@ (void)) (define/public (prepare fsym stmt close-on-exec?) - (unless close-on-exec? + ;; FIXME: hacky way of supporting virtual-statement + (unless (or close-on-exec? (eq? fsym 'virtual-statement)) (error fsym "cannot prepare statement with virtual connection")) (send (get-connection #t) prepare fsym stmt close-on-exec?)) @@ -329,6 +334,7 @@ (get-dbsystem) (query fsym stmt) (prepare fsym stmt close-on-exec?) + (get-base) (free-statement stmt) (transaction-status fsym) (start-transaction fsym isolation) diff --git a/collects/db/private/generic/functions.rkt b/collects/db/private/generic/functions.rkt index 25fbbbad61..d5bd0e8f20 100644 --- a/collects/db/private/generic/functions.rkt +++ b/collects/db/private/generic/functions.rkt @@ -63,14 +63,16 @@ (struct virtual-statement (table gen) #:property prop:statement (lambda (stmt c) - (let ([table (virtual-statement-table stmt)] - [gen (virtual-statement-gen stmt)] - [cache? (not (is-a? c no-cache-prepare<%>))]) - (let ([table-pst (hash-ref table c #f)]) + (let* ([table (virtual-statement-table stmt)] + [gen (virtual-statement-gen stmt)] + [base-c (send c get-base)]) + (let ([table-pst (and base-c (hash-ref table base-c #f))]) (or table-pst (let* ([sql-string (gen (send c get-dbsystem))] - [pst (prepare1 'virtual-statement c sql-string (not cache?))]) - (when cache? (hash-set! table c pst)) + ;; FIXME: virtual-connection:prepare1 handles + ;; fsym = 'virtual-statement case specially + [pst (prepare1 'virtual-statement c sql-string #f)]) + (hash-set! table base-c pst) pst)))))) (define virtual-statement* diff --git a/collects/db/private/generic/interfaces.rkt b/collects/db/private/generic/interfaces.rkt index 8dd09def6c..9ac8eaf7c9 100644 --- a/collects/db/private/generic/interfaces.rkt +++ b/collects/db/private/generic/interfaces.rkt @@ -13,8 +13,6 @@ define-type-table - no-cache-prepare<%> - locking% transactions% @@ -41,21 +39,12 @@ get-dbsystem ;; -> dbsystem<%> query ;; symbol statement -> QueryResult prepare ;; symbol preparable boolean -> prepared-statement<%> - + get-base ;; -> connection<%> or #f (#f means base isn't fixed) + list-tables ;; symbol symbol -> (listof string) start-transaction ;; symbol (U 'serializable ...) -> void end-transaction ;; symbol (U 'commit 'rollback) -> void transaction-status ;; symbol -> (U boolean 'invalid) - - list-tables ;; symbol symbol -> (listof string) - - free-statement)) ;; prepared-statement<%> -> void - -;; no-cache-prepare<%> -;; Interface to identify connections such as connection-generators: -;; prepare method must be called with close-on-exec? = #t and result must -;; not be cached. -(define no-cache-prepare<%> - (interface ())) + free-statement)) ;; prepared-statement<%> -> void ;; ==== DBSystem diff --git a/collects/db/private/mysql/connection.rkt b/collects/db/private/mysql/connection.rkt index a1fa843c93..78848a4d99 100644 --- a/collects/db/private/mysql/connection.rkt +++ b/collects/db/private/mysql/connection.rkt @@ -356,6 +356,8 @@ [(? field-packet?) (cons (parse-field-dvec r) (prepare1:get-field-descriptions fsym))]))) + (define/public (get-base) this) + (define/public (free-statement pst) (call-with-lock* 'free-statement (lambda () diff --git a/collects/db/private/odbc/connection.rkt b/collects/db/private/odbc/connection.rkt index 6dc463463a..b96ef2f293 100644 --- a/collects/db/private/odbc/connection.rkt +++ b/collects/db/private/odbc/connection.rkt @@ -452,6 +452,8 @@ (void))))) (call-with-lock* 'disconnect go go #f)) + (define/public (get-base) this) + (define/public (free-statement pst) (define (go) (free-statement* 'free-statement pst)) (call-with-lock* 'free-statement go go #f)) diff --git a/collects/db/private/postgresql/connection.rkt b/collects/db/private/postgresql/connection.rkt index ded03dffc6..fbd65cfa2b 100644 --- a/collects/db/private/postgresql/connection.rkt +++ b/collects/db/private/postgresql/connection.rkt @@ -403,6 +403,8 @@ (set! name-counter (add1 name-counter)) (format "λmz_~a_~a" process-id n))) + (define/public (get-base) this) + ;; free-statement : prepared-statement -> void (define/public (free-statement pst) (call-with-lock* 'free-statement diff --git a/collects/db/private/sqlite3/connection.rkt b/collects/db/private/sqlite3/connection.rkt index d2a72db847..3fb1c65d80 100644 --- a/collects/db/private/sqlite3/connection.rkt +++ b/collects/db/private/sqlite3/connection.rkt @@ -165,6 +165,8 @@ (void)))) (call-with-lock* 'disconnect go go #f)) + (define/public (get-base) this) + (define/public (free-statement pst) (define (go) (let ([stmt (send pst get-handle)]) diff --git a/collects/tests/db/db/query.rkt b/collects/tests/db/db/query.rkt index 5b267f2912..0d7038380d 100644 --- a/collects/tests/db/db/query.rkt +++ b/collects/tests/db/db/query.rkt @@ -276,6 +276,30 @@ (check-equal? (query-value c (select-val "17")) (if (TESTFLAGS 'odbc 'issl) "17" 17)))))) +(define virtual-statement-tests + (let () + (define (check-prep-once mk-connection) + (let* ([counter 0] + [c (mk-connection)] + [vstmt (virtual-statement + (lambda (dbsys) + (set! counter (add1 counter)) + (select-val "17")))]) + (query-value c vstmt) + (check-equal? counter 1 "first query") + (query-value c vstmt) + (check-equal? counter 1 "second query") + (disconnect c))) + (test-suite "virtual-statements" + (test-case "prep once" + (check-prep-once connect-and-setup)) + (test-case "prep once for virtual-connection" + (check-prep-once + (lambda () (virtual-connection connect-and-setup)))) + (test-case "prep once for virtual-connection/pool" + (check-prep-once + (lambda () (virtual-connection (connection-pool connect-and-setup)))))))) + (define test (test-suite "query API" (simple-tests 'string) @@ -284,4 +308,5 @@ (simple-tests 'gen) low-level-tests misc-tests + virtual-statement-tests error-tests)) From 418985d4c402a589996f623259e2dbcb96b36b10 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 29 Aug 2011 03:45:35 -0600 Subject: [PATCH 015/235] db: fixed issues with statement finalization (don't use weak hash) In some cases, statements were disappearing from statement-table without being finalized; this makes disconnect fail. (I was only able to produce the problem when the db lib was instantiated in a sub custodian that is later shutdown.... like the way the rackunit gui runs the test suite.) --- collects/db/private/generic/interfaces.rkt | 1 - collects/db/private/odbc/connection.rkt | 15 +++++--- collects/db/private/sqlite3/connection.rkt | 45 ++++++++++++---------- collects/db/private/sqlite3/ffi.rkt | 8 ++++ 4 files changed, 42 insertions(+), 27 deletions(-) diff --git a/collects/db/private/generic/interfaces.rkt b/collects/db/private/generic/interfaces.rkt index 9ac8eaf7c9..c8ad693a70 100644 --- a/collects/db/private/generic/interfaces.rkt +++ b/collects/db/private/generic/interfaces.rkt @@ -90,7 +90,6 @@ ;; extension hooks: usually shouldn't need to override finalize ;; -> void - register-finalizer ;; -> void ;; inspection only get-param-types ;; -> (listof TypeDesc) diff --git a/collects/db/private/odbc/connection.rkt b/collects/db/private/odbc/connection.rkt index b96ef2f293..df9e2beb7f 100644 --- a/collects/db/private/odbc/connection.rkt +++ b/collects/db/private/odbc/connection.rkt @@ -3,6 +3,7 @@ racket/list racket/math ffi/unsafe + ffi/unsafe/atomic "../generic/interfaces.rkt" "../generic/prepared.rkt" "../generic/sql-data.rkt" @@ -24,7 +25,7 @@ char-mode) (init strict-parameter-types?) - (define statement-table (make-weak-hasheq)) + (define statement-table (make-hasheq)) (define lock (make-semaphore 1)) (define use-describe-param? @@ -437,13 +438,14 @@ (define/public (disconnect) (define (go) + (start-atomic) (let ([db* db] [env* env]) + (set! db #f) + (set! env #f) + (end-atomic) (when db* (let ([statements (hash-map statement-table (lambda (k v) k))]) - (set! db #f) - (set! env #f) - (set! statement-table #f) (for ([pst (in-list statements)]) (free-statement* 'disconnect pst)) (handle-status 'disconnect (SQLDisconnect db*) db*) @@ -459,11 +461,14 @@ (call-with-lock* 'free-statement go go #f)) (define/private (free-statement* fsym pst) + (start-atomic) (let ([stmt (send pst get-handle)]) + (send pst set-handle #f) + (end-atomic) (when stmt - (send pst set-handle #f) (handle-status 'free-statement (SQLFreeStmt stmt SQL_CLOSE) stmt) (handle-status 'free-statement (SQLFreeHandle SQL_HANDLE_STMT stmt) stmt) + (hash-remove! statement-table pst) (void)))) ;; Transactions diff --git a/collects/db/private/sqlite3/connection.rkt b/collects/db/private/sqlite3/connection.rkt index 3fb1c65d80..523d4336a5 100644 --- a/collects/db/private/sqlite3/connection.rkt +++ b/collects/db/private/sqlite3/connection.rkt @@ -1,6 +1,7 @@ #lang racket/base (require racket/class ffi/unsafe + ffi/unsafe/atomic "../generic/interfaces.rkt" "../generic/prepared.rkt" "../generic/sql-data.rkt" @@ -18,7 +19,7 @@ busy-retry-delay) (define -db db) - (define statement-table (make-weak-hasheq)) + (define statement-table (make-hasheq)) (define saved-tx-status #f) ;; set by with-lock, only valid while locked (inherit call-with-lock* @@ -149,33 +150,35 @@ pst))) (define/public (disconnect) - ;; FIXME: Reorder effects to be more robust if thread killed within disconnect (?) (define (go) - (when -db - (let ([db -db] - [statements (hash-map statement-table (lambda (k v) k))]) - (set! -db #f) - (set! statement-table #f) - (for ([pst (in-list statements)]) - (let ([stmt (send pst get-handle)]) - (when stmt - (send pst set-handle #f) - (HANDLE 'disconnect (sqlite3_finalize stmt))))) - (HANDLE 'disconnect (sqlite3_close db)) - (void)))) + (start-atomic) + (let ([db -db]) + (set! -db #f) + (end-atomic) + (when db + (let ([statements (hash-map statement-table (lambda (k v) k))]) + (for ([pst (in-list statements)]) + (do-free-statement 'disconnect pst)) + (HANDLE 'disconnect2 (sqlite3_close db)) + (void))))) (call-with-lock* 'disconnect go go #f)) (define/public (get-base) this) (define/public (free-statement pst) - (define (go) - (let ([stmt (send pst get-handle)]) - (when stmt - (send pst set-handle #f) - (HANDLE 'free-statement (sqlite3_finalize stmt)) - (void)))) + (define (go) (do-free-statement 'free-statement pst)) (call-with-lock* 'free-statement go go #f)) + (define/private (do-free-statement fsym pst) + (start-atomic) + (let ([stmt (send pst get-handle)]) + (send pst set-handle #f) + (end-atomic) + (hash-remove! statement-table pst) + (when stmt + (HANDLE fsym (sqlite3_finalize stmt)) + (void)))) + ;; == Transactions @@ -262,7 +265,7 @@ ;; Can't figure out how to test... (define/private (handle-status who s) (when (memv s maybe-rollback-status-list) - (when (and saved-tx-status (not (get-tx-status -db))) ;; was in trans, now not + (when (and saved-tx-status -db (not (get-tx-status -db))) ;; was in trans, now not (set! tx-status 'invalid))) (handle-status* who s -db)) diff --git a/collects/db/private/sqlite3/ffi.rkt b/collects/db/private/sqlite3/ffi.rkt index a0c4d5e3ab..94db428b6d 100644 --- a/collects/db/private/sqlite3/ffi.rkt +++ b/collects/db/private/sqlite3/ffi.rkt @@ -132,6 +132,14 @@ (_fun _sqlite3_database -> _bool)) +(define-sqlite sqlite3_next_stmt + (_fun _sqlite3_database _sqlite3_statement/null + -> _sqlite3_statement/null)) + +(define-sqlite sqlite3_sql + (_fun _sqlite3_statement + -> _string)) + ;; ---------------------------------------- #| From f339060e551ff58530b182552480bbcc6cc4d9db Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 29 Aug 2011 04:34:56 -0600 Subject: [PATCH 016/235] db: added note on performance, edited note on isolation --- collects/db/scribblings/introduction.scrbl | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/collects/db/scribblings/introduction.scrbl b/collects/db/scribblings/introduction.scrbl index 7240899c1b..3ccb5e044a 100644 --- a/collects/db/scribblings/introduction.scrbl +++ b/collects/db/scribblings/introduction.scrbl @@ -202,15 +202,18 @@ web-server ] The main problem with using one connection for all requests is that -while all connection functions are thread-safe, two threads accessing -a connection concurrently may still interfere. For example, if two -threads both attempt to start a new transaction, the second one will -fail, because the first thread has already put the connection into an -``in transaction'' state. And if one thread is accessing the -connection within a transaction and another thread issues a query, the -second thread may see invalid data or even disrupt the work of the -first thread (see -@hyperlink["http://en.wikipedia.org/wiki/Isolation_%28database_systems%29"]{isolation}). +multiple threads accessing the same connection are not properly +@hyperlink["http://en.wikipedia.org/wiki/Isolation_%28database_systems%29"]{isolated}. For +example, if two threads both attempt to start a new transaction, the +second one will fail, because the first thread has already put the +connection into an ``in transaction'' state. And if one thread is +accessing the connection within a transaction and another thread +issues a query, the second thread may see invalid data or even disrupt +the work of the first thread. + +A secondary problem is performance. A connection can only perform a +single query at a time, whereas most database systems are capable of +concurrent query processing. The proper way to use database connections in a servlet is to create a connection for each request and disconnect it when the request From 281df3221e1ddfc59cef3378f032a09fd6af0c42 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 29 Aug 2011 14:35:02 -0600 Subject: [PATCH 017/235] db: tried async execution with odbc... didn't work Added note in TODO, my guess why not. Fixed odbc ffi bindings, added a few more status checks. --- collects/db/TODO | 5 +++++ collects/db/private/odbc/ffi.rkt | 24 ++++++++++++++++-------- 2 files changed, 21 insertions(+), 8 deletions(-) diff --git a/collects/db/TODO b/collects/db/TODO index b9af8c7f36..80205d44af 100644 --- a/collects/db/TODO +++ b/collects/db/TODO @@ -68,6 +68,11 @@ Misc - how about implicit support only in 'in-query'? - ODBC: use async execution to avoid blocking all Racket threads + Status: Tried it. Oracle driver doesn't support async. PG, MY drivers don't support async. + DB2 driver does, but gives baffling HY010 function sequence errors, couldn't fix. + (Best theory so far: possible that DB2 requires polling args to be identical to original + call, which means (_ptr o X) args are the problem. Or maybe unixodbc's fault.) + Didn't try SQL Server. All in all, not worth it. - add evt versions of functions - for query functions (?) diff --git a/collects/db/private/odbc/ffi.rkt b/collects/db/private/odbc/ffi.rkt index 4c9e520692..404cd0db38 100644 --- a/collects/db/private/odbc/ffi.rkt +++ b/collects/db/private/odbc/ffi.rkt @@ -123,6 +123,10 @@ Docs at http://msdn.microsoft.com/en-us/library/ms712628%28v=VS.85%29.aspx (define-ffi-definer define-odbc odbc-lib) +(define (ok-status? n) + (or (= n SQL_SUCCESS) + (= n SQL_SUCCESS_WITH_INFO))) + (define-odbc SQLAllocHandle (_fun (type : _sqlsmallint) (parent : _sqlhandle/null) @@ -168,7 +172,8 @@ Docs at http://msdn.microsoft.com/en-us/library/ms712628%28v=VS.85%29.aspx (len : (_ptr o _sqlsmallint)) -> (status : _sqlreturn) -> (values status - (bytes->string/utf-8 value #f 0 len))))) + (and (ok-status? status) + (bytes->string/utf-8 value #f 0 len)))))) (define-odbc SQLGetFunctions (_fun (handle : _sqlhdbc) @@ -211,7 +216,7 @@ Docs at http://msdn.microsoft.com/en-us/library/ms712628%28v=VS.85%29.aspx (out-len : (_ptr o _sqlsmallint)) -> (status : _sqlreturn) -> (values status - (and (or (= status SQL_SUCCESS) (= status SQL_SUCCESS_WITH_INFO)) + (and (ok-status? status) (bytes->string/utf-8 out-buf #f 0 out-len))))) (define-odbc SQLDataSources @@ -226,9 +231,9 @@ Docs at http://msdn.microsoft.com/en-us/library/ms712628%28v=VS.85%29.aspx (descr-length : (_ptr o _sqlsmallint)) -> (status : _sqlreturn) -> (values status - (and (or (= status SQL_SUCCESS) (= status SQL_SUCCESS_WITH_INFO)) + (and (ok-status? status) (bytes->string/utf-8 server-buf #f 0 server-length)) - (and (or (= status SQL_SUCCESS) (= status SQL_SUCCESS_WITH_INFO)) + (and (ok-status? status) (bytes->string/utf-8 descr-buf #f 0 descr-length))))) (define-odbc SQLDrivers @@ -242,7 +247,7 @@ Docs at http://msdn.microsoft.com/en-us/library/ms712628%28v=VS.85%29.aspx ((if attrs-buf (bytes-length attrs-buf) 0) : _sqlsmallint) (attrs-length : (_ptr o _sqlsmallint)) -> (status : _sqlreturn) - -> (if (or (= status SQL_SUCCESS) (= status SQL_SUCCESS_WITH_INFO)) + -> (if (ok-status? status) (values status (bytes->string/utf-8 driver-buf #f 0 driver-length) attrs-length) @@ -308,7 +313,8 @@ Docs at http://msdn.microsoft.com/en-us/library/ms712628%28v=VS.85%29.aspx (nullable : (_ptr o _sqlsmallint)) -> (status : _sqlreturn) -> (values status - (bytes->string/utf-8 column-buf #f 0 column-len) + (and (ok-status? status) + (bytes->string/utf-8 column-buf #f 0 column-len)) data-type size digits nullable))) (define-odbc SQLFetch @@ -356,9 +362,11 @@ Docs at http://msdn.microsoft.com/en-us/library/ms712628%28v=VS.85%29.aspx (message-len : (_ptr o _sqlsmallint)) -> (status : _sqlreturn) -> (values status - (bytes->string/utf-8 sql-state-buf #\? 0 5) + (and (ok-status? status) + (bytes->string/utf-8 sql-state-buf #\? 0 5)) native-errcode - (bytes->string/utf-8 message-buf #\? 0 message-len)))) + (and (ok-status? status) + (bytes->string/utf-8 message-buf #\? 0 message-len))))) (define-odbc SQLEndTran (_fun (handle completion-type) :: From 883e9e9e6b77863eaa2a45131a7cd20b67f05870 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 29 Aug 2011 16:59:32 -0600 Subject: [PATCH 018/235] syntax/parse: syntax-parse sets current-syntax-context --- collects/syntax/parse/private/parse.rkt | 8 +++++--- collects/syntax/parse/private/sc.rkt | 16 +++++++++------- collects/syntax/scribblings/parse/parsing.scrbl | 7 +++++-- 3 files changed, 19 insertions(+), 12 deletions(-) diff --git a/collects/syntax/parse/private/parse.rkt b/collects/syntax/parse/private/parse.rkt index 10eef457e2..0634de5a07 100644 --- a/collects/syntax/parse/private/parse.rkt +++ b/collects/syntax/parse/private/parse.rkt @@ -8,6 +8,7 @@ "rep.rkt" "kws.rkt" "txlift.rkt") + racket/syntax racket/stxparam syntax/stx unstable/struct @@ -242,9 +243,10 @@ Conventions: [es null] [cx x] [fh0 (syntax-patterns-fail ctx0)]) - (with ([fail-handler fh0] - [cut-prompt fh0]) - (try alternative ...)))))))])) + (parameterize ((current-syntax-context ctx0)) + (with ([fail-handler fh0] + [cut-prompt fh0]) + (try alternative ...))))))))])) ;; ---- diff --git a/collects/syntax/parse/private/sc.rkt b/collects/syntax/parse/private/sc.rkt index 00bd0332e3..e60d83d712 100644 --- a/collects/syntax/parse/private/sc.rkt +++ b/collects/syntax/parse/private/sc.rkt @@ -4,6 +4,7 @@ racket/syntax "rep-data.rkt" "rep.rkt") + racket/syntax "parse.rkt" "keywords.rkt" "runtime.rkt" @@ -163,14 +164,15 @@ [(def ...) defs] [expr expr]) #'(defattrs/unpack (a ...) - (let* ([x expr] + (let* ([x (datum->syntax #f expr)] [cx x] [pr (ps-empty x x)] [es null] [fh0 (syntax-patterns-fail x)]) - def ... - (#%expression - (with ([fail-handler fh0] - [cut-prompt fh0]) - (parse:S x cx pattern pr es - (list (attribute name) ...)))))))))])) + (parameterize ((current-syntax-context x)) + def ... + (#%expression + (with ([fail-handler fh0] + [cut-prompt fh0]) + (parse:S x cx pattern pr es + (list (attribute name) ...))))))))))])) diff --git a/collects/syntax/scribblings/parse/parsing.scrbl b/collects/syntax/scribblings/parse/parsing.scrbl index 5972197acb..6ba87ee86e 100644 --- a/collects/syntax/scribblings/parse/parsing.scrbl +++ b/collects/syntax/scribblings/parse/parsing.scrbl @@ -3,7 +3,8 @@ scribble/struct scribble/decode scribble/eval - "parse-common.rkt") + "parse-common.rkt" + (for-label racket/syntax)) @title{Parsing Syntax} @@ -58,7 +59,9 @@ The following options are supported: #:contracts ([context-expr syntax?])]{ When present, @racket[context-expr] is used in reporting parse -failures; otherwise @racket[stx-expr] is used. +failures; otherwise @racket[stx-expr] is used. The +@racket[current-syntax-context] parameter is also set to the value of +@racket[context-expr]. @(myexamples (syntax-parse #'(a b 3) From b706fc1ebc04681d8534480798a7e68c7d9ee824 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 29 Aug 2011 20:28:21 -0600 Subject: [PATCH 019/235] db: cleaned up testing script, run sqlite tests by default --- collects/tests/db/all-tests.rkt | 70 ++++++++++++++++++++++----------- 1 file changed, 46 insertions(+), 24 deletions(-) diff --git a/collects/tests/db/all-tests.rkt b/collects/tests/db/all-tests.rkt index e5d874721d..c247cea7b0 100644 --- a/collects/tests/db/all-tests.rkt +++ b/collects/tests/db/all-tests.rkt @@ -22,6 +22,18 @@ RUNNING THE TESTS ----------------- +1) Default test configuration. + +To run the default tests (ie, the generic tests and sqlite3 tests), +simply execute this file with no arguments: + + racket -l tests/db/all-tests + +This is how DrDr runs the file---we assume the machine running DrDr +has sqlite installed. + +2) Custom test configuration. + First, set up the testing environment as described in the following subsections. @@ -115,6 +127,11 @@ Testing profiles are flattened, not hierarchical. (dbconf->unit (dbconf dbtestname (data-source 'odbc dbargs `((db:test ,dbflags)))))) +(define sqlite-unit + (dbconf->unit + (dbconf "sqlite3, memory" + (data-source 'sqlite3 '(#:database memory) '((db:test (issl))))))) + ;; ---- (define-unit db-test@ @@ -156,7 +173,10 @@ Testing profiles are flattened, not hierarchical. (define (odbc-test dsn [flags null]) (specialize-test (odbc-unit dsn flags `(#:dsn ,dsn)))) -(define generic-tests +(define sqlite-test + (specialize-test sqlite-unit)) + +(define generic-test (make-test-suite "Generic tests (no db)" (list gen-sql-types:test gen-query:test))) @@ -179,6 +199,7 @@ Testing profiles are flattened, not hierarchical. (define gui? #f) (define include-generic? #f) +(define include-sqlite? #f) ;; If no labels given, run generic tests. If labels given, run generic ;; tests only if -g option given. @@ -187,28 +208,29 @@ Testing profiles are flattened, not hierarchical. #:once-each [("--gui") "Run tests in RackUnit GUI" (set! gui? #t)] [("-g" "--generic") "Run generic tests" (set! include-generic? #t)] + [("-s" "--sqlite3") "Run sqlite3 in-memory db tests" (set! include-sqlite? #t)] [("-f" "--config-file") file "Use configuration file" (pref-file file)] #:args labels - (cond [gui? - (let* ([dbtests - (for/list ([label labels]) - (make-all-tests label (get-dbconf (string->symbol label))))] - [tests - (cond [(or include-generic? (null? dbtests)) - (cons generic-tests dbtests)] - [else dbtests])] - [test/gui (dynamic-require 'rackunit/gui 'test/gui)]) - (apply test/gui tests) - (eprintf "Press Cntl-C to end.\n") ;; HACK! - (with-handlers ([exn:break? (lambda _ (newline) (exit))]) - (sync never-evt)))] - [else - (when (or include-generic? (null? labels)) - (printf "Running generic tests\n") - (run-tests generic-tests) - (newline)) - (for ([label labels]) - (printf "Running ~s tests\n" label) - (run-tests - (make-all-tests label (get-dbconf (string->symbol label)))) - (newline))])) + (let* ([tests + (for/list ([label labels]) + (cons label + (make-all-tests label (get-dbconf (string->symbol label)))))] + [tests + (cond [(or include-sqlite? (null? labels)) + (cons (cons "sqlite3, memory" sqlite-test) tests)] + [else tests])] + [tests + (cond [(or include-generic? (null? labels)) + (cons (cons "generic" generic-test) tests)] + [else tests])]) + (cond [gui? + (let* ([test/gui (dynamic-require 'rackunit/gui 'test/gui)]) + (apply test/gui (map cdr tests)) + (eprintf "Press Cntl-C to end.\n") ;; HACK! + (with-handlers ([exn:break? (lambda _ (newline) (exit))]) + (sync never-evt)))] + [else + (for ([test tests]) + (printf "Running ~s tests\n" (car test)) + (run-tests (cdr test)) + (newline))]))) From 0fbed43a262905705b094553315061fde36de42b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 30 Aug 2011 14:31:46 -0500 Subject: [PATCH 020/235] Fix 'place's handling of the result of resolved-module-path-name Plus minor cleanups: - fixed indentation - removed useless gen-create-place function - avoid using the guard position of syntax-case - drop useless datum->syntax call (it returns syntax objects unmodified and generate-temporary returns a syntax object) - "interal" => "internal" - minimized the generated code (move into a function call) - check to make sure constructed lambda expression is well-formed - check to make sure 'place' is used inside a module (or else several other things it use will fail) --- collects/racket/place.rkt | 38 +++++++++++++++++++++++--------------- 1 file changed, 23 insertions(+), 15 deletions(-) diff --git a/collects/racket/place.rkt b/collects/racket/place.rkt index bc4b752088..d1e9261c0d 100644 --- a/collects/racket/place.rkt +++ b/collects/racket/place.rkt @@ -143,19 +143,27 @@ (syntax-case stx () [(_ a ...) b ...]))) -(define-for-syntax (gen-create-place stx) - (syntax-case stx () - [(_ ch body ...) - (unless (identifier? #'ch) - (raise-syntax-error #f "expected an indentifier" stx #'ch)) - (with-syntax ([interal-def-name - (syntax-local-lift-expression #'(lambda (ch) body ...))] - [funcname (datum->syntax stx (generate-temporary #'place/anon))]) - (syntax-local-lift-provide #'(rename interal-def-name funcname)) - #'(let ([module-path (resolved-module-path-name - (variable-reference->resolved-module-path - (#%variable-reference)))]) - (dynamic-place module-path (quote funcname))))])) - (define-syntax (place stx) - (gen-create-place stx)) + (syntax-case stx () + [(_ ch body1 body ...) + (begin + (unless (eq? 'module (syntax-local-context)) + (raise-syntax-error #f "can only be used in a module" stx)) + (unless (identifier? #'ch) + (raise-syntax-error #f "expected an indentifier" stx #'ch)) + (with-syntax ([internal-def-name + (syntax-local-lift-expression #'(lambda (ch) body1 body ...))] + [func-name (generate-temporary #'place/anon)]) + (syntax-local-lift-provide #'(rename internal-def-name func-name)) + #'(place/proc (#%variable-reference) 'func-name)))] + [(_ ch) + (raise-syntax-error #f "expected at least one body expression" stx)])) + +(define (place/proc vr func-name) + (define name + (resolved-module-path-name + (variable-reference->resolved-module-path + vr))) + (dynamic-place (if (symbol? name) `',name name) + func-name)) + From 959db06c7cf92c2e3c135680bd8aa56278b41bfc Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 30 Aug 2011 09:18:52 -0600 Subject: [PATCH 021/235] change "cache.rktd" format to be platform-independent The format previously included relative paths in the syntax of the platform used to run `raco setup'. While a "cache.rktd" built on Unix would work for Windows, the reverse would not be true. Also, `raco setup' under Windows would get confused because it would arrive at different relative paths for the same collection (e.g., "drracket/private" and "drracket\\private"). The portable representation of relative paths is also normalized. A "cache.rktd" file still has absolute paths for Planet packages or links installed with `raco link', but that's not a problem for packaging a distribution with a portable "cache.rktd". Also, `raco setup' cleans "cache.rtkd" by removing collections that are omitted and by not including collections that have no "info.rkt"/"info.ss" file. --- collects/setup/getinfo.rkt | 26 +++++++++--- collects/setup/setup-unit.rkt | 77 ++++++++++++++++++++++++++++------- 2 files changed, 82 insertions(+), 21 deletions(-) diff --git a/collects/setup/getinfo.rkt b/collects/setup/getinfo.rkt index 748a625ee0..7ae7b1c1ca 100644 --- a/collects/setup/getinfo.rkt +++ b/collects/setup/getinfo.rkt @@ -1,6 +1,10 @@ #lang scheme/base -(require scheme/match scheme/contract planet/cachepath syntax/modread) +(require scheme/match + scheme/contract + planet/cachepath + syntax/modread + "path-relativize.rkt") ;; in addition to infodomain/compiled/cache.rktd, getinfo will look in this ;; file to find mappings. PLaneT uses this to put info about installed @@ -118,6 +122,12 @@ (for ([f+root-dir (reverse (table-paths t))]) (let ([f (car f+root-dir)] [root-dir (cdr f+root-dir)]) + (define-values (path->info-relative + info-relative->path) + (make-relativize (lambda () root-dir) + 'info + 'path->info-relative + 'info-relative->path)) (when (file-exists? f) (for ([i (let ([l (with-input-from-file f read)]) (cond [(list? l) l] @@ -125,7 +135,7 @@ [else (error 'find-relevant-directories "bad info-domain cache file: ~a" f)]))]) (match i - [(list (? bytes? pathbytes) + [(list (and pathbytes (or (? bytes?) (list 'info (? bytes?) ...))) (list (? symbol? fields) ...) key ;; anything is okay here (? integer? maj) @@ -134,10 +144,14 @@ [new-item (make-directory-record maj min key - (let ([p (bytes->path pathbytes)]) - (if (and (relative-path? p) root-dir) - (build-path root-dir p) - p)) + (if (bytes? pathbytes) + (let ([p (bytes->path pathbytes)]) + (if (and (relative-path? p) root-dir) + ;; `raco setup' doesn't generate relative paths anyway, + ;; but it's ok to support them: + (build-path root-dir p) + p)) + (info-relative->path pathbytes)) fields)]) (hash-set! colls key ((table-insert t) new-item old-items)))] diff --git a/collects/setup/setup-unit.rkt b/collects/setup/setup-unit.rkt index 39003f9f4f..a67ffe4d19 100644 --- a/collects/setup/setup-unit.rkt +++ b/collects/setup/setup-unit.rkt @@ -26,6 +26,7 @@ "dirs.rkt" "main-collects.rkt" "path-to-relative.rkt" + "path-relativize.rkt" "private/omitted-paths.rkt" "parallel-build.rkt" "collects.rkt" @@ -792,8 +793,23 @@ ;; about those collections that exist in the same root as the ones in ;; `collections-to-compile'. (let ([ht (make-hash)] - [ht-orig (make-hash)]) + [ht-orig (make-hash)] + [roots (make-hash)]) (for ([cc ccs-to-compile]) + (define-values (path->info-relative info-relative->path) + (apply values + (hash-ref roots + (cc-info-root cc) + (lambda () + (define-values (p-> ->p) + (if (cc-info-root cc) + (make-relativize (lambda () (cc-info-root cc)) + 'info + 'path->info-relative + 'info-relative->path) + (values #f #f))) + (hash-set! roots (cc-info-root cc) (list p-> ->p)) + (list p-> ->p))))) (let* ([domain (with-handlers ([exn:fail? (lambda (x) (lambda () null))]) (dynamic-require (build-path (cc-path cc) "info.rkt") @@ -817,13 +833,16 @@ (set! all-ok? #t) (for ([i l]) (match i - [(list (? bytes? a) (list (? symbol? b) ...) c (? integer? d) (? integer? e)) - (let ([p (bytes->path a)]) + [(list (and a (or (? bytes?) (list 'info (? bytes?) ...))) + (list (? symbol? b) ...) c (? integer? d) (? integer? e)) + (let ([p (if (bytes? a) + (bytes->path a) + a)]) ;; Check that the path is suitably absolute or relative: (let ([dir (case (cc-info-path-mode cc) [(relative abs-in-relative) - (or (and (relative-path? p) - (build-path (cc-info-root cc) p)) + (or (and (list? p) + (info-relative->path p)) (and (complete-path? p) ;; `c' must be `(lib ...)' (list? c) @@ -839,11 +858,25 @@ (and (complete-path? p) p)])]) (if (and dir + (let ([omit-root + (if (path? p) + ;; absolute path => need a root for checking omits; + ;; for a collection path of length N, go up N-1 dirs: + (simplify-path (apply build-path p (for/list ([i (cddr c)]) 'up)) #f) + ;; relative path => no root needed for checking omits: + #f)]) + (not (eq? 'all (omitted-paths dir getinfo omit-root)))) (or (file-exists? (build-path dir "info.rkt")) (file-exists? (build-path dir "info.ss")))) (hash-set! t a (list b c d e)) - (set! all-ok? #f))))] - [_ (set! all-ok? #f)]))) + (begin + (when (verbose) + (printf " drop entry: ~s\n" i)) + (set! all-ok? #f)))))] + [_ + (when (verbose) + (printf " bad entry: ~s\n" i)) + (set! all-ok? #f)]))) ;; Record the table loaded for this collection root ;; in the all-roots table: (hash-set! ht (cc-info-path cc) t) @@ -854,14 +887,18 @@ (and all-ok? (hash-copy t))) t))))]) ;; Add this collection's info to the table, replacing any information - ;; already there. - (hash-set! t - (path->bytes (if (eq? (cc-info-path-mode cc) 'relative) - ;; Use relative path: - (apply build-path (cc-collection cc)) - ;; Use absolute path: - (cc-path cc))) - (cons (domain) (cc-shadowing-policy cc))))) + ;; already there, if the collection has an "info.ss" file: + (when (or (file-exists? (build-path (cc-path cc) "info.rkt")) + (file-exists? (build-path (cc-path cc) "info.ss"))) + (hash-set! t + (if (eq? (cc-info-path-mode cc) 'relative) + ;; Use relative path: + (path->info-relative (apply build-path + (cc-info-root cc) + (cc-collection cc))) + ;; Use absolute path: + (path->bytes (cc-path cc))) + (cons (domain) (cc-shadowing-policy cc)))))) ;; Write out each collection-root-specific table to a "cache.rktd" file: (hash-for-each ht (lambda (info-path ht) @@ -870,6 +907,16 @@ (make-directory* base) (let ([p info-path]) (setup-printf "updating" "~a" (path->relative-string/setup p)) + (when (verbose) + (let ([ht0 (hash-ref ht-orig info-path)]) + (when ht0 + (for ([(k v) (in-hash ht)]) + (let ([v2 (hash-ref ht0 k #f)]) + (unless (equal? v v2) + (printf " ~s -> ~s\n instead of ~s\n" k v v2)))) + (for ([(k v) (in-hash ht0)]) + (unless (hash-ref ht k #f) + (printf " ~s removed\n" k)))))) (with-handlers ([exn:fail? (warning-handler (void))]) (with-output-to-file p #:exists 'truncate/replace From 35a8359c6dc85867dd7f143ee49646fc5e2760f0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 30 Aug 2011 13:18:05 -0600 Subject: [PATCH 022/235] remove some path case normalization The change allows `raco setup' to reach a fixed point under Windows for "redex/examples/cont-mark-transform". I'm more and more convinced that `normal-case-path' is never a good idea. In some cases, maybe it's good to recognize a few extra equivalences, but it works badly when paths are taken from many sources and are not consistently normalized. It's better to just preserve case. For basic normalization, `simplify-path' is the right choice. Use inode identity (as `raco setup' does) when anything stronger than `simplify-path' is needed. --- collects/setup/path-relativize.rkt | 3 +-- collects/setup/setup-unit.rkt | 2 +- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/collects/setup/path-relativize.rkt b/collects/setup/path-relativize.rkt index 90ed58c550..22402be0d4 100644 --- a/collects/setup/path-relativize.rkt +++ b/collects/setup/path-relativize.rkt @@ -20,8 +20,7 @@ ;; tree, so we explode the paths. This is slower than the old way ;; (by a factor of 2 or so), but it's simpler and more portable. (define (explode-path path) - (let loop ([path (simplify-path - (normal-case-path (path->complete-path path)))] + (let loop ([path (simplify-path (path->complete-path path))] [rest null]) (let-values ([(base name dir?) (split-path path)]) (if (path? base) diff --git a/collects/setup/setup-unit.rkt b/collects/setup/setup-unit.rkt index a67ffe4d19..4a5cefbb42 100644 --- a/collects/setup/setup-unit.rkt +++ b/collects/setup/setup-unit.rkt @@ -656,7 +656,7 @@ [dir-table (make-hash)] [doing-path (lambda (path) (unless (verbose) - (let ([path (normal-case-path (path-only path))]) + (let ([path (path-only path)]) (unless (hash-ref dir-table path #f) (hash-set! dir-table path #t) (print-verbose oop path)))))]) From c0625dc30c007c5dfa11c4cb01bc2e8c3b81466f Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Tue, 30 Aug 2011 12:43:07 -0500 Subject: [PATCH 023/235] Adds define-term form --- collects/redex/private/defined-checks.rkt | 2 +- .../redex/private/reduction-semantics.rkt | 4 --- collects/redex/private/term-fn.rkt | 26 ++++++++++++---- collects/redex/private/term.rkt | 22 ++++++++++++- collects/redex/redex.scrbl | 7 +++-- collects/redex/reduction-semantics.rkt | 1 + collects/redex/tests/check-syntax-test.rkt | 21 +++++++++++++ .../judgment-form-undefined.rktd | 2 +- collects/redex/tests/run-err-tests/term.rktd | 9 +++++- collects/redex/tests/tl-test.rkt | 31 +++++++++++++++++-- 10 files changed, 107 insertions(+), 18 deletions(-) diff --git a/collects/redex/private/defined-checks.rkt b/collects/redex/private/defined-checks.rkt index 261866f2ab..8861097b8c 100644 --- a/collects/redex/private/defined-checks.rkt +++ b/collects/redex/private/defined-checks.rkt @@ -14,4 +14,4 @@ (thunk))) (define (report-undefined name desc) - (redex-error #f "~a ~s applied before its definition" desc name)) \ No newline at end of file + (redex-error #f "reference to ~a ~s before its definition" desc name)) \ No newline at end of file diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt index c2f3bfc6a6..d82651e81e 100644 --- a/collects/redex/private/reduction-semantics.rkt +++ b/collects/redex/private/reduction-semantics.rkt @@ -1331,10 +1331,6 @@ (map (λ (x) (to-lw/proc (datum->syntax #f (cdr (syntax-e x)) x))) (syntax->list #'(lhs-for-lw ...))))) -(define-for-syntax (not-expression-context stx) - (when (eq? (syntax-local-context) 'expression) - (raise-syntax-error #f "not allowed in an expression context" stx))) - ; ; ; diff --git a/collects/redex/private/term-fn.rkt b/collects/redex/private/term-fn.rkt index 1440fe2efb..3deb9c1b04 100644 --- a/collects/redex/private/term-fn.rkt +++ b/collects/redex/private/term-fn.rkt @@ -7,7 +7,10 @@ (struct-out term-id) (struct-out judgment-form) judgment-form-id? - defined-check) + (struct-out defined-term) + defined-term-id? + defined-check + not-expression-context) (define-values (struct-type make-term-fn term-fn? term-fn-get term-fn-set!) (make-struct-type 'term-fn #f 1 0)) @@ -15,13 +18,24 @@ (define-struct term-id (id depth)) -(define-struct judgment-form (name mode proc lang lws)) - -(define (judgment-form-id? stx) +(define ((transformer-predicate p?) stx) (and (identifier? stx) - (judgment-form? (syntax-local-value stx (λ () 'not-a-judgment-form))))) + (cond [(syntax-local-value stx (λ () #f)) => p?] + [else #f]))) + +(define-struct judgment-form (name mode proc lang lws)) +(define judgment-form-id? + (transformer-predicate judgment-form?)) + +(define-struct defined-term (value)) +(define defined-term-id? + (transformer-predicate defined-term?)) (define (defined-check id desc #:external [external id]) (if (eq? (identifier-binding id) 'lexical) (quasisyntax/loc external (check-defined-lexical #,id '#,external #,desc)) - (quasisyntax/loc external (check-defined-module (λ () #,id) '#,external #,desc)))) \ No newline at end of file + (quasisyntax/loc external (check-defined-module (λ () #,id) '#,external #,desc)))) + +(define (not-expression-context stx) + (when (eq? (syntax-local-context) 'expression) + (raise-syntax-error #f "not allowed in an expression context" stx))) \ No newline at end of file diff --git a/collects/redex/private/term.rkt b/collects/redex/private/term.rkt index a64a39d00c..b6e6f0602c 100644 --- a/collects/redex/private/term.rkt +++ b/collects/redex/private/term.rkt @@ -3,11 +3,14 @@ (require (for-syntax scheme/base "term-fn.rkt" syntax/boundmap + syntax/parse racket/syntax) "error.rkt" "matcher.rkt") -(provide term term-let term-let/error-name term-let-fn term-define-fn hole in-hole) +(provide term term-let define-term + hole in-hole + term-let/error-name term-let-fn term-define-fn) (define-syntax (hole stx) (raise-syntax-error 'hole "used outside of term")) (define-syntax (in-hole stx) (raise-syntax-error 'in-hole "used outside of term")) @@ -69,6 +72,15 @@ (let ([id (syntax-local-value/record (syntax x) (λ (x) #t))]) (values (datum->syntax (term-id-id id) (syntax-e (term-id-id id)) (syntax x)) (term-id-depth id)))] + [x + (defined-term-id? #'x) + (let ([ref (syntax-property + (defined-term-value (syntax-local-value #'x)) + 'disappeared-use #'x)]) + (with-syntax ([v #`(begin + #,(defined-check ref "term" #:external #'x) + #,ref)]) + (values #'#,v 0)))] [(unquote x) (values (syntax (unsyntax x)) 0)] [(unquote . x) @@ -208,3 +220,11 @@ (term-let/error-name term-let ((x rhs) ...) body1 body2 ...))] [(_ x) (raise-syntax-error 'term-let "expected at least one body" stx)])) + +(define-syntax (define-term stx) + (syntax-parse stx + [(_ x:id t:expr) + (not-expression-context stx) + #'(begin + (define term-val (term t)) + (define-syntax x (defined-term #'term-val)))])) \ No newline at end of file diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index 2ff16ed1c8..25e9f61360 100644 --- a/collects/redex/redex.scrbl +++ b/collects/redex/redex.scrbl @@ -421,8 +421,8 @@ stands for repetition unless otherwise indicated): @item{A term written @racket[_identifier] is equivalent to the corresponding symbol, unless the identifier is bound by -@racket[term-let] (or in a @|pattern| elsewhere) or is -@tt{hole} (as below). } +@racket[term-let], @racket[define-term], or a @|pattern| variable or +the identifier is @tt{hole} (as below).} @item{A term written @racket[(_term-sequence ...)] constructs a list of the terms constructed by the sequence elements.} @@ -532,6 +532,9 @@ In some contexts, it may be more efficient to use @racket[term-match/single] The @racket[let*] analog of @racket[redex-let]. } +@defform[(define-term identifier @#,tttterm)]{ +Defines @racket[identifier] for use in @|tterm| templates.} + @defform[(term-match language [@#,ttpattern expression] ...)]{ This produces a procedure that accepts term (or quoted) diff --git a/collects/redex/reduction-semantics.rkt b/collects/redex/reduction-semantics.rkt index c04fd42205..a95d0b7b74 100644 --- a/collects/redex/reduction-semantics.rkt +++ b/collects/redex/reduction-semantics.rkt @@ -40,6 +40,7 @@ term-match/single redex-let redex-let* + define-term match? match-bindings make-bind bind? bind-name bind-exp diff --git a/collects/redex/tests/check-syntax-test.rkt b/collects/redex/tests/check-syntax-test.rkt index 357fd0c3a3..b173b35173 100644 --- a/collects/redex/tests/check-syntax-test.rkt +++ b/collects/redex/tests/check-syntax-test.rkt @@ -153,4 +153,25 @@ (test (send annotations collected-rename-class contract-name) (expected-rename-class metafunction-binding))) +;; define-term +(let ([annotations (new collector%)]) + (define-values (add-syntax done) + (make-traversal module-namespace #f)) + + (define def-name (identifier x)) + (define use-name (identifier x)) + + (parameterize ([current-annotations annotations] + [current-namespace module-namespace]) + (add-syntax + (expand #`(let () + (define-term #,def-name a) + (term (#,use-name b))))) + (done)) + + (test (send annotations collected-rename-class def-name) + (expected-rename-class (list def-name use-name))) + (test (send annotations collected-rename-class def-name) + (expected-rename-class (list def-name use-name)))) + (print-tests-passed 'check-syntax-test.rkt) \ No newline at end of file diff --git a/collects/redex/tests/run-err-tests/judgment-form-undefined.rktd b/collects/redex/tests/run-err-tests/judgment-form-undefined.rktd index 04c37d2b03..0a4f2e6e66 100644 --- a/collects/redex/tests/run-err-tests/judgment-form-undefined.rktd +++ b/collects/redex/tests/run-err-tests/judgment-form-undefined.rktd @@ -1,4 +1,4 @@ -("judgment form q applied before its definition" +("reference to judgment form q before its definition" ([use q]) ([def q]) (let () (judgment-holds (use 1)) diff --git a/collects/redex/tests/run-err-tests/term.rktd b/collects/redex/tests/run-err-tests/term.rktd index 0a6e36dd15..33d502408e 100644 --- a/collects/redex/tests/run-err-tests/term.rktd +++ b/collects/redex/tests/run-err-tests/term.rktd @@ -39,4 +39,11 @@ (#rx"term .* does not match pattern" ([rhs 'a]) ([ellipsis ...]) - (term-let ([(x ellipsis) rhs]) 3)) \ No newline at end of file + (term-let ([(x ellipsis) rhs]) 3)) + +("reference to term x before its definition" + ([use x]) ([def x]) + (let () + (define t (term (use y))) + (define-term def z) + t)) \ No newline at end of file diff --git a/collects/redex/tests/tl-test.rkt b/collects/redex/tests/tl-test.rkt index e2853ea061..5a76e7589f 100644 --- a/collects/redex/tests/tl-test.rkt +++ b/collects/redex/tests/tl-test.rkt @@ -989,14 +989,14 @@ (with-handlers ([exn:fail:redex? exn-message]) (eval '(require 'm)) #f)) - "metafunction q applied before its definition") + "reference to metafunction q before its definition") (test (with-handlers ([exn:fail:redex? exn-message]) (let () (term (q)) (define-language L) (define-metafunction L [(q) ()]) #f)) - "metafunction q applied before its definition") + "reference to metafunction q before its definition") (exec-syntax-error-tests "syn-err-tests/metafunction-definition.rktd") ; @@ -2131,6 +2131,33 @@ (eval '(require redex/reduction-semantics)) (exec-runtime-error-tests "run-err-tests/judgment-form-undefined.rktd")) + +; +; +; +; ; ;; ; +; ; ; ; ; +; ; ; ; +; ;;;; ;;; ;;; ; ;;;; ;;; ;;; ;;; ; ;; ;;;;; +; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ;; ; ; ; ; +; ; ; ;;;;; ; ; ; ; ;;;;; ; ;;;;; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ;;;; ;;; ; ; ; ; ;;; ;; ;;; ; ; ; ; +; +; +; + + (test (let () + (define-term x 1) + (term (x x))) + (term (1 1))) + (test (let () + (define-term x 1) + (let ([x 'whatever]) + (term (x x)))) + (term (x x))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; examples from doc.txt From c25c0b28680b2719addcf4631ce11c048c9e6067 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Tue, 30 Aug 2011 12:49:35 -0500 Subject: [PATCH 024/235] Deletes duplicate tests --- collects/redex/tests/tl-test.rkt | 4 ---- 1 file changed, 4 deletions(-) diff --git a/collects/redex/tests/tl-test.rkt b/collects/redex/tests/tl-test.rkt index 5a76e7589f..2b3bbf992a 100644 --- a/collects/redex/tests/tl-test.rkt +++ b/collects/redex/tests/tl-test.rkt @@ -2127,10 +2127,6 @@ (exec-runtime-error-tests "run-err-tests/judgment-form-undefined.rktd") (exec-runtime-error-tests "run-err-tests/judgment-form-ellipses.rktd")) - (parameterize ([current-namespace (make-base-namespace)]) - (eval '(require redex/reduction-semantics)) - (exec-runtime-error-tests "run-err-tests/judgment-form-undefined.rktd")) - ; ; From ecdd50da094872ede7c2a8e829806fa0e188cd5e Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Tue, 30 Aug 2011 13:07:13 -0500 Subject: [PATCH 025/235] Tests defined-checks directly --- collects/redex/tests/defined-checks-test.rkt | 24 +++++++++++++++++++ .../run-err-tests/metafunction-undefined.rktd | 8 +++++++ collects/redex/tests/run-tests.rkt | 1 + collects/redex/tests/tl-test.rkt | 4 ++++ 4 files changed, 37 insertions(+) create mode 100644 collects/redex/tests/defined-checks-test.rkt create mode 100644 collects/redex/tests/run-err-tests/metafunction-undefined.rktd diff --git a/collects/redex/tests/defined-checks-test.rkt b/collects/redex/tests/defined-checks-test.rkt new file mode 100644 index 0000000000..c2d4b84e0f --- /dev/null +++ b/collects/redex/tests/defined-checks-test.rkt @@ -0,0 +1,24 @@ +#lang racket + +(require "test-util.rkt" + "../private/error.rkt" + "../private/defined-checks.rkt") + +(reset-count) + +(define expected-message "reference to thing x before its definition") + +(test (with-handlers ([exn:fail:redex? exn-message]) + (check-defined-lexical x 'x "thing") + (define x 4) + "") + expected-message) + +(test (with-handlers ([exn:fail:redex? exn-message]) + (check-defined-module (λ () x) 'x "thing") + "") + expected-message) + +(define x 4) + +(print-tests-passed 'defined-checks-test.rkt) \ No newline at end of file diff --git a/collects/redex/tests/run-err-tests/metafunction-undefined.rktd b/collects/redex/tests/run-err-tests/metafunction-undefined.rktd new file mode 100644 index 0000000000..a01c78b7f6 --- /dev/null +++ b/collects/redex/tests/run-err-tests/metafunction-undefined.rktd @@ -0,0 +1,8 @@ +("reference to metafunction q before its definition" + ([use q]) ([def q]) + (let () + (term (use)) + (define-language L) + (define-metafunction L + [(def) ()]) + #f)) \ No newline at end of file diff --git a/collects/redex/tests/run-tests.rkt b/collects/redex/tests/run-tests.rkt index bca1653099..d70ccd71cf 100644 --- a/collects/redex/tests/run-tests.rkt +++ b/collects/redex/tests/run-tests.rkt @@ -26,6 +26,7 @@ "pict-test.rkt" "hole-test.rkt" "stepper-test.rkt" + "defined-checks-test.rkt" "check-syntax-test.rkt" "test-docs-complete.rkt") (if test-bitmaps? '("bitmap-test.rkt") '()) diff --git a/collects/redex/tests/tl-test.rkt b/collects/redex/tests/tl-test.rkt index 2b3bbf992a..9b31935a95 100644 --- a/collects/redex/tests/tl-test.rkt +++ b/collects/redex/tests/tl-test.rkt @@ -977,6 +977,10 @@ x) '(2 1))) + (parameterize ([current-namespace (make-base-namespace)]) + (eval '(require redex/reduction-semantics)) + (exec-runtime-error-tests "run-err-tests/judgment-form-undefined.rktd")) + ;; errors for not-yet-defined metafunctions (test (parameterize ([current-namespace (make-empty-namespace)]) (namespace-attach-module (namespace-anchor->namespace this-namespace) 'redex/reduction-semantics) From f3d22879a2cf4e4000cfd47b92b3243dbdceaf1a Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 30 Aug 2011 14:06:32 -0400 Subject: [PATCH 026/235] Make TR timing info fit on a line. --- collects/typed-scheme/utils/utils.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/utils/utils.rkt b/collects/typed-scheme/utils/utils.rkt index db37a19d7a..2cbccf325e 100644 --- a/collects/typed-scheme/utils/utils.rkt +++ b/collects/typed-scheme/utils/utils.rkt @@ -124,7 +124,7 @@ at least theoretically. (error 'start-timing "Timing already started")) (set!-last-time (current-process-milliseconds)) (set!-initial-time last-time) - (log-debug (format "TR Timing: ~a at ~a" (pad "Starting" 40 #\space) initial-time)))]) + (log-debug (format "TR Timing: ~a at ~a" (pad "Starting" 32 #\space) initial-time)))]) (syntax-rules () [(_ msg) (begin @@ -133,7 +133,7 @@ at least theoretically. (let* ([t (current-process-milliseconds)] [old last-time] [diff (- t old)] - [new-msg (pad msg 40 #\space)]) + [new-msg (pad msg 32 #\space)]) (set!-last-time t) (log-debug (format "TR Timing: ~a at ~a\tlast step: ~a\ttotal: ~a" new-msg t diff (- t initial-time)))))])) (values (lambda _ #'(void)) (lambda _ #'(void))))) From 70aaf6bf24e4cd80ad0e4be3baf841ed8e252cad Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 30 Aug 2011 14:18:49 -0400 Subject: [PATCH 027/235] Delay evaluation of numeric base env types. --- .../base-env/base-env-numeric.rkt | 1068 +++++++++-------- 1 file changed, 555 insertions(+), 513 deletions(-) diff --git a/collects/typed-scheme/base-env/base-env-numeric.rkt b/collects/typed-scheme/base-env/base-env-numeric.rkt index fc42e8caae..cb25ff614b 100644 --- a/collects/typed-scheme/base-env/base-env-numeric.rkt +++ b/collects/typed-scheme/base-env/base-env-numeric.rkt @@ -78,461 +78,503 @@ (define round-type ; also used for truncate - (from-cases - (map unop all-int-types) - (-> -NonNegRat -Nat) - (-> -NonPosRat -NonPosInt) - (-> -Rat -Int) - (map unop (list -FlonumPosZero -FlonumNegZero -FlonumZero - -NonNegFlonum -NonPosFlonum -Flonum - -SingleFlonumPosZero -SingleFlonumNegZero -SingleFlonumZero - -NonNegSingleFlonum -NonPosSingleFlonum -SingleFlonum - -InexactRealPosZero -InexactRealNegZero -InexactRealZero - -NonNegInexactReal -NonPosInexactReal -InexactReal - -RealZero -NonNegReal -NonPosReal -Real)))) + (lambda () + (from-cases + (map unop all-int-types) + (-> -NonNegRat -Nat) + (-> -NonPosRat -NonPosInt) + (-> -Rat -Int) + (map unop (list -FlonumPosZero -FlonumNegZero -FlonumZero + -NonNegFlonum -NonPosFlonum -Flonum + -SingleFlonumPosZero -SingleFlonumNegZero -SingleFlonumZero + -NonNegSingleFlonum -NonPosSingleFlonum -SingleFlonum + -InexactRealPosZero -InexactRealNegZero -InexactRealZero + -NonNegInexactReal -NonPosInexactReal -InexactReal + -RealZero -NonNegReal -NonPosReal -Real))))) - (define fl-unop (unop -Flonum)) + (define fl-unop (lambda () (unop -Flonum))) ;; types for specific operations, to avoid repetition between safe and unsafe versions (define fx+-type - (fx-from-cases - (binop -Zero) - (map (lambda (t) (commutative-binop t -Zero t)) - (list -One -PosByte -Byte -PosIndex -Index)) - (commutative-binop -PosByte -Byte -PosIndex) - (-Byte -Byte . -> . -PosIndex) - ;; in other cases, either we stay within fixnum range, or we error - (commutative-binop -Pos -Nat -PosFixnum) - (-Nat -Nat . -> . -NonNegFixnum) - (commutative-binop -NegInt -One -NonPosFixnum) - (commutative-binop -NegInt -NonPosInt -NegFixnum) - (-NonPosInt -NonPosInt . -> . -NonPosFixnum) - (-Int -Int . -> . -Fixnum))) + (lambda () + (fx-from-cases + (binop -Zero) + (map (lambda (t) (commutative-binop t -Zero t)) + (list -One -PosByte -Byte -PosIndex -Index)) + (commutative-binop -PosByte -Byte -PosIndex) + (-Byte -Byte . -> . -PosIndex) + ;; in other cases, either we stay within fixnum range, or we error + (commutative-binop -Pos -Nat -PosFixnum) + (-Nat -Nat . -> . -NonNegFixnum) + (commutative-binop -NegInt -One -NonPosFixnum) + (commutative-binop -NegInt -NonPosInt -NegFixnum) + (-NonPosInt -NonPosInt . -> . -NonPosFixnum) + (-Int -Int . -> . -Fixnum)))) (define fx--type - (fx-from-cases - (binop -Zero) - (map (lambda (t) (commutative-binop t -Zero t)) - (list -One -PosByte -Byte -PosIndex -Index)) - (-One -One . -> . -Zero) - (-PosByte -One . -> . -Byte) - (-PosIndex -One . -> . -Index) - (-PosFixnum -One . -> . -NonNegFixnum) - (-NegInt -Nat . -> . -NegFixnum) - (-NonPosInt -PosInt . -> . -NegFixnum) - (-NonPosInt -Nat . -> . -NonPosFixnum) - (-PosInt -NonPosInt . -> . -PosInt) - (-Nat -NegInt . -> . -PosInt) - (-Nat -NonPosInt . -> . -Nat) - (-Int -Int . -> . -Fixnum))) + (lambda () + (fx-from-cases + (binop -Zero) + (map (lambda (t) (commutative-binop t -Zero t)) + (list -One -PosByte -Byte -PosIndex -Index)) + (-One -One . -> . -Zero) + (-PosByte -One . -> . -Byte) + (-PosIndex -One . -> . -Index) + (-PosFixnum -One . -> . -NonNegFixnum) + (-NegInt -Nat . -> . -NegFixnum) + (-NonPosInt -PosInt . -> . -NegFixnum) + (-NonPosInt -Nat . -> . -NonPosFixnum) + (-PosInt -NonPosInt . -> . -PosInt) + (-Nat -NegInt . -> . -PosInt) + (-Nat -NonPosInt . -> . -Nat) + (-Int -Int . -> . -Fixnum)))) (define fx*-type - (fx-from-cases - (map binop (list -Zero -One)) - (commutative-binop -Zero -Int) - (-PosByte -PosByte . -> . -PosIndex) - (-Byte -Byte . -> . -Index) - (-PosInt -PosInt . -> . -PosFixnum) - (commutative-binop -PosInt -NegInt -NegFixnum) - (-NegInt -NegInt . -> . -PosFixnum) - (-Nat -Nat . -> . -NonNegFixnum) - (commutative-binop -Nat -NonPosInt -NonPosFixnum) - (-NonPosFixnum -NonPosFixnum . -> . -NonNegFixnum) - (-Int -Int . -> . -Fixnum))) + (lambda () + (fx-from-cases + (map binop (list -Zero -One)) + (commutative-binop -Zero -Int) + (-PosByte -PosByte . -> . -PosIndex) + (-Byte -Byte . -> . -Index) + (-PosInt -PosInt . -> . -PosFixnum) + (commutative-binop -PosInt -NegInt -NegFixnum) + (-NegInt -NegInt . -> . -PosFixnum) + (-Nat -Nat . -> . -NonNegFixnum) + (commutative-binop -Nat -NonPosInt -NonPosFixnum) + (-NonPosFixnum -NonPosFixnum . -> . -NonNegFixnum) + (-Int -Int . -> . -Fixnum)))) (define fxquotient-type - (fx-from-cases - (-Zero -Int . -> . -Zero) - (map (lambda (t) (-> t -One t)) ; division by one is identity - (list -PosByte -Byte -PosIndex -Index - -PosFixnum -NonNegFixnum -NegFixnum -NonPosFixnum -Fixnum)) - (-Byte -Nat . -> . -Byte) - (-Index -Nat . -> . -Index) - (-Nat -Nat . -> . -NonNegFixnum) - (commutative-binop -Nat -NonPosInt -NonPosFixnum) - (-NonPosInt -NonPosInt . -> . -NonNegFixnum) - (-Int -Int . -> . -Fixnum))) + (lambda () + (fx-from-cases + (-Zero -Int . -> . -Zero) + (map (lambda (t) (-> t -One t)) ; division by one is identity + (list -PosByte -Byte -PosIndex -Index + -PosFixnum -NonNegFixnum -NegFixnum -NonPosFixnum -Fixnum)) + (-Byte -Nat . -> . -Byte) + (-Index -Nat . -> . -Index) + (-Nat -Nat . -> . -NonNegFixnum) + (commutative-binop -Nat -NonPosInt -NonPosFixnum) + (-NonPosInt -NonPosInt . -> . -NonNegFixnum) + (-Int -Int . -> . -Fixnum)))) (define fxremainder-type ; result has same sign as first arg - (fx-from-cases - (-One -One . -> . -Zero) - (map (lambda (t) (list (-> -Nat t t) - (-> t -Int t))) - (list -Byte -Index)) - (-Nat -Int . -> . -NonNegFixnum) - (-NonPosInt -Int . -> . -NonPosFixnum) - (-Int -Int . -> . -Fixnum))) + (lambda () + (fx-from-cases + (-One -One . -> . -Zero) + (map (lambda (t) (list (-> -Nat t t) + (-> t -Int t))) + (list -Byte -Index)) + (-Nat -Int . -> . -NonNegFixnum) + (-NonPosInt -Int . -> . -NonPosFixnum) + (-Int -Int . -> . -Fixnum)))) (define fxmodulo-type ; result has same sign as second arg - (fx-from-cases - (-One -One . -> . -Zero) - (map (lambda (t) (list (-> -Int t t) - (-> t -Nat t))) - (list -Byte -Index)) - (-Int -Nat . -> . -NonNegFixnum) - (-Int -NonPosInt . -> . -NonPosFixnum) - (-Int -Int . -> . -Fixnum))) + (lambda () + (fx-from-cases + (-One -One . -> . -Zero) + (map (lambda (t) (list (-> -Int t t) + (-> t -Nat t))) + (list -Byte -Index)) + (-Int -Nat . -> . -NonNegFixnum) + (-Int -NonPosInt . -> . -NonPosFixnum) + (-Int -Int . -> . -Fixnum)))) (define fxabs-type - (fx-from-cases - (map unop (list -Zero -One -PosByte -Byte -PosIndex -Index)) - ((Un -PosInt -NegInt) . -> . -PosFixnum) - (-Int . -> . -NonNegFixnum))) + (lambda () + (fx-from-cases + (map unop (list -Zero -One -PosByte -Byte -PosIndex -Index)) + ((Un -PosInt -NegInt) . -> . -PosFixnum) + (-Int . -> . -NonNegFixnum)))) (define fx=-type - (fx-from-cases - ;; we could rule out cases like (= Pos Neg), but we currently don't - (map (lambda (l) (apply exclude-zero l)) - (list (list -Byte -PosByte) - (list -Index -PosIndex) - (list -Nat -PosFixnum) - (list -NonPosInt -NegFixnum) - (list -Int (Un -PosFixnum -NegFixnum)))) - (map (lambda (t) (commutative-equality/filter -Int t)) - (list -One -PosByte -Byte -PosIndex -Index -PosFixnum -NonNegFixnum -NegFixnum -NonPosFixnum)) - (comp -Int))) + (lambda () + (fx-from-cases + ;; we could rule out cases like (= Pos Neg), but we currently don't + (map (lambda (l) (apply exclude-zero l)) + (list (list -Byte -PosByte) + (list -Index -PosIndex) + (list -Nat -PosFixnum) + (list -NonPosInt -NegFixnum) + (list -Int (Un -PosFixnum -NegFixnum)))) + (map (lambda (t) (commutative-equality/filter -Int t)) + (list -One -PosByte -Byte -PosIndex -Index -PosFixnum -NonNegFixnum -NegFixnum -NonPosFixnum)) + (comp -Int)))) (define fx<-type - (fx-from-cases - (-> -Pos -One B : (-FS (-filter (Un) 0) -top)) ; can't happen - (-> -Nat -One B : (-FS (-filter -Zero 0) -top)) - (-> -Int -One B : (-FS (-filter -NonPosFixnum 0) (-filter -PosFixnum 0))) - ;; bleh, this repeats cases below, but since we can only match a single - ;; case, we need to put it here as well, or we would not gain that info, - ;; as another unrelated case would match - (-> -Byte -Zero B : (-FS (-filter (Un) 0) -top)) - (-> -Byte -One B : (-FS (-filter -Zero 0) -top)) - (-> -Zero -Byte B : (-FS (-filter -PosByte 1) (-filter -Zero 1))) - (-> -Byte -PosByte B : (-FS -top (-filter -PosByte 0))) - (-> -Byte -Byte B : (-FS (-filter -PosByte 1) -top)) - (-> -Pos -Byte B : (-FS (-and (-filter -PosByte 0) (-filter -PosByte 1)) -top)) - (-> -Byte -Pos B : (-FS -top (-and (-filter -PosByte 0) (-filter -PosByte 1)))) - (-> -Nat -Byte B : (-FS (-and (-filter -Byte 0) (-filter -PosByte 1)) -top)) - (-> -Byte -Nat B : (-FS -top (-filter -Byte 1))) - (-> -Index -Zero B : (-FS (-filter (Un) 0) -top)) - (-> -Index -One B : (-FS (-filter -Zero 0) -top)) - (-> -Zero -Index B : (-FS (-filter -PosIndex 1) (-filter -Zero 1))) - (-> -Index -PosIndex B : (-FS -top (-filter -PosIndex 0))) - (-> -Index -Index B : (-FS (-filter -PosIndex 1) -top)) - (-> -Pos -Index B : (-FS (-and (-filter -PosIndex 0) (-filter -PosIndex 1)) -top)) - (-> -Index -Pos B : (-FS -top (-and (-filter -PosIndex 0) (-filter -PosIndex 1)))) - (-> -Nat -Index B : (-FS (-and (-filter -Index 0) (-filter -PosIndex 1)) -top)) - (-> -Index -Nat B : (-FS -top (-filter -Index 1))) - ;; general integer cases - (-> -Int -Zero B : (-FS (-filter -NegFixnum 0) (-filter -NonNegFixnum 0))) - (-> -Zero -Int B : (-FS (-filter -PosFixnum 1) (-filter -NonPosFixnum 1))) - (-> -Int -PosInt B : (-FS -top (-filter -PosFixnum 0))) - (-> -Int -Nat B : (-FS -top (-filter -NonNegFixnum 0))) - (-> -Nat -Int B : (-FS (-filter -PosFixnum 1) -top)) - (-> -Int -NonPosInt B : (-FS (-filter -NegFixnum 0) -top)) - (-> -NegInt -Int B : (-FS -top (-filter -NegFixnum 1))) - (-> -NonPosInt -Int B : (-FS -top (-filter -NonPosFixnum 1))) - (comp -Int))) + (lambda () + (fx-from-cases + (-> -Pos -One B : (-FS (-filter (Un) 0) -top)) ; can't happen + (-> -Nat -One B : (-FS (-filter -Zero 0) -top)) + (-> -Int -One B : (-FS (-filter -NonPosFixnum 0) (-filter -PosFixnum 0))) + ;; bleh, this repeats cases below, but since we can only match a single + ;; case, we need to put it here as well, or we would not gain that info, + ;; as another unrelated case would match + (-> -Byte -Zero B : (-FS (-filter (Un) 0) -top)) + (-> -Byte -One B : (-FS (-filter -Zero 0) -top)) + (-> -Zero -Byte B : (-FS (-filter -PosByte 1) (-filter -Zero 1))) + (-> -Byte -PosByte B : (-FS -top (-filter -PosByte 0))) + (-> -Byte -Byte B : (-FS (-filter -PosByte 1) -top)) + (-> -Pos -Byte B : (-FS (-and (-filter -PosByte 0) (-filter -PosByte 1)) -top)) + (-> -Byte -Pos B : (-FS -top (-and (-filter -PosByte 0) (-filter -PosByte 1)))) + (-> -Nat -Byte B : (-FS (-and (-filter -Byte 0) (-filter -PosByte 1)) -top)) + (-> -Byte -Nat B : (-FS -top (-filter -Byte 1))) + (-> -Index -Zero B : (-FS (-filter (Un) 0) -top)) + (-> -Index -One B : (-FS (-filter -Zero 0) -top)) + (-> -Zero -Index B : (-FS (-filter -PosIndex 1) (-filter -Zero 1))) + (-> -Index -PosIndex B : (-FS -top (-filter -PosIndex 0))) + (-> -Index -Index B : (-FS (-filter -PosIndex 1) -top)) + (-> -Pos -Index B : (-FS (-and (-filter -PosIndex 0) (-filter -PosIndex 1)) -top)) + (-> -Index -Pos B : (-FS -top (-and (-filter -PosIndex 0) (-filter -PosIndex 1)))) + (-> -Nat -Index B : (-FS (-and (-filter -Index 0) (-filter -PosIndex 1)) -top)) + (-> -Index -Nat B : (-FS -top (-filter -Index 1))) + ;; general integer cases + (-> -Int -Zero B : (-FS (-filter -NegFixnum 0) (-filter -NonNegFixnum 0))) + (-> -Zero -Int B : (-FS (-filter -PosFixnum 1) (-filter -NonPosFixnum 1))) + (-> -Int -PosInt B : (-FS -top (-filter -PosFixnum 0))) + (-> -Int -Nat B : (-FS -top (-filter -NonNegFixnum 0))) + (-> -Nat -Int B : (-FS (-filter -PosFixnum 1) -top)) + (-> -Int -NonPosInt B : (-FS (-filter -NegFixnum 0) -top)) + (-> -NegInt -Int B : (-FS -top (-filter -NegFixnum 1))) + (-> -NonPosInt -Int B : (-FS -top (-filter -NonPosFixnum 1))) + (comp -Int)))) (define fx>-type - (fx-from-cases - (-> -One -Pos B : (-FS (-filter (Un) 1) -top)) ; can't happen - (-> -One -Nat B : (-FS (-filter -Zero 1) -top)) - (-> -One -Int B : (-FS (-filter -NonPosFixnum 1) (-filter -PosFixnum 1))) - (-> -Byte -Zero B : (-FS (-filter -PosByte 0) (-filter -Zero 0))) - (-> -Zero -Byte B : (-FS (-filter (Un) 1) -top)) - (-> -One -Byte B : (-FS (-filter -Zero 1) (-filter -PosByte 1))) - (-> -PosByte -Byte B : (-FS -top (-filter -PosByte 1))) - (-> -Byte -Byte B : (-FS (-filter -PosByte 0) -top)) - (-> -Byte -Pos B : (-FS (-and (-filter -PosByte 0) (-filter -PosByte 1)) -top)) - (-> -Pos -Byte B : (-FS -top (-and (-filter -PosByte 0) (-filter -PosByte 1)))) - (-> -Byte -Nat B : (-FS (-and (-filter -PosByte 0) (-filter -Byte 1)) -top)) - (-> -Nat -Byte B : (-FS -top (-filter -Byte 0))) - (-> -Zero -Index B : (-FS (-filter (Un) 1) -top)) - (-> -One -Index B : (-FS (-filter -Zero 1) -top)) - (-> -Index -Zero B : (-FS (-filter -PosIndex 0) (-filter -Zero 0))) - (-> -PosIndex -Index B : (-FS -top (-filter -PosIndex 1))) - (-> -Index -Index B : (-FS (-filter -PosIndex 0) -top)) - (-> -Index -Pos B : (-FS (-and (-filter -PosIndex 0) (-filter -PosIndex 1)) -top)) - (-> -Pos -Index B : (-FS -top (-and (-filter -PosIndex 0) (-filter -PosIndex 1)))) - (-> -Index -Nat B : (-FS (-and (-filter -PosIndex 0) (-filter -Index 1)) -top)) - (-> -Nat -Index B : (-FS -top (-filter -Index 0))) - ;; general integer cases - (-> -Zero -Int B : (-FS (-filter -NegFixnum 1) (-filter -NonNegFixnum 1))) - (-> -Int -Zero B : (-FS (-filter -PosFixnum 0) (-filter -NonPosFixnum 0))) - (-> -PosInt -Int B : (-FS -top (-filter -PosFixnum 1))) - (-> -Nat -Int B : (-FS -top (-filter -NonNegFixnum 1))) - (-> -Int -Nat B : (-FS (-filter -PosFixnum 0) -top)) - (-> -NonPosInt -Int B : (-FS (-filter -NegFixnum 1) -top)) - (-> -Int -NegInt B : (-FS -top (-filter -NegFixnum 0))) - (-> -Int -NonPosInt B : (-FS -top (-filter -NonPosFixnum 0))) - (comp -Int))) + (lambda () + (fx-from-cases + (-> -One -Pos B : (-FS (-filter (Un) 1) -top)) ; can't happen + (-> -One -Nat B : (-FS (-filter -Zero 1) -top)) + (-> -One -Int B : (-FS (-filter -NonPosFixnum 1) (-filter -PosFixnum 1))) + (-> -Byte -Zero B : (-FS (-filter -PosByte 0) (-filter -Zero 0))) + (-> -Zero -Byte B : (-FS (-filter (Un) 1) -top)) + (-> -One -Byte B : (-FS (-filter -Zero 1) (-filter -PosByte 1))) + (-> -PosByte -Byte B : (-FS -top (-filter -PosByte 1))) + (-> -Byte -Byte B : (-FS (-filter -PosByte 0) -top)) + (-> -Byte -Pos B : (-FS (-and (-filter -PosByte 0) (-filter -PosByte 1)) -top)) + (-> -Pos -Byte B : (-FS -top (-and (-filter -PosByte 0) (-filter -PosByte 1)))) + (-> -Byte -Nat B : (-FS (-and (-filter -PosByte 0) (-filter -Byte 1)) -top)) + (-> -Nat -Byte B : (-FS -top (-filter -Byte 0))) + (-> -Zero -Index B : (-FS (-filter (Un) 1) -top)) + (-> -One -Index B : (-FS (-filter -Zero 1) -top)) + (-> -Index -Zero B : (-FS (-filter -PosIndex 0) (-filter -Zero 0))) + (-> -PosIndex -Index B : (-FS -top (-filter -PosIndex 1))) + (-> -Index -Index B : (-FS (-filter -PosIndex 0) -top)) + (-> -Index -Pos B : (-FS (-and (-filter -PosIndex 0) (-filter -PosIndex 1)) -top)) + (-> -Pos -Index B : (-FS -top (-and (-filter -PosIndex 0) (-filter -PosIndex 1)))) + (-> -Index -Nat B : (-FS (-and (-filter -PosIndex 0) (-filter -Index 1)) -top)) + (-> -Nat -Index B : (-FS -top (-filter -Index 0))) + ;; general integer cases + (-> -Zero -Int B : (-FS (-filter -NegFixnum 1) (-filter -NonNegFixnum 1))) + (-> -Int -Zero B : (-FS (-filter -PosFixnum 0) (-filter -NonPosFixnum 0))) + (-> -PosInt -Int B : (-FS -top (-filter -PosFixnum 1))) + (-> -Nat -Int B : (-FS -top (-filter -NonNegFixnum 1))) + (-> -Int -Nat B : (-FS (-filter -PosFixnum 0) -top)) + (-> -NonPosInt -Int B : (-FS (-filter -NegFixnum 1) -top)) + (-> -Int -NegInt B : (-FS -top (-filter -NegFixnum 0))) + (-> -Int -NonPosInt B : (-FS -top (-filter -NonPosFixnum 0))) + (comp -Int)))) (define fx<=-type - (fx-from-cases - (-> -Pos -One B : (-FS (-filter -One 0) -top)) - (-> -Byte -Zero B : (-FS (-filter -Zero 0) (-filter -PosByte 0))) - (-> -Zero -Byte B : (-FS -top (-filter (Un) 1))) - (-> -One -Byte B : (-FS (-filter -PosByte 1) (-filter -Zero 1))) - (-> -PosByte -Byte B : (-FS (-filter -PosByte 1) -top)) - (-> -Byte -Byte B : (-FS -top (-filter -PosByte 0))) - (-> -Pos -Byte B : (-FS (-and (-filter -PosByte 0) (-filter -PosByte 1)) -top)) - (-> -Byte -Pos B : (-FS -top (-and (-filter -PosByte 0) (-filter -PosByte 1)))) - (-> -Nat -Byte B : (-FS (-filter -Byte 0) -top)) - (-> -Byte -Nat B : (-FS -top (-and (-filter -PosByte 0) (-filter -Byte 1)))) - (-> -Index -Zero B : (-FS (-filter -Zero 0) (-filter -PosIndex 0))) - (-> -Zero -Index B : (-FS -top (-filter (Un) 1))) - (-> -One -Index B : (-FS (-filter -PosIndex 1) (-filter -Zero 1))) - (-> -PosIndex -Index B : (-FS (-filter -PosIndex 1) -top)) - (-> -Index -Index B : (-FS -top (-filter -PosIndex 0))) - (-> -Pos -Index B : (-FS (-and (-filter -PosIndex 0) (-filter -PosIndex 1)) -top)) - (-> -Index -Pos B : (-FS -top (-and (-filter -PosIndex 0) (-filter -PosIndex 1)))) - (-> -Nat -Index B : (-FS (-filter -Index 0) -top)) - (-> -Index -Nat B : (-FS -top (-and (-filter -PosIndex 0) (-filter -Index 1)))) - ;; general integer cases - (-> -Nat -Zero B : (-FS (-filter -Zero 0) -top)) - (-> -One -Nat B : (-FS (-filter -PosFixnum 1) (-filter -Zero 1))) - (-> -Int -Zero B : (-FS (-filter -NonPosFixnum 0) (-filter -PosFixnum 0))) - (-> -Zero -Int B : (-FS (-filter -NonNegFixnum 1) (-filter -NegFixnum 1))) - (-> -PosInt -Int B : (-FS (-filter -PosFixnum 1) -top)) - (-> -Int -Nat B : (-FS -top (-filter -PosFixnum 0))) - (-> -Nat -Int B : (-FS (-filter -NonNegFixnum 1) -top)) - (-> -Int -NegInt B : (-FS (-filter -NegFixnum 0) -top)) - (-> -Int -NonPosInt B : (-FS (-filter -NonPosFixnum 0) -top)) - (-> -NonPosInt -Int B : (-FS -top (-filter -NegFixnum 1))) - (comp -Int))) + (lambda () + (fx-from-cases + (-> -Pos -One B : (-FS (-filter -One 0) -top)) + (-> -Byte -Zero B : (-FS (-filter -Zero 0) (-filter -PosByte 0))) + (-> -Zero -Byte B : (-FS -top (-filter (Un) 1))) + (-> -One -Byte B : (-FS (-filter -PosByte 1) (-filter -Zero 1))) + (-> -PosByte -Byte B : (-FS (-filter -PosByte 1) -top)) + (-> -Byte -Byte B : (-FS -top (-filter -PosByte 0))) + (-> -Pos -Byte B : (-FS (-and (-filter -PosByte 0) (-filter -PosByte 1)) -top)) + (-> -Byte -Pos B : (-FS -top (-and (-filter -PosByte 0) (-filter -PosByte 1)))) + (-> -Nat -Byte B : (-FS (-filter -Byte 0) -top)) + (-> -Byte -Nat B : (-FS -top (-and (-filter -PosByte 0) (-filter -Byte 1)))) + (-> -Index -Zero B : (-FS (-filter -Zero 0) (-filter -PosIndex 0))) + (-> -Zero -Index B : (-FS -top (-filter (Un) 1))) + (-> -One -Index B : (-FS (-filter -PosIndex 1) (-filter -Zero 1))) + (-> -PosIndex -Index B : (-FS (-filter -PosIndex 1) -top)) + (-> -Index -Index B : (-FS -top (-filter -PosIndex 0))) + (-> -Pos -Index B : (-FS (-and (-filter -PosIndex 0) (-filter -PosIndex 1)) -top)) + (-> -Index -Pos B : (-FS -top (-and (-filter -PosIndex 0) (-filter -PosIndex 1)))) + (-> -Nat -Index B : (-FS (-filter -Index 0) -top)) + (-> -Index -Nat B : (-FS -top (-and (-filter -PosIndex 0) (-filter -Index 1)))) + ;; general integer cases + (-> -Nat -Zero B : (-FS (-filter -Zero 0) -top)) + (-> -One -Nat B : (-FS (-filter -PosFixnum 1) (-filter -Zero 1))) + (-> -Int -Zero B : (-FS (-filter -NonPosFixnum 0) (-filter -PosFixnum 0))) + (-> -Zero -Int B : (-FS (-filter -NonNegFixnum 1) (-filter -NegFixnum 1))) + (-> -PosInt -Int B : (-FS (-filter -PosFixnum 1) -top)) + (-> -Int -Nat B : (-FS -top (-filter -PosFixnum 0))) + (-> -Nat -Int B : (-FS (-filter -NonNegFixnum 1) -top)) + (-> -Int -NegInt B : (-FS (-filter -NegFixnum 0) -top)) + (-> -Int -NonPosInt B : (-FS (-filter -NonPosFixnum 0) -top)) + (-> -NonPosInt -Int B : (-FS -top (-filter -NegFixnum 1))) + (comp -Int)))) (define fx>=-type - (fx-from-cases - (-> -One -Pos B : (-FS (-filter -One 1) -top)) - (-> -Zero -Byte B : (-FS (-filter -Zero 1) (-filter -PosByte 1))) - (-> -Byte -Zero B : (-FS -top (-filter (Un) 0))) - (-> -Byte -One B : (-FS (-filter -PosByte 0) (-filter -Zero 0))) - (-> -Byte -PosByte B : (-FS (-filter -PosByte 0) -top)) - (-> -Byte -Byte B : (-FS -top (-filter -PosByte 1))) - (-> -Byte -Pos B : (-FS (-and (-filter -PosByte 1) (-filter -PosByte 0)) -top)) - (-> -Pos -Byte B : (-FS -top (-and (-filter -PosByte 1) (-filter -PosByte 0)))) - (-> -Byte -Nat B : (-FS (-filter -Byte 1) -top)) - (-> -Nat -Byte B : (-FS -top (-and (-filter -Byte 0) (-filter -PosByte 1)))) - (-> -Zero -Index B : (-FS (-filter -Zero 1) (-filter -PosIndex 1))) - (-> -Index -Zero B : (-FS -top (-filter (Un) 0))) - (-> -Index -One B : (-FS (-filter -PosIndex 0) (-filter -Zero 0))) - (-> -Index -PosIndex B : (-FS (-filter -PosIndex 0) -top)) - (-> -Index -Index B : (-FS -top (-filter -PosIndex 1))) - (-> -Index -Pos B : (-FS (-and (-filter -PosIndex 0) (-filter -PosIndex 1)) -top)) - (-> -Pos -Index B : (-FS -top (-and (-filter -PosIndex 0) (-filter -PosIndex 1)))) - (-> -Index -Nat B : (-FS (-filter -Index 1) -top)) - (-> -Nat -Index B : (-FS -top (-and (-filter -Index 0) (-filter -PosIndex 1)))) - ;; general integer cases - (-> -Zero -Nat B : (-FS (-filter -Zero 1) -top)) - (-> -Nat -One B : (-FS (-filter -PosFixnum 0) (-filter -Zero 0))) - (-> -Zero -Int B : (-FS (-filter -NonPosFixnum 1) (-filter -PosFixnum 1))) - (-> -Int -Zero B : (-FS (-filter -NonNegFixnum 0) (-filter -NegFixnum 0))) - (-> -Int -PosInt B : (-FS (-filter -PosFixnum 0) -top)) - (-> -Nat -Int B : (-FS -top (-filter -PosFixnum 1))) - (-> -Int -Nat B : (-FS (-filter -NonNegFixnum 0) -top)) - (-> -NegInt -Int B : (-FS (-filter -NegFixnum 1) -top)) - (-> -NonPosInt -Int B : (-FS (-filter -NonPosFixnum 1) -top)) - (-> -Int -NonPosInt B : (-FS -top (-filter -NegFixnum 0))) - (comp -Int))) + (lambda () + (fx-from-cases + (-> -One -Pos B : (-FS (-filter -One 1) -top)) + (-> -Zero -Byte B : (-FS (-filter -Zero 1) (-filter -PosByte 1))) + (-> -Byte -Zero B : (-FS -top (-filter (Un) 0))) + (-> -Byte -One B : (-FS (-filter -PosByte 0) (-filter -Zero 0))) + (-> -Byte -PosByte B : (-FS (-filter -PosByte 0) -top)) + (-> -Byte -Byte B : (-FS -top (-filter -PosByte 1))) + (-> -Byte -Pos B : (-FS (-and (-filter -PosByte 1) (-filter -PosByte 0)) -top)) + (-> -Pos -Byte B : (-FS -top (-and (-filter -PosByte 1) (-filter -PosByte 0)))) + (-> -Byte -Nat B : (-FS (-filter -Byte 1) -top)) + (-> -Nat -Byte B : (-FS -top (-and (-filter -Byte 0) (-filter -PosByte 1)))) + (-> -Zero -Index B : (-FS (-filter -Zero 1) (-filter -PosIndex 1))) + (-> -Index -Zero B : (-FS -top (-filter (Un) 0))) + (-> -Index -One B : (-FS (-filter -PosIndex 0) (-filter -Zero 0))) + (-> -Index -PosIndex B : (-FS (-filter -PosIndex 0) -top)) + (-> -Index -Index B : (-FS -top (-filter -PosIndex 1))) + (-> -Index -Pos B : (-FS (-and (-filter -PosIndex 0) (-filter -PosIndex 1)) -top)) + (-> -Pos -Index B : (-FS -top (-and (-filter -PosIndex 0) (-filter -PosIndex 1)))) + (-> -Index -Nat B : (-FS (-filter -Index 1) -top)) + (-> -Nat -Index B : (-FS -top (-and (-filter -Index 0) (-filter -PosIndex 1)))) + ;; general integer cases + (-> -Zero -Nat B : (-FS (-filter -Zero 1) -top)) + (-> -Nat -One B : (-FS (-filter -PosFixnum 0) (-filter -Zero 0))) + (-> -Zero -Int B : (-FS (-filter -NonPosFixnum 1) (-filter -PosFixnum 1))) + (-> -Int -Zero B : (-FS (-filter -NonNegFixnum 0) (-filter -NegFixnum 0))) + (-> -Int -PosInt B : (-FS (-filter -PosFixnum 0) -top)) + (-> -Nat -Int B : (-FS -top (-filter -PosFixnum 1))) + (-> -Int -Nat B : (-FS (-filter -NonNegFixnum 0) -top)) + (-> -NegInt -Int B : (-FS (-filter -NegFixnum 1) -top)) + (-> -NonPosInt -Int B : (-FS (-filter -NonPosFixnum 1) -top)) + (-> -Int -NonPosInt B : (-FS -top (-filter -NegFixnum 0))) + (comp -Int)))) (define fxmin-type - (fx-from-cases - (binop -Zero) - (binop -One) - (commutative-binop -Zero (Un -Zero -One) -Zero) - (commutative-binop -PosByte -PosInt -PosByte) - (commutative-binop -Byte -Nat -Byte) - (commutative-binop -PosIndex -PosInt -PosIndex) - (commutative-binop -Index -Nat -Index) - (-> -Pos -Pos -PosFixnum) - (-> -Nat -Nat -NonNegFixnum) - (commutative-binop -NegInt -Int -NegFixnum) - (commutative-binop -NonPosInt -Int -NonPosInt) - (-> -Int -Int -Fixnum))) + (lambda () + (fx-from-cases + (binop -Zero) + (binop -One) + (commutative-binop -Zero (Un -Zero -One) -Zero) + (commutative-binop -PosByte -PosInt -PosByte) + (commutative-binop -Byte -Nat -Byte) + (commutative-binop -PosIndex -PosInt -PosIndex) + (commutative-binop -Index -Nat -Index) + (-> -Pos -Pos -PosFixnum) + (-> -Nat -Nat -NonNegFixnum) + (commutative-binop -NegInt -Int -NegFixnum) + (commutative-binop -NonPosInt -Int -NonPosInt) + (-> -Int -Int -Fixnum)))) (define fxmax-type - (fx-from-cases - (binop -Zero) - (commutative-binop -One (Un -Zero -One) -One) - (commutative-binop -PosByte -Byte -PosByte) - (binop -Byte) - (commutative-binop -PosIndex -Index -PosIndex) - (map binop (list -Index -NegFixnum -NonPosFixnum)) - (commutative-binop -PosInt -Int -PosFixnum) - (commutative-binop -Nat -Int -NonNegFixnum) - (-> -Int -Int -Fixnum))) + (lambda () + (fx-from-cases + (binop -Zero) + (commutative-binop -One (Un -Zero -One) -One) + (commutative-binop -PosByte -Byte -PosByte) + (binop -Byte) + (commutative-binop -PosIndex -Index -PosIndex) + (map binop (list -Index -NegFixnum -NonPosFixnum)) + (commutative-binop -PosInt -Int -PosFixnum) + (commutative-binop -Nat -Int -NonNegFixnum) + (-> -Int -Int -Fixnum)))) (define fxand-type - (fx-from-cases - (commutative-binop -Zero -Int -Zero) - (commutative-binop -Byte -Int -Byte) - (commutative-binop -Index -Int -Index) - (binop -Nat -NonNegFixnum) - (binop -NegInt -NegFixnum) - (binop -NonPosInt -NonPosFixnum) - (binop -Int -Fixnum))) + (lambda () + (fx-from-cases + (commutative-binop -Zero -Int -Zero) + (commutative-binop -Byte -Int -Byte) + (commutative-binop -Index -Int -Index) + (binop -Nat -NonNegFixnum) + (binop -NegInt -NegFixnum) + (binop -NonPosInt -NonPosFixnum) + (binop -Int -Fixnum)))) (define fxior-type - (fx-from-cases - (binop -Zero) - (commutative-binop -One -Zero -One) - (commutative-binop -PosByte -Byte -PosByte) - (binop -Byte) - (commutative-binop -PosIndex -Index -PosIndex) - (binop -Index) - (commutative-binop -PosInt -Nat -PosFixnum) - (binop -Nat -NonNegFixnum) - (commutative-binop -NegInt -Int -NegFixnum) ; as long as there's one negative, the result is negative - (binop -Int -Fixnum))) + (lambda () + (fx-from-cases + (binop -Zero) + (commutative-binop -One -Zero -One) + (commutative-binop -PosByte -Byte -PosByte) + (binop -Byte) + (commutative-binop -PosIndex -Index -PosIndex) + (binop -Index) + (commutative-binop -PosInt -Nat -PosFixnum) + (binop -Nat -NonNegFixnum) + (commutative-binop -NegInt -Int -NegFixnum) ; as long as there's one negative, the result is negative + (binop -Int -Fixnum)))) (define fxxor-type - (fx-from-cases - (binop -Zero) - (binop -One -Zero) - (binop -Byte) - (binop -Index) - (binop -Nat -NonNegFixnum) - (binop -NonPosInt -NonNegFixnum) - (commutative-binop -NegInt -Nat -NegFixnum) - (commutative-binop -NonPosInt -Nat -NonPosFixnum) - (binop -Int -Fixnum))) + (lambda () + (fx-from-cases + (binop -Zero) + (binop -One -Zero) + (binop -Byte) + (binop -Index) + (binop -Nat -NonNegFixnum) + (binop -NonPosInt -NonNegFixnum) + (commutative-binop -NegInt -Nat -NegFixnum) + (commutative-binop -NonPosInt -Nat -NonPosFixnum) + (binop -Int -Fixnum)))) (define fxnot-type - (fx-from-cases - (-Nat . -> . -NegFixnum) - (-NegInt . -> . -NonNegFixnum) - (-Int . -> . -Fixnum))) + (lambda () + (fx-from-cases + (-Nat . -> . -NegFixnum) + (-NegInt . -> . -NonNegFixnum) + (-Int . -> . -Fixnum)))) (define fxlshift-type - (fx-from-cases - (map (lambda (x) (-> x -Zero x)) - (list -Zero -One -PosByte -Byte -PosIndex -Index)) - (-> -PosInt -Int -PosFixnum) ; negative 2nd arg errors, so we can't reach 0 - (-> -Nat -Int -NonNegFixnum) - (-> -NegInt -Int -NegFixnum) - (-> -NonPosInt -Int -NonPosFixnum) - (binop -Int -Fixnum))) + (lambda () + (fx-from-cases + (map (lambda (x) (-> x -Zero x)) + (list -Zero -One -PosByte -Byte -PosIndex -Index)) + (-> -PosInt -Int -PosFixnum) ; negative 2nd arg errors, so we can't reach 0 + (-> -Nat -Int -NonNegFixnum) + (-> -NegInt -Int -NegFixnum) + (-> -NonPosInt -Int -NonPosFixnum) + (binop -Int -Fixnum)))) (define fxrshift-type - (fx-from-cases - (map (lambda (x) (-> x -Zero x)) - (list -Zero -One -PosByte -Byte -PosIndex -Index)) - (-> -Nat -Int -NonNegFixnum) ; can reach 0 - (-> -NegInt -Int -NegFixnum) ; can't reach 0 - (-> -NonPosInt -Int -NonPosFixnum) - (binop -Int -Fixnum))) + (lambda () + (fx-from-cases + (map (lambda (x) (-> x -Zero x)) + (list -Zero -One -PosByte -Byte -PosIndex -Index)) + (-> -Nat -Int -NonNegFixnum) ; can reach 0 + (-> -NegInt -Int -NegFixnum) ; can't reach 0 + (-> -NonPosInt -Int -NonPosFixnum) + (binop -Int -Fixnum)))) - (define flabs-type (cl->* (-> (Un -PosFlonum -NegFlonum) -PosFlonum) - (-> -Flonum -NonNegFlonum))) + (define flabs-type + (lambda () + (cl->* (-> (Un -PosFlonum -NegFlonum) -PosFlonum) + (-> -Flonum -NonNegFlonum)))) (define fl+-type - (from-cases (map (lambda (t) (commutative-binop t -FlonumZero t)) - all-flonum-types) - (commutative-binop -NonNegFlonum -PosFlonum -PosFlonum) - (map binop (list -NonNegFlonum -NegFlonum -NonPosFlonum -Flonum)) - (-Flonum -Flonum . -> . -Flonum))) + (lambda () + (from-cases (map (lambda (t) (commutative-binop t -FlonumZero t)) + all-flonum-types) + (commutative-binop -NonNegFlonum -PosFlonum -PosFlonum) + (map binop (list -NonNegFlonum -NegFlonum -NonPosFlonum -Flonum)) + (-Flonum -Flonum . -> . -Flonum)))) (define fl--type - (from-cases (binop -FlonumZero) - (-NegFlonum (Un -NonNegFlonum -FlonumZero) . -> . -NegFlonum) - ((Un -NonPosFlonum -FlonumZero) -PosFlonum . -> . -NegFlonum) - (-NonPosFlonum -NonNegFlonum . -> . -NonPosFlonum) - (binop -Flonum))) + (lambda () + (from-cases (binop -FlonumZero) + (-NegFlonum (Un -NonNegFlonum -FlonumZero) . -> . -NegFlonum) + ((Un -NonPosFlonum -FlonumZero) -PosFlonum . -> . -NegFlonum) + (-NonPosFlonum -NonNegFlonum . -> . -NonPosFlonum) + (binop -Flonum)))) (define fl*-type - (from-cases (map binop (list -FlonumPosZero -FlonumNegZero)) - (commutative-binop -FlonumNegZero -FlonumPosZero -FlonumNegZero) - (binop -FlonumNegZero -FlonumPosZero) - ;; we don't have Pos Pos -> Pos, possible underflow - (map binop (list -FlonumZero -NonNegFlonum)) - (commutative-binop -NegFlonum -PosFlonum -NonPosFlonum) - (binop -NegFlonum -NonNegFlonum) - (commutative-binop -NonPosFlonum -NonNegFlonum -NonPosFlonum) - (binop -NonPosFlonum -NonNegFlonum) - (binop -Flonum))) + (lambda () + (from-cases (map binop (list -FlonumPosZero -FlonumNegZero)) + (commutative-binop -FlonumNegZero -FlonumPosZero -FlonumNegZero) + (binop -FlonumNegZero -FlonumPosZero) + ;; we don't have Pos Pos -> Pos, possible underflow + (map binop (list -FlonumZero -NonNegFlonum)) + (commutative-binop -NegFlonum -PosFlonum -NonPosFlonum) + (binop -NegFlonum -NonNegFlonum) + (commutative-binop -NonPosFlonum -NonNegFlonum -NonPosFlonum) + (binop -NonPosFlonum -NonNegFlonum) + (binop -Flonum)))) (define fl/-type - (from-cases (-FlonumPosZero -PosFlonum . -> . -FlonumPosZero) - (-FlonumPosZero -NegFlonum . -> . -FlonumNegZero) - (-FlonumNegZero -PosFlonum . -> . -FlonumNegZero) - (-FlonumNegZero -NegFlonum . -> . -FlonumPosZero) - (-PosFlonum -PosFlonum . -> . -NonNegFlonum) ; possible underflow - (commutative-binop -PosFlonum -NegFlonum -NonPosFlonum) - (-NegFlonum -NegFlonum . -> . -NonNegFlonum) - (binop -Flonum))) + (lambda () + (from-cases (-FlonumPosZero -PosFlonum . -> . -FlonumPosZero) + (-FlonumPosZero -NegFlonum . -> . -FlonumNegZero) + (-FlonumNegZero -PosFlonum . -> . -FlonumNegZero) + (-FlonumNegZero -NegFlonum . -> . -FlonumPosZero) + (-PosFlonum -PosFlonum . -> . -NonNegFlonum) ; possible underflow + (commutative-binop -PosFlonum -NegFlonum -NonPosFlonum) + (-NegFlonum -NegFlonum . -> . -NonNegFlonum) + (binop -Flonum)))) (define fl=-type - (from-cases (map (lambda (l) (exclude-zero (car l) (cadr l) -FlonumZero)) - (list (list -NonNegFlonum -PosFlonum) - (list -NonPosFlonum -NegFlonum))) - (map (lambda (t) (commutative-equality/filter -Flonum t)) - (list -FlonumZero -PosFlonum -NonNegFlonum - -NegFlonum -NonPosFlonum)) - (comp -Flonum))) + (lambda () + (from-cases (map (lambda (l) (exclude-zero (car l) (cadr l) -FlonumZero)) + (list (list -NonNegFlonum -PosFlonum) + (list -NonPosFlonum -NegFlonum))) + (map (lambda (t) (commutative-equality/filter -Flonum t)) + (list -FlonumZero -PosFlonum -NonNegFlonum + -NegFlonum -NonPosFlonum)) + (comp -Flonum)))) (define fl<-type - (from-cases - (-> -FlonumZero -Flonum B : (-FS (-filter -PosFlonum 1) (-filter (Un -NonPosFlonum -FlonumPosZero) 1))) - (-> -Flonum -FlonumZero B : (-FS (-filter -NegFlonum 0) (-filter (Un -NonNegFlonum -FlonumNegZero) 0))) - (-> -PosFlonum -Flonum B : (-FS (-filter -PosFlonum 1) -top)) - (-> -Flonum -PosFlonum B : (-FS -top (-filter -PosFlonum 0))) - (-> -NonNegFlonum -Flonum B : (-FS (-filter -PosFlonum 1) -top)) - (-> -Flonum -NonNegFlonum B : (-FS -top (-filter (Un -NonNegFlonum -FlonumNegZero) 0))) - (-> -NegFlonum -Flonum B : (-FS -top (-filter -NegFlonum 1))) - (-> -Flonum -NegFlonum B : (-FS (-filter -NegFlonum 0) -top)) - (-> -NonPosFlonum -Flonum B : (-FS -top (-filter (Un -NonPosFlonum -FlonumPosZero) 1))) - (-> -Flonum -NonPosFlonum B : (-FS (-filter -NegFlonum 0) -top)) - (comp -Flonum))) + (lambda () + (from-cases + (-> -FlonumZero -Flonum B : (-FS (-filter -PosFlonum 1) (-filter (Un -NonPosFlonum -FlonumPosZero) 1))) + (-> -Flonum -FlonumZero B : (-FS (-filter -NegFlonum 0) (-filter (Un -NonNegFlonum -FlonumNegZero) 0))) + (-> -PosFlonum -Flonum B : (-FS (-filter -PosFlonum 1) -top)) + (-> -Flonum -PosFlonum B : (-FS -top (-filter -PosFlonum 0))) + (-> -NonNegFlonum -Flonum B : (-FS (-filter -PosFlonum 1) -top)) + (-> -Flonum -NonNegFlonum B : (-FS -top (-filter (Un -NonNegFlonum -FlonumNegZero) 0))) + (-> -NegFlonum -Flonum B : (-FS -top (-filter -NegFlonum 1))) + (-> -Flonum -NegFlonum B : (-FS (-filter -NegFlonum 0) -top)) + (-> -NonPosFlonum -Flonum B : (-FS -top (-filter (Un -NonPosFlonum -FlonumPosZero) 1))) + (-> -Flonum -NonPosFlonum B : (-FS (-filter -NegFlonum 0) -top)) + (comp -Flonum)))) (define fl>-type - (from-cases - (-> -FlonumZero -Flonum B : (-FS (-filter -NegFlonum 1) (-filter (Un -NonNegFlonum -FlonumNegZero) 1))) - (-> -Flonum -FlonumZero B : (-FS (-filter -PosFlonum 0) (-filter (Un -NonPosFlonum -FlonumPosZero) 0))) - (-> -PosFlonum -Flonum B : (-FS -top (-filter -PosFlonum 1))) - (-> -Flonum -PosFlonum B : (-FS (-filter -PosFlonum 0) -top)) - (-> -NonNegFlonum -Flonum B : (-FS -top (-filter (Un -NonNegFlonum -FlonumNegZero) 1))) - (-> -Flonum -NonNegFlonum B : (-FS (-filter -PosFlonum 0) -top)) - (-> -NegFlonum -Flonum B : (-FS (-filter -NegFlonum 1) -top)) - (-> -Flonum -NegFlonum B : (-FS -top (-filter -NegFlonum 0))) - (-> -NonPosFlonum -Flonum B : (-FS (-filter -NegFlonum 1) -top)) - (-> -Flonum -NonPosFlonum B : (-FS -top (-filter (Un -NonPosFlonum -FlonumPosZero) 0))) - (comp -Flonum))) + (lambda () + (from-cases + (-> -FlonumZero -Flonum B : (-FS (-filter -NegFlonum 1) (-filter (Un -NonNegFlonum -FlonumNegZero) 1))) + (-> -Flonum -FlonumZero B : (-FS (-filter -PosFlonum 0) (-filter (Un -NonPosFlonum -FlonumPosZero) 0))) + (-> -PosFlonum -Flonum B : (-FS -top (-filter -PosFlonum 1))) + (-> -Flonum -PosFlonum B : (-FS (-filter -PosFlonum 0) -top)) + (-> -NonNegFlonum -Flonum B : (-FS -top (-filter (Un -NonNegFlonum -FlonumNegZero) 1))) + (-> -Flonum -NonNegFlonum B : (-FS (-filter -PosFlonum 0) -top)) + (-> -NegFlonum -Flonum B : (-FS (-filter -NegFlonum 1) -top)) + (-> -Flonum -NegFlonum B : (-FS -top (-filter -NegFlonum 0))) + (-> -NonPosFlonum -Flonum B : (-FS (-filter -NegFlonum 1) -top)) + (-> -Flonum -NonPosFlonum B : (-FS -top (-filter (Un -NonPosFlonum -FlonumPosZero) 0))) + (comp -Flonum)))) (define fl<=-type - (from-cases - (-> -FlonumZero -Flonum B : (-FS (-filter (Un -NonNegFlonum -FlonumNegZero) 1) (-filter -NegFlonum 1))) - (-> -Flonum -FlonumZero B : (-FS (-filter (Un -NonPosFlonum -FlonumPosZero) 0) (-filter -PosFlonum 0))) - (-> -PosFlonum -Flonum B : (-FS (-filter -PosFlonum 1) -top)) - (-> -Flonum -PosFlonum B : (-FS -top (-filter -PosFlonum 0))) - (-> -NonNegFlonum -Flonum B : (-FS (-filter (Un -NonNegFlonum -FlonumNegZero) 1) -top)) - (-> -Flonum -NonNegFlonum B : (-FS -top (-filter -PosFlonum 0))) - (-> -NegFlonum -Flonum B : (-FS -top (-filter -NegFlonum 1))) - (-> -Flonum -NegFlonum B : (-FS (-filter -NegFlonum 0) -top)) - (-> -NonPosFlonum -Flonum B : (-FS -top (-filter -NegFlonum 1))) - (-> -Flonum -NonPosFlonum B : (-FS (-filter (Un -NonPosFlonum -FlonumPosZero) 0) -top)) - (comp -Flonum))) + (lambda () + (from-cases + (-> -FlonumZero -Flonum B : (-FS (-filter (Un -NonNegFlonum -FlonumNegZero) 1) (-filter -NegFlonum 1))) + (-> -Flonum -FlonumZero B : (-FS (-filter (Un -NonPosFlonum -FlonumPosZero) 0) (-filter -PosFlonum 0))) + (-> -PosFlonum -Flonum B : (-FS (-filter -PosFlonum 1) -top)) + (-> -Flonum -PosFlonum B : (-FS -top (-filter -PosFlonum 0))) + (-> -NonNegFlonum -Flonum B : (-FS (-filter (Un -NonNegFlonum -FlonumNegZero) 1) -top)) + (-> -Flonum -NonNegFlonum B : (-FS -top (-filter -PosFlonum 0))) + (-> -NegFlonum -Flonum B : (-FS -top (-filter -NegFlonum 1))) + (-> -Flonum -NegFlonum B : (-FS (-filter -NegFlonum 0) -top)) + (-> -NonPosFlonum -Flonum B : (-FS -top (-filter -NegFlonum 1))) + (-> -Flonum -NonPosFlonum B : (-FS (-filter (Un -NonPosFlonum -FlonumPosZero) 0) -top)) + (comp -Flonum)))) (define fl>=-type - (from-cases - (-> -FlonumZero -Flonum B : (-FS (-filter (Un -NonPosFlonum -FlonumPosZero) 1) (-filter -PosFlonum 1))) - (-> -Flonum -FlonumZero B : (-FS (-filter (Un -NonNegFlonum -FlonumNegZero) 0) (-filter -NegFlonum 0))) - (-> -PosFlonum -Flonum B : (-FS -top (-filter -PosFlonum 1))) - (-> -Flonum -PosFlonum B : (-FS (-filter -PosFlonum 0) -top)) - (-> -NonNegFlonum -Flonum B : (-FS -top (-filter -PosFlonum 1))) - (-> -Flonum -NonNegFlonum B : (-FS (-filter (Un -NonNegFlonum -FlonumNegZero) 0) -top)) - (-> -NegFlonum -Flonum B : (-FS (-filter -NegFlonum 1) -top)) - (-> -Flonum -NegFlonum B : (-FS -top (-filter -NegFlonum 0))) - (-> -NonPosFlonum -Flonum B : (-FS -top (-filter -PosFlonum 1))) - (-> -Flonum -NonPosFlonum B : (-FS (-filter (Un -NonPosFlonum -FlonumPosZero) 0) -top)) - (comp -Flonum))) + (lambda () + (from-cases + (-> -FlonumZero -Flonum B : (-FS (-filter (Un -NonPosFlonum -FlonumPosZero) 1) (-filter -PosFlonum 1))) + (-> -Flonum -FlonumZero B : (-FS (-filter (Un -NonNegFlonum -FlonumNegZero) 0) (-filter -NegFlonum 0))) + (-> -PosFlonum -Flonum B : (-FS -top (-filter -PosFlonum 1))) + (-> -Flonum -PosFlonum B : (-FS (-filter -PosFlonum 0) -top)) + (-> -NonNegFlonum -Flonum B : (-FS -top (-filter -PosFlonum 1))) + (-> -Flonum -NonNegFlonum B : (-FS (-filter (Un -NonNegFlonum -FlonumNegZero) 0) -top)) + (-> -NegFlonum -Flonum B : (-FS (-filter -NegFlonum 1) -top)) + (-> -Flonum -NegFlonum B : (-FS -top (-filter -NegFlonum 0))) + (-> -NonPosFlonum -Flonum B : (-FS -top (-filter -PosFlonum 1))) + (-> -Flonum -NonPosFlonum B : (-FS (-filter (Un -NonPosFlonum -FlonumPosZero) 0) -top)) + (comp -Flonum)))) (define flmin-type - (from-cases (map binop - (list -PosFlonum -NonNegFlonum -NegFlonum -NonPosFlonum -Flonum)))) + (lambda () + (from-cases (map binop + (list -PosFlonum -NonNegFlonum -NegFlonum -NonPosFlonum -Flonum))))) (define flmax-type - (from-cases (commutative-case -PosFlonum -Flonum -PosFlonum) - (commutative-case -NonNegFlonum -Flonum -NonNegFlonum) - (binop -NegFlonum) - (commutative-case -NegFlonum -NonPosFlonum -NonPosFlonum) - (binop -Flonum))) + (lambda () + (from-cases (commutative-case -PosFlonum -Flonum -PosFlonum) + (commutative-case -NonNegFlonum -Flonum -NonNegFlonum) + (binop -NegFlonum) + (commutative-case -NegFlonum -NonPosFlonum -NonPosFlonum) + (binop -Flonum)))) (define flround-type ; truncate too - (from-cases (map unop (list -FlonumPosZero -FlonumNegZero -FlonumZero - -NonNegFlonum -NonPosFlonum -Flonum)))) + (lambda () + (from-cases (map unop (list -FlonumPosZero -FlonumNegZero -FlonumZero + -NonNegFlonum -NonPosFlonum -Flonum))))) (define flfloor-type - (from-cases (map unop (list -FlonumPosZero -FlonumNegZero -FlonumZero - -NonNegFlonum -NegFlonum -NonPosFlonum -Flonum)))) + (lambda () + (from-cases (map unop (list -FlonumPosZero -FlonumNegZero -FlonumZero + -NonNegFlonum -NegFlonum -NonPosFlonum -Flonum))))) (define flceiling-type - (from-cases (map unop (list -FlonumPosZero -FlonumNegZero -FlonumZero - -PosFlonum -NonNegFlonum -NonPosFlonum -Flonum)))) + (lambda () + (from-cases (map unop (list -FlonumPosZero -FlonumNegZero -FlonumZero + -PosFlonum -NonNegFlonum -NonPosFlonum -Flonum))))) (define fllog-type - (from-cases (-> -FlonumZero -NegFlonum) ; -inf - (-> -PosFlonum -NonNegFlonum) ; possible underflow - (unop -Flonum))) + (lambda () + (from-cases (-> -FlonumZero -NegFlonum) ; -inf + (-> -PosFlonum -NonNegFlonum) ; possible underflow + (unop -Flonum)))) (define flexp-type - (from-cases ((Un -NonNegFlonum -FlonumNegZero) . -> . -PosFlonum) - (-NegFlonum . -> . -NonNegFlonum) - (-Flonum . -> . -Flonum))) ; nan is the only non nonnegative case (returns nan) + (lambda () + (from-cases ((Un -NonNegFlonum -FlonumNegZero) . -> . -PosFlonum) + (-NegFlonum . -> . -NonNegFlonum) + (-Flonum . -> . -Flonum)))) ; nan is the only non nonnegative case (returns nan) (define flsqrt-type - (from-cases (map unop (list -FlonumPosZero -FlonumNegZero -FlonumZero - -NonNegFlonum ; we don't have positive case, possible underflow - -Flonum)))) ; anything negative returns nan - (define fx->fl-type (fx-from-cases - (-PosInt . -> . -PosFlonum) - (-Nat . -> . -NonNegFlonum) - (-NegInt . -> . -NegFlonum) - (-NonPosInt . -> . -NonPosFlonum) - (-Int . -> . -Flonum))) - (define make-flrectangular-type (-Flonum -Flonum . -> . -FloatComplex)) - (define flreal-part-type (-FloatComplex . -> . -Flonum)) - (define flimag-part-type (-FloatComplex . -> . -Flonum)) + (lambda () + (from-cases (map unop (list -FlonumPosZero -FlonumNegZero -FlonumZero + -NonNegFlonum ; we don't have positive case, possible underflow + -Flonum))))) ; anything negative returns nan + (define fx->fl-type + (lambda () + (fx-from-cases + (-PosInt . -> . -PosFlonum) + (-Nat . -> . -NonNegFlonum) + (-NegInt . -> . -NegFlonum) + (-NonPosInt . -> . -NonPosFlonum) + (-Int . -> . -Flonum)))) + (define make-flrectangular-type (lambda () (-Flonum -Flonum . -> . -FloatComplex))) + (define flreal-part-type (lambda () (-FloatComplex . -> . -Flonum))) + (define flimag-part-type (lambda () (-FloatComplex . -> . -Flonum))) ;; There's a repetitive pattern in the types of each comparison operator. ;; As explained below, this is because filters don't do intersections. @@ -1461,8 +1503,8 @@ -InexactRealPosZero -InexactRealNegZero -InexactRealZero -PosInexactReal -NonNegInexactReal -NonPosInexactReal -InexactReal -RealZero -PosReal -NonNegReal -NonPosReal -Real)))] -[truncate round-type] -[round round-type] +[truncate (round-type)] +[round (round-type)] [make-rectangular (cl->* (-Rat -Rat . -> . -ExactNumber) (-Flonum -Real . -> . -FloatComplex) @@ -1747,117 +1789,117 @@ ;; scheme/fixnum -[fx+ fx+-type] -[fx- fx--type] -[fx* fx*-type] -[fxquotient fxquotient-type] -[fxremainder fxremainder-type] -[fxmodulo fxmodulo-type] -[fxabs fxabs-type] +[fx+ (fx+-type)] +[fx- (fx--type)] +[fx* (fx*-type)] +[fxquotient (fxquotient-type)] +[fxremainder (fxremainder-type)] +[fxmodulo (fxmodulo-type)] +[fxabs (fxabs-type)] -[fxand fxand-type] -[fxior fxior-type] -[fxxor fxxor-type] -[fxnot fxnot-type] -[fxlshift fxlshift-type] -[fxrshift fxrshift-type] +[fxand (fxand-type)] +[fxior (fxior-type)] +[fxxor (fxxor-type)] +[fxnot (fxnot-type)] +[fxlshift (fxlshift-type)] +[fxrshift (fxrshift-type)] -[fx= fx=-type] -[fx< fx<-type] -[fx> fx>-type] -[fx<= fx<=-type] -[fx>= fx>=-type] -[fxmin fxmin-type] -[fxmax fxmax-type] +[fx= (fx=-type)] +[fx< (fx<-type)] +[fx> (fx>-type)] +[fx<= (fx<=-type)] +[fx>= (fx>=-type)] +[fxmin (fxmin-type)] +[fxmax (fxmax-type)] -[unsafe-fx+ fx+-type] -[unsafe-fx- fx--type] -[unsafe-fx* fx*-type] -[unsafe-fxquotient fxquotient-type] -[unsafe-fxremainder fxremainder-type] -[unsafe-fxmodulo fxmodulo-type] -[unsafe-fxabs fxabs-type] +[unsafe-fx+ (fx+-type)] +[unsafe-fx- (fx--type)] +[unsafe-fx* (fx*-type)] +[unsafe-fxquotient (fxquotient-type)] +[unsafe-fxremainder (fxremainder-type)] +[unsafe-fxmodulo (fxmodulo-type)] +[unsafe-fxabs (fxabs-type)] -[unsafe-fxand fxand-type] -[unsafe-fxior fxior-type] -[unsafe-fxxor fxxor-type] -[unsafe-fxnot fxnot-type] -[unsafe-fxlshift fxlshift-type] -[unsafe-fxrshift fxrshift-type] +[unsafe-fxand (fxand-type)] +[unsafe-fxior (fxior-type)] +[unsafe-fxxor (fxxor-type)] +[unsafe-fxnot (fxnot-type)] +[unsafe-fxlshift (fxlshift-type)] +[unsafe-fxrshift (fxrshift-type)] -[unsafe-fx= fx=-type] -[unsafe-fx< fx<-type] -[unsafe-fx> fx>-type] -[unsafe-fx<= fx<=-type] -[unsafe-fx>= fx>=-type] -[unsafe-fxmin fxmin-type] -[unsafe-fxmax fxmax-type] +[unsafe-fx= (fx=-type)] +[unsafe-fx< (fx<-type)] +[unsafe-fx> (fx>-type)] +[unsafe-fx<= (fx<=-type)] +[unsafe-fx>= (fx>=-type)] +[unsafe-fxmin (fxmin-type)] +[unsafe-fxmax (fxmax-type)] ;; flonum ops -[flabs flabs-type] -[fl+ fl+-type] -[fl- fl--type] -[fl* fl*-type] -[fl/ fl/-type] -[fl= fl=-type] -[fl<= fl<=-type] -[fl>= fl>=-type] -[fl> fl>-type] -[fl< fl<-type] -[flmin flmin-type] -[flmax flmax-type] -[flround flround-type] -[flfloor flfloor-type] -[flceiling flceiling-type] -[fltruncate flround-type] -[flsin fl-unop] ; special cases (0s) not worth special-casing -[flcos fl-unop] -[fltan fl-unop] -[flatan fl-unop] -[flasin fl-unop] -[flacos fl-unop] -[fllog fllog-type] -[flexp flexp-type] -[flsqrt flsqrt-type] -[->fl fx->fl-type] -[make-flrectangular make-flrectangular-type] -[flreal-part flreal-part-type] -[flimag-part flimag-part-type] +[flabs (flabs-type)] +[fl+ (fl+-type)] +[fl- (fl--type)] +[fl* (fl*-type)] +[fl/ (fl/-type)] +[fl= (fl=-type)] +[fl<= (fl<=-type)] +[fl>= (fl>=-type)] +[fl> (fl>-type)] +[fl< (fl<-type)] +[flmin (flmin-type)] +[flmax (flmax-type)] +[flround (flround-type)] +[flfloor (flfloor-type)] +[flceiling (flceiling-type)] +[fltruncate (flround-type)] +[flsin (fl-unop)] ; special cases (0s) not worth special-casing +[flcos (fl-unop)] +[fltan (fl-unop)] +[flatan (fl-unop)] +[flasin (fl-unop)] +[flacos (fl-unop)] +[fllog (fllog-type)] +[flexp (flexp-type)] +[flsqrt (flsqrt-type)] +[->fl (fx->fl-type)] +[make-flrectangular (make-flrectangular-type)] +[flreal-part (flreal-part-type)] +[flimag-part (flimag-part-type)] -[unsafe-flabs flabs-type] -[unsafe-fl+ fl+-type] -[unsafe-fl- fl--type] -[unsafe-fl* fl*-type] -[unsafe-fl/ fl/-type] -[unsafe-fl= fl=-type] -[unsafe-fl<= fl<=-type] -[unsafe-fl>= fl>=-type] -[unsafe-fl> fl>-type] -[unsafe-fl< fl<-type] -[unsafe-flmin flmin-type] -[unsafe-flmax flmax-type] +[unsafe-flabs (flabs-type)] +[unsafe-fl+ (fl+-type)] +[unsafe-fl- (fl--type)] +[unsafe-fl* (fl*-type)] +[unsafe-fl/ (fl/-type)] +[unsafe-fl= (fl=-type)] +[unsafe-fl<= (fl<=-type)] +[unsafe-fl>= (fl>=-type)] +[unsafe-fl> (fl>-type)] +[unsafe-fl< (fl<-type)] +[unsafe-flmin (flmin-type)] +[unsafe-flmax (flmax-type)] ;These are currently the same binding as the safe versions ;and so are not needed. If this changes they should be ;uncommented. There is a check in the definitions part of ;the file that makes sure that they are the same binding. ; -;[unsafe-flround flround-type] -;[unsafe-flfloor flfloor-type] -;[unsafe-flceiling flceiling-type] -;[unsafe-fltruncate flround-type] -;[unsafe-flsin fl-unop] -;[unsafe-flcos fl-unop] -;[unsafe-fltan fl-unop] -;[unsafe-flatan fl-unop] -;[unsafe-flasin fl-unop] -;[unsafe-flacos fl-unop] -;[unsafe-fllog fllog-type] -;[unsafe-flexp flexp-type] +;[unsafe-flround (flround-type)] +;[unsafe-flfloor (flfloor-type)] +;[unsafe-flceiling (flceiling-type)] +;[unsafe-fltruncate (flround-type)] +;[unsafe-flsin (fl-unop)] +;[unsafe-flcos (fl-unop)] +;[unsafe-fltan (fl-unop)] +;[unsafe-flatan (fl-unop)] +;[unsafe-flasin (fl-unop)] +;[unsafe-flacos (fl-unop)] +;[unsafe-fllog (fllog-type)] +;[unsafe-flexp (flexp-type)] ; -[unsafe-flsqrt flsqrt-type] -[unsafe-fx->fl fx->fl-type] -[unsafe-make-flrectangular make-flrectangular-type] -[unsafe-flreal-part flreal-part-type] -[unsafe-flimag-part flimag-part-type] +[unsafe-flsqrt (flsqrt-type)] +[unsafe-fx->fl (fx->fl-type)] +[unsafe-make-flrectangular (make-flrectangular-type)] +[unsafe-flreal-part (flreal-part-type)] +[unsafe-flimag-part (flimag-part-type)] From e0f4ec56c46109e0c4051c299925f84c3df67f84 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 30 Aug 2011 15:55:15 -0400 Subject: [PATCH 028/235] Turn off TR timing. --- collects/typed-scheme/utils/utils.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-scheme/utils/utils.rkt b/collects/typed-scheme/utils/utils.rkt index 2cbccf325e..5c3f2fc64a 100644 --- a/collects/typed-scheme/utils/utils.rkt +++ b/collects/typed-scheme/utils/utils.rkt @@ -104,7 +104,7 @@ at least theoretically. #'(void))) ;; some macros to do some timing, only when `timing?' is #t -(define-for-syntax timing? #t) +(define-for-syntax timing? #f) (define last-time #f) (define initial-time #f) (define (set!-initial-time t) (set! initial-time t)) From 0510bb09490c7c04ee86905f905fdcd209293832 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 30 Aug 2011 16:43:24 -0400 Subject: [PATCH 029/235] Have drdr run the missed opts tests. --- collects/tests/typed-scheme/run.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/tests/typed-scheme/run.rkt b/collects/tests/typed-scheme/run.rkt index d014a95eb6..a8a7880e23 100644 --- a/collects/tests/typed-scheme/run.rkt +++ b/collects/tests/typed-scheme/run.rkt @@ -20,7 +20,7 @@ ["--missed-opt" "run the missed optimization tests" (missed-opt? #t)] ["--benchmarks" "compile the typed benchmarks" (bench? #t)] ["--just" path "run only this test" (single (just-one path))] - ["--nightly" "for the nightly builds" (begin (nightly? #t) (unit? #t) (opt? #t))] + ["--nightly" "for the nightly builds" (begin (nightly? #t) (unit? #t) (opt? #t) (missed-opt? #t))] ["--all" "run all tests" (begin (unit? #t) (int? #t) (opt? #t) (missed-opt? #t) (bench? #t))] ["--gui" "run using the gui" (if (gui-available?) From c11b7b3c9a939f8a3aa2ef38616dfd94b5525671 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 30 Aug 2011 15:31:47 -0500 Subject: [PATCH 030/235] double the planet tests timeout (again) --- collects/meta/props | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/meta/props b/collects/meta/props index 1479813b47..a47747ed78 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1566,7 +1566,7 @@ path/s is either such a string or a list of them. "collects/tests/planet/examples/dummy-module.rkt" drdr:command-line #f "collects/tests/planet/examples/scribblings-package" drdr:command-line #f "collects/tests/planet/lang.rkt" drdr:command-line (raco "make" *) -"collects/tests/planet/run-all.rkt" drdr:command-line (racket *) drdr:timeout 4000 +"collects/tests/planet/run-all.rkt" drdr:command-line (racket *) drdr:timeout 8000 "collects/tests/planet/test-docs-complete.rkt" drdr:command-line (raco "make" *) "collects/tests/planet/thread-safe-resolver.rkt" drdr:command-line (raco "make" *) drdr:timeout 1000 "collects/tests/planet/version.rkt" drdr:command-line (raco "make" *) From ce0da835ce0fa2c6295bf9c39565f6dbe77216cd Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 30 Aug 2011 16:09:36 -0500 Subject: [PATCH 031/235] adjust the 'recently opened files' menu item so its contents are contain fewer redundant entries amusingly I was reminded to do this by Matthew's recent commit message saying that normal-case-path is usually a bad idea --- collects/framework/private/handler.rkt | 57 +++++++++++++++----------- 1 file changed, 32 insertions(+), 25 deletions(-) diff --git a/collects/framework/private/handler.rkt b/collects/framework/private/handler.rkt index 3c06dfa589..8f49494b4c 100644 --- a/collects/framework/private/handler.rkt +++ b/collects/framework/private/handler.rkt @@ -120,25 +120,29 @@ ;; add-to-recent : path -> void (define (add-to-recent filename) - (let* ([old-list (preferences:get 'framework:recently-opened-files/pos)] - [old-ents (filter (λ (x) (string=? (path->string (car x)) - (path->string filename))) - old-list)] - [old-ent (if (null? old-ents) - #f - (car old-ents))] - [new-ent (list filename - (if old-ent (cadr old-ent) 0) - (if old-ent (caddr old-ent) 0))] - [added-in (cons new-ent - (remove new-ent old-list compare-recent-list-items))] - [new-recent (size-down added-in - (preferences:get 'framework:recent-max-count))]) - (preferences:set 'framework:recently-opened-files/pos new-recent))) + + (define old-list (preferences:get 'framework:recently-opened-files/pos)) + (define old-ents (filter (λ (x) (recently-opened-files-same-enough-path? (car x) filename)) + old-list)) + (define new-ent (if (null? old-ents) + (list filename 0 0) + (cons filename (cdr (car old-ents))))) + (define added-in (cons new-ent + (remove* (list new-ent) + old-list + (λ (l1 l2) + (recently-opened-files-same-enough-path? (car l1) (car l2)))))) + (define new-recent (size-down added-in + (preferences:get 'framework:recent-max-count))) + (preferences:set 'framework:recently-opened-files/pos new-recent)) + +;; same-enough-path? : path path -> boolean +;; used to determine if the open-recent-files menu item considers two paths to be the same +(define (recently-opened-files-same-enough-path? p1 p2) + (equal? (simplify-path (normal-case-path p1) #f) + (simplify-path (normal-case-path p2) #f))) + -;; compare-recent-list-items : recent-list-item recent-list-item -> boolean -(define (compare-recent-list-items l1 l2) - (equal? (car l1) (car l2))) ;; size-down : (listof X) -> (listof X)[< recent-max-count] ;; takes a list of stuff and returns the @@ -167,8 +171,8 @@ (preferences:get 'framework:recently-opened-files/pos)] [new-recent-items (map (λ (x) - (if (string=? (path->string (car x)) - (path->string filename)) + (if (recently-opened-files-same-enough-path? (path->string (car x)) + (path->string filename)) (list* (car x) start end (cdddr x)) x)) (preferences:get 'framework:recently-opened-files/pos))]) @@ -198,9 +202,8 @@ (define (recent-list-item->menu-label recent-list-item) (let ([filename (car recent-list-item)]) - (gui-utils:trim-string - (regexp-replace* #rx"&" (path->string filename) "\\&\\&") - 200))) + (gui-utils:quote-literal-label + (path->string filename)))) ;; this function must mimic what happens in install-recent-items ;; it returns #t if all of the labels of menus are the same, or approximation to @@ -232,8 +235,12 @@ (send ed set-position start end)))))] [else (preferences:set 'framework:recently-opened-files/pos - (remove recent-list-item - (preferences:get 'framework:recently-opened-files/pos))) + (remove* (list recent-list-item) + (preferences:get 'framework:recently-opened-files/pos) + (λ (l1 l2) + (recently-opened-files-same-enough-path? + (car l1) + (car l2))))) (message-box (string-constant error) (format (string-constant cannot-open-because-dne) filename))]))) From c5155b6b75842c5f362150396859b5538e970609 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Tue, 30 Aug 2011 16:38:25 -0400 Subject: [PATCH 032/235] basic fixes to figure.tex; partially addresses PR 12140 --- collects/scriblib/figure.tex | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/collects/scriblib/figure.tex b/collects/scriblib/figure.tex index 17feceaa8a..ac29788584 100644 --- a/collects/scriblib/figure.tex +++ b/collects/scriblib/figure.tex @@ -9,12 +9,16 @@ \newlength{\FigOrigskip} \FigOrigskip=\parskip -\newenvironment{CenterfigureMulti}{\begin{figure*}[t!p]\centering}{\end{figure*}} +\newenvironment{Figure}{\begin{figure}}{\end{figure}} + +\newenvironment{CenterfigureMulti}{\begin{center}}{\end{center}} \newenvironment{CenterfigureMultiWide}{\begin{CenterfigureMulti}}{\end{CenterfigureMulti}} -\newenvironment{Centerfigure}{\begin{figure}[t!p]\centering}{\end{figure}} -\newenvironment{Herefigure}{\begin{figure}[ht!p]\centering}{\end{figure}} +\newenvironment{Centerfigure}{\begin{center}}{\end{center}} +\newenvironment{Herefigure}{\begin{center}}{\end{center}} \newenvironment{FigureInside}{\begin{list}{}{\leftmargin=0pt\topsep=0pt\parsep=\FigOrigskip\partopsep=0pt}\item}{\end{list}} -\newenvironment{LeftfigureMulti}{\begin{figure*}[t!p]}{\end{figure*}} +\newenvironment{LeftfigureMulti}{\begin{center}[t!p]}{\end{center}} \newenvironment{LeftfigureMultiWide}{\begin{leftfigureMulti}}{\end{leftfigureMulti}} -\newenvironment{Leftfigure}{\begin{figure}[t!p]}{\end{figure}} +\newenvironment{Leftfigure}{\begin{flushleft}}{\end{flushleft}} + +\def\Centertext#1{\def\Centertext#1{\begin{center}#1\end{center}}} From e4039661d4f814587a1d35a478b1c64e51c0a424 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Tue, 30 Aug 2011 17:13:58 -0400 Subject: [PATCH 033/235] Closes PR12140 --- collects/scriblib/figure.rkt | 37 ++++++++++++------------------------ collects/scriblib/figure.tex | 14 +++++++------- 2 files changed, 19 insertions(+), 32 deletions(-) diff --git a/collects/scriblib/figure.rkt b/collects/scriblib/figure.rkt index a30dd1c4df..ab81d7d463 100644 --- a/collects/scriblib/figure.rkt +++ b/collects/scriblib/figure.rkt @@ -42,27 +42,17 @@ (define leftfiguremultiwide-style (make-style "LeftfigureMultiWide" figure-style-extras)) (define (figure tag caption #:style [style centerfigure-style] . content) - (apply figure-helper style tag caption content)) + (apply figure-helper figure-style style tag caption content)) + (define (figure-here tag caption . content) - (apply figure-helper herefigure-style tag caption content)) -(define (figure-helper style tag caption . content) + (apply figure-helper herefigure-style centerfigure-style tag caption content)) + +(define (figure-helper figure-style content-style tag caption . content) (make-nested-flow figure-style (list - (make-nested-flow - style - (list - (make-nested-flow - figureinside-style - (append - (decode-flow content) - (list))))) - (make-paragraph - centertext-style - (list - (make-element legend-style - (list (Figure-target tag) ": " - caption))))))) + (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))))))) (define (*figure style tag caption content) (make-nested-flow @@ -75,15 +65,12 @@ (list (make-paragraph plain - (list - (make-element legend-style - (list (Figure-target tag) ": " - caption)))))))))) + (list (make-element legend-style (list (Figure-target tag) ": " caption)))))))))) -(define (figure* tag caption #:style [style centerfiguremulti-style] . content) - (*figure style tag caption content)) -(define (figure** tag caption #:style [style centerfiguremultiwide-style] . content) - (*figure style tag caption content)) +(define (figure* tag caption . content) + (*figure centerfiguremulti-style tag caption content)) +(define (figure** tag caption . content) + (*figure centerfiguremultiwide-style tag caption content)) (define figures (new-counter "figure")) (define (Figure-target tag) diff --git a/collects/scriblib/figure.tex b/collects/scriblib/figure.tex index ac29788584..54a393c56a 100644 --- a/collects/scriblib/figure.tex +++ b/collects/scriblib/figure.tex @@ -11,14 +11,14 @@ \newenvironment{Figure}{\begin{figure}}{\end{figure}} -\newenvironment{CenterfigureMulti}{\begin{center}}{\end{center}} -\newenvironment{CenterfigureMultiWide}{\begin{CenterfigureMulti}}{\end{CenterfigureMulti}} \newenvironment{Centerfigure}{\begin{center}}{\end{center}} -\newenvironment{Herefigure}{\begin{center}}{\end{center}} -\newenvironment{FigureInside}{\begin{list}{}{\leftmargin=0pt\topsep=0pt\parsep=\FigOrigskip\partopsep=0pt}\item}{\end{list}} +\def\Centertext#1{\begin{center}#1\end{center}} -\newenvironment{LeftfigureMulti}{\begin{center}[t!p]}{\end{center}} -\newenvironment{LeftfigureMultiWide}{\begin{leftfigureMulti}}{\end{leftfigureMulti}} \newenvironment{Leftfigure}{\begin{flushleft}}{\end{flushleft}} -\def\Centertext#1{\def\Centertext#1{\begin{center}#1\end{center}}} +\newenvironment{CenterfigureMulti}{\begin{figure*}[t!p]\centering}{\end{figure*}} +\newenvironment{CenterfigureMultiWide}{\begin{CenterfigureMulti}}{\end{CenterfigureMulti}} + +\newenvironment{Herefigure}{\begin{figure}[ht!p]\centering}{\end{figure}} + +\newenvironment{FigureInside}{\begin{list}{}{\leftmargin=0pt\topsep=0pt\parsep=\FigOrigskip\partopsep=0pt}\item}{\end{list}} From c414b09ecfb424fcc4e0c4d80d9cf5197ea297c9 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 30 Aug 2011 17:54:02 -0400 Subject: [PATCH 034/235] Dynamic-require the optimizer. --- collects/typed-scheme/tc-setup.rkt | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/collects/typed-scheme/tc-setup.rkt b/collects/typed-scheme/tc-setup.rkt index 1e051e8920..2fb9dbf4c2 100644 --- a/collects/typed-scheme/tc-setup.rkt +++ b/collects/typed-scheme/tc-setup.rkt @@ -4,7 +4,6 @@ (except-in syntax/parse id) unstable/mutated-vars racket/pretty - (optimizer optimizer) (private type-contract) (types utils convenience) (typecheck typechecker provide-handling tc-toplevel) @@ -27,8 +26,12 @@ (define (maybe-optimize body) ;; do we optimize? (if (optimize?) - (begin0 (map optimize-top (syntax->list body)) - (do-time "Optimized")) + (let ([optimize-top + (begin0 (dynamic-require 'typed-scheme/optimizer/optimizer + 'optimize-top) + (do-time "Loading optimizer"))]) + (begin0 (map optimize-top (syntax->list body)) + (do-time "Optimized"))) body)) (define-syntax-rule (tc-setup orig-stx stx expand-ctxt fully-expanded-stx checker result . body) From 4d8833eab2ae4bed5580336905db3b3b803c3580 Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Tue, 30 Aug 2011 15:36:26 -0600 Subject: [PATCH 035/235] abandon unused scheme_socket_to_ports during place copy --- collects/tests/racket/place-channel-fd2.rkt | 66 +++++++++++++++++++ .../tests/racket/place-channel-socket.rkt | 58 ++++++++++++++++ src/racket/src/network.c | 4 ++ src/racket/src/place.c | 9 ++- src/racket/src/schpriv.h | 1 + 5 files changed, 137 insertions(+), 1 deletion(-) create mode 100644 collects/tests/racket/place-channel-fd2.rkt create mode 100644 collects/tests/racket/place-channel-socket.rkt diff --git a/collects/tests/racket/place-channel-fd2.rkt b/collects/tests/racket/place-channel-fd2.rkt new file mode 100644 index 0000000000..eed8fcbdf3 --- /dev/null +++ b/collects/tests/racket/place-channel-fd2.rkt @@ -0,0 +1,66 @@ +#lang racket/base +(require racket/match + racket/place + rackunit) + +(define (racket-subprocess o i e . args) + (define (current-executable-path) + (parameterize ([current-directory (find-system-path 'orig-dir)]) + (find-executable-path (find-system-path 'exec-file) #f))) + + (apply subprocess o i e (current-executable-path) args)) + +(provide main) +(define (main) + (test-case + "test file descriptors copied across place channesl" +;; write out "fdt.rkt" + (with-output-to-file "fdt.rkt" #:exists 'replace (lambda () + (display +#<u.two_int_val.int1; int fd = ((Scheme_Simple_Object *) so)->u.two_int_val.int2; scheme_socket_to_ports(fd, "", 1, &in, &out); - new_so = (type == scheme_input_port_type) ? in : out; + if (type == scheme_input_port_type) { + scheme_tcp_abandon_port(out); + new_so = in; + } + else { + scheme_tcp_abandon_port(in); + new_so = out; + } } break; case scheme_serialized_file_fd_type: diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index d01acc9e3b..593a36af11 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -3697,6 +3697,7 @@ intptr_t scheme_dup_socket(intptr_t fd); intptr_t scheme_dup_file(intptr_t fd); void scheme_close_socket_fd(intptr_t fd); void scheme_close_file_fd(intptr_t fd); +void scheme_tcp_abandon_port(Scheme_Object *port); #define SCHEME_PLACE_OBJECTP(o) (SCHEME_TYPE(o) == scheme_place_object_type) From b110671c5cb691fae4b60872d0cc63f285c6eafa Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Tue, 30 Aug 2011 15:54:14 -0600 Subject: [PATCH 036/235] Comment out broken place check --- collects/racket/place.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/racket/place.rkt b/collects/racket/place.rkt index d1e9261c0d..ff450f8bf4 100644 --- a/collects/racket/place.rkt +++ b/collects/racket/place.rkt @@ -147,7 +147,8 @@ (syntax-case stx () [(_ ch body1 body ...) (begin - (unless (eq? 'module (syntax-local-context)) + ;breaks valid uses of place + #;(unless (eq? 'module (syntax-local-context)) (raise-syntax-error #f "can only be used in a module" stx)) (unless (identifier? #'ch) (raise-syntax-error #f "expected an indentifier" stx #'ch)) From 6c75b60d1b86c93f73bd0f00f9e532c155df20e2 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Tue, 23 Aug 2011 23:43:23 -0600 Subject: [PATCH 037/235] [honu] add assignment operator --- collects/honu/core/private/honu2.rkt | 7 +++++++ collects/honu/core/read.rkt | 2 +- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/collects/honu/core/private/honu2.rkt b/collects/honu/core/private/honu2.rkt index d065506d3d..c7e4d0f7d9 100644 --- a/collects/honu/core/private/honu2.rkt +++ b/collects/honu/core/private/honu2.rkt @@ -136,6 +136,13 @@ [right right]) #'(right left)))) +(provide honu-assignment) +(define-honu-operator/syntax honu-assignment 0.0001 'left + (lambda (left right) + (with-syntax ([left left] + [right right]) + #'(set! left right)))) + (define-binary-operator honu-+ 1 'left +) (define-binary-operator honu-- 1 'left -) (define-binary-operator honu-* 2 'left *) diff --git a/collects/honu/core/read.rkt b/collects/honu/core/read.rkt index 846b1dfa33..cdc4318760 100644 --- a/collects/honu/core/read.rkt +++ b/collects/honu/core/read.rkt @@ -34,7 +34,7 @@ (:~ #\"))) (define-lex-abbrev string (:: #\" (:* string-character) #\")) (define-lex-abbrev operator (:or "+" "=" "*" "/" "-" "^" "||" "|" "&&" "<=" - ">=" "<-" "<" ">" "!" "::")) + ">=" "<-" "<" ">" "!" "::" ":=")) (define-lex-abbrev block-comment (:: "/*" (complement (:: any-string "*/" any-string)) "*/")) From d88b75a9b7374f6f6ffd22f38fab08658ede6b78 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Tue, 30 Aug 2011 14:26:38 -0600 Subject: [PATCH 038/235] [honu] macros can be defined with honu syntax --- collects/honu/core/main.rkt | 6 +++ .../honu/core/private/honu-typed-scheme.rkt | 11 +++-- collects/honu/core/private/macro2.rkt | 47 ++++++++++++++----- collects/honu/core/private/parse2.rkt | 4 ++ 4 files changed, 52 insertions(+), 16 deletions(-) diff --git a/collects/honu/core/main.rkt b/collects/honu/core/main.rkt index 74c6f94f58..625f4a7a92 100644 --- a/collects/honu/core/main.rkt +++ b/collects/honu/core/main.rkt @@ -2,13 +2,18 @@ (require "private/honu-typed-scheme.rkt" "private/honu2.rkt" + "private/macro2.rkt" + (for-syntax (only-in "private/parse2.rkt" honu-expression)) (prefix-in literal: "private/literals.rkt")) (provide #%top #%datum print printf true false + (for-syntax (rename-out [honu-expression expression])) (rename-out [#%dynamic-honu-module-begin #%module-begin] [honu-function function] + [honu-macro macro] + [honu-syntax syntax] [honu-var var] [honu-val val] [honu-for for] @@ -21,6 +26,7 @@ [honu-> >] [honu-< <] [honu->= >=] [honu-<= <=] [honu-= =] + [honu-assignment :=] [literal:honu-<- <-] [honu-map map] [honu-flow \|] diff --git a/collects/honu/core/private/honu-typed-scheme.rkt b/collects/honu/core/private/honu-typed-scheme.rkt index 8113b5e43d..8e4b1fcb98 100644 --- a/collects/honu/core/private/honu-typed-scheme.rkt +++ b/collects/honu/core/private/honu-typed-scheme.rkt @@ -445,21 +445,22 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt #'rest)]))) (define-for-syntax (honu-expand forms) - (parse-all forms)) + (parse-one forms)) (define-for-syntax (honu-compile forms) #'(void)) - (define-syntax (honu-unparsed-begin stx) (emit-remark "Honu unparsed begin!" stx) (debug "honu unparsed begin: ~a at phase ~a\n" (syntax->datum stx) (syntax-local-phase-level)) (syntax-parse stx [(_) #'(void)] [(_ forms ...) - (define expanded (honu-expand #'(forms ...))) - (debug "expanded ~a\n" (syntax->datum expanded)) - expanded])) + (define-values (parsed unparsed) (honu-expand #'(forms ...))) + (debug "expanded ~a\n" (syntax->datum parsed)) + (with-syntax ([parsed parsed] + [(unparsed ...) unparsed]) + #'(begin parsed (honu-unparsed-begin unparsed ...)))])) (define-syntax (#%dynamic-honu-module-begin stx) (syntax-case stx () diff --git a/collects/honu/core/private/macro2.rkt b/collects/honu/core/private/macro2.rkt index 72d3edf7c6..60a799978a 100644 --- a/collects/honu/core/private/macro2.rkt +++ b/collects/honu/core/private/macro2.rkt @@ -3,6 +3,7 @@ (require (for-syntax "transformer.rkt" syntax/define syntax/parse + syntax/stx "literals.rkt" "parse2.rkt" "debug.rkt" @@ -17,30 +18,39 @@ (syntax/loc stx (define-syntax id (make-honu-transformer rhs)))))) -(define-for-syntax (convert-pattern pattern) - (syntax-parse pattern - [(name semicolon class) - #'(~var name class)])) +(define-for-syntax (convert-pattern original-pattern) + (define-splicing-syntax-class pattern-type + #:literal-sets (cruft) + [pattern (~seq name colon class) + #:with result #'(~var name class #:attr-name-separator "_")] + [pattern x #:with result #'x]) + (syntax-parse original-pattern + [(thing:pattern-type ...) + #'(thing.result ...)])) -(provide macro) -(define-honu-syntax macro +(provide honu-macro) +(define-honu-syntax honu-macro (lambda (code context) (debug "Macroize ~a\n" code) (syntax-parse code #:literal-sets (cruft) [(_ name literals (#%braces pattern ...) (#%braces action ...) . rest) (debug "Pattern is ~a\n" #'(pattern ...)) (values - (with-syntax ([syntax-parse-pattern + (with-syntax ([(syntax-parse-pattern ...) (convert-pattern #'(pattern ...))]) #'(define-honu-syntax name (lambda (stx context-name) (syntax-parse stx - [(_ syntax-parse-pattern . more) + [(_ syntax-parse-pattern ... . more) (values #'(let-syntax ([do-parse (lambda (stx) - (parse-all stx))]) + (define what (parse-all (stx-cdr stx))) + (debug "Macro parse all ~a\n" what) + what)]) (do-parse action ...)) - #'more)])))) - #'rest)]))) + #'more + #t)])))) + #'rest + #t)]))) (provide (rename-out [honu-with-syntax withSyntax])) (define-honu-syntax honu-with-syntax @@ -49,3 +59,18 @@ [(_ [#%brackets name:id data] (#%braces code ...)) #'(with-syntax ([name data]) code ...)]))) + +(define-syntax (parse-stuff stx) + (syntax-parse stx + [(_ stuff ...) + (parse-all #'(stuff ...))])) + +(provide honu-syntax) +(define-honu-syntax honu-syntax + (lambda (code context) + (syntax-parse code #:literal-sets (cruft) + [(_ (#%parens stuff ...) . rest) + (values + #'(parse-stuff stuff ...) + #'rest + #f)]))) diff --git a/collects/honu/core/private/parse2.rkt b/collects/honu/core/private/parse2.rkt index 142f60586b..4ac102cc19 100644 --- a/collects/honu/core/private/parse2.rkt +++ b/collects/honu/core/private/parse2.rkt @@ -290,6 +290,10 @@ [() #t] [else #f])) +(provide parse-one) +(define (parse-one code) + (parse (strip-stops code))) + (define (parse-all code) (let loop ([all '()] [code code]) From 6af36bc25d3e4494fab5c350876359e456a9e172 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Tue, 30 Aug 2011 17:17:31 -0600 Subject: [PATCH 039/235] [honu] treat #\return like #\newline --- collects/honu/core/read.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/honu/core/read.rkt b/collects/honu/core/read.rkt index cdc4318760..c0caa43a23 100644 --- a/collects/honu/core/read.rkt +++ b/collects/honu/core/read.rkt @@ -42,7 +42,7 @@ (define-lex-abbrev line-comment (:: (:or "#" "//") (:* (:~ "\n")) ;; we might hit eof before a \n - (:? "\n"))) + (:? "\n" "\r"))) (define (replace-escapes string) (define replacements '([#px"\\\\n" "\n"] @@ -60,7 +60,7 @@ #; [line-comment (token-whitespace)] [(:or "#" "//") (token-end-of-line-comment)] - ["\n" (token-whitespace)] + [(:? "\n" "\r") (token-whitespace)] [number (token-number (string->number lexeme))] #; [block-comment (token-whitespace)] From 5dab69cf4bf4179aef3acc7465664b5ed4097df6 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Tue, 30 Aug 2011 17:18:58 -0600 Subject: [PATCH 040/235] [honu] new macro test --- collects/tests/honu/macros.rkt | 60 ++-------------------------------- 1 file changed, 2 insertions(+), 58 deletions(-) diff --git a/collects/tests/honu/macros.rkt b/collects/tests/honu/macros.rkt index 4a4646769f..f21c32b7e5 100644 --- a/collects/tests/honu/macros.rkt +++ b/collects/tests/honu/macros.rkt @@ -1,61 +1,5 @@ #lang honu -// display(1); +macro testx () {x:expression} {syntax(x_result + 1)} -/* -=> - -x = function(q){ - print q; - if (q < end){ - x(q+1); - } -} -x(start); -*/ - -/* - -// display(syntax ...); - -macro (to2){{fuz - x ... to2 - }} -{{ - display(x); - ... - }} - -fuz 5 6 to2 - -// macro (to = do end) {{ for looper:id = first:expr to last:expr do - - /* -macro (to = do end) {{ for looper = first to last do - body ... -}} -{{ - /* display(2); */ - var x = function(looper){ - body ... - if (looper < last){ - x(looper+1); - } - }; - x(first); -}} - - -/* -for2 x = 1 to 10 do - display(x); - newline(); -end -*/ - -for x = 1 to 10 do - display(x); - newline(); - - */ -*/ +testx 5 * 2; From 050d0c0fe0a09c3a11cc97294c6c6b97bd42504f Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 30 Aug 2011 20:40:58 -0500 Subject: [PATCH 041/235] fix scribble pdf button closes PR 12141 --- collects/scribble/tools/drracket-buttons.rkt | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/collects/scribble/tools/drracket-buttons.rkt b/collects/scribble/tools/drracket-buttons.rkt index 95fbdb558f..9a91d24490 100644 --- a/collects/scribble/tools/drracket-buttons.rkt +++ b/collects/scribble/tools/drracket-buttons.rkt @@ -25,6 +25,7 @@ bmp (λ (drs-frame) (define fn (send (send drs-frame get-definitions-text) get-filename)) + (define html? (equal? suffix #".html")) (cond [fn (parameterize ([drracket:rep:after-expression @@ -32,15 +33,21 @@ (printf "scribble: loading xref\n") (define xref ((dynamic-require 'setup/xref 'load-collections-xref))) (printf "scribble: rendering\n") - ((dynamic-require 'scribble/render 'render) - (list (eval 'doc)) - (list fn) - #:xrefs (list xref)) + (parameterize ([current-input-port (open-input-string "")]) + ((dynamic-require 'scribble/render 'render) + (list (eval 'doc)) + (list fn) + #:render-mixin (dynamic-require (if html? + 'scribble/html-render + 'scribble/pdf-render) + 'render-mixin) + #:xrefs (list xref))) (cond - [(equal? suffix #".html") + [html? (send-url/file (path-replace-suffix fn suffix))] [else - (system (format "open ~s" (path->string (path-replace-suffix fn suffix))))]))]) + (parameterize ([current-input-port (open-input-string "")]) + (system (format "open \"~a\"" (path->string (path-replace-suffix fn suffix)))))]))]) (send drs-frame execute-callback))] [else (message-box "Scribble" "Cannot render buffer without filename")])))) From 5f0a221a039b4e00e4c9714ff24f07f4ad38e550 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Tue, 30 Aug 2011 18:31:55 -0600 Subject: [PATCH 042/235] [honu] allow already parsed expression to pass through --- collects/honu/core/private/parse2.rkt | 14 +++++++++++++- collects/honu/core/private/util.rkt | 1 - collects/tests/honu/macros.rkt | 3 +++ 3 files changed, 16 insertions(+), 2 deletions(-) diff --git a/collects/honu/core/private/parse2.rkt b/collects/honu/core/private/parse2.rkt index 4ac102cc19..e0ca3c8d98 100644 --- a/collects/honu/core/private/parse2.rkt +++ b/collects/honu/core/private/parse2.rkt @@ -120,6 +120,13 @@ (loop (cons parsed used) unparsed)))))) +(define parsed-property (gensym 'honu-parsed)) +(define (parsed-syntax syntax) + (syntax-property syntax parsed-property #t)) + +(define (parsed-syntax? syntax) + (syntax-property syntax parsed-property)) + (define (stopper? what) (define-literal-set check (honu-comma semicolon colon)) (define is (and (identifier? what) @@ -178,6 +185,8 @@ #'rest) (do-parse #'rest precedence left #'parsed)))))] + [(parsed-syntax? #'head) + (do-parse #'(rest ...) precedence left #'head)] [(honu-operator? #'head) (define new-precedence (transformer:honu-operator-ref (syntax-local-value #'head) 0)) (define association (transformer:honu-operator-ref (syntax-local-value #'head) 1)) @@ -283,7 +292,10 @@ (error 'parse "function call")] [else (error 'what "dont know how to parse ~a" #'head)])])])])) - (do-parse input 0 (lambda (x) x) #f)) + (define-values (parsed unparsed) + (do-parse input 0 (lambda (x) x) #f)) + (values (parsed-syntax parsed) + unparsed)) (define (empty-syntax? what) (syntax-parse what diff --git a/collects/honu/core/private/util.rkt b/collects/honu/core/private/util.rkt index d6e45b9e05..c26b441106 100644 --- a/collects/honu/core/private/util.rkt +++ b/collects/honu/core/private/util.rkt @@ -2,7 +2,6 @@ (provide (except-out (all-defined-out) test-delimiter)) (require "debug.rkt" - tests/eli-tester racket/match (for-syntax racket/base) syntax/stx diff --git a/collects/tests/honu/macros.rkt b/collects/tests/honu/macros.rkt index f21c32b7e5..cc9255503a 100644 --- a/collects/tests/honu/macros.rkt +++ b/collects/tests/honu/macros.rkt @@ -3,3 +3,6 @@ macro testx () {x:expression} {syntax(x_result + 1)} testx 5 * 2; + +for z = 1 to testx 5 * 2 do + printf("z is ~a\n", z) From 96663d4fa4d17c5f90091453e5ed2a496981384a Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Tue, 30 Aug 2011 17:41:19 -0600 Subject: [PATCH 043/235] db: added #:use-place arg for ffi-based connections SQLite and ODBC connections can use places to avoid blocking all Racket threads. --- collects/db/TODO | 7 - collects/db/main.rkt | 9 +- collects/db/odbc.rkt | 6 +- collects/db/private/generic/dsn.rkt | 10 +- collects/db/private/generic/place-client.rkt | 137 +++++++++++++++++ collects/db/private/generic/place-server.rkt | 147 +++++++++++++++++++ collects/db/private/generic/prepared.rkt | 8 +- collects/db/private/odbc/connection.rkt | 16 ++ collects/db/private/odbc/main.rkt | 76 ++++++---- collects/db/private/sqlite3/main.rkt | 72 +++++---- collects/db/scribblings/config.rkt | 3 + collects/db/scribblings/connect.scrbl | 36 ++++- collects/db/sqlite3.rkt | 3 +- collects/tests/db/all-tests.rkt | 18 ++- collects/tests/db/db/concurrent.rkt | 74 +++++----- collects/tests/db/db/query.rkt | 36 +++++ 16 files changed, 532 insertions(+), 126 deletions(-) create mode 100644 collects/db/private/generic/place-client.rkt create mode 100644 collects/db/private/generic/place-server.rkt diff --git a/collects/db/TODO b/collects/db/TODO index 80205d44af..8a91f306d1 100644 --- a/collects/db/TODO +++ b/collects/db/TODO @@ -67,13 +67,6 @@ Misc - how do people want to use cursors? - how about implicit support only in 'in-query'? -- ODBC: use async execution to avoid blocking all Racket threads - Status: Tried it. Oracle driver doesn't support async. PG, MY drivers don't support async. - DB2 driver does, but gives baffling HY010 function sequence errors, couldn't fix. - (Best theory so far: possible that DB2 requires polling args to be identical to original - call, which means (_ptr o X) args are the problem. Or maybe unixodbc's fault.) - Didn't try SQL Server. All in all, not worth it. - - add evt versions of functions - for query functions (?) - connection-pool-lease-evt diff --git a/collects/db/main.rkt b/collects/db/main.rkt index 0a1a61ca12..5d759ecc66 100644 --- a/collects/db/main.rkt +++ b/collects/db/main.rkt @@ -75,7 +75,8 @@ (->* (#:database (or/c path-string? 'memory 'temporary)) (#:mode (or/c 'read-only 'read/write 'create) #:busy-retry-limit (or/c exact-nonnegative-integer? +inf.0) - #:busy-retry-delay (and/c rational? (not/c negative?))) + #:busy-retry-delay (and/c rational? (not/c negative?)) + #:use-place boolean?) any/c)] ;; Duplicates contracts at odbc.rkt @@ -85,13 +86,15 @@ #:password (or/c string? #f) #:notice-handler (or/c 'output 'error output-port? procedure?) #:strict-parameter-types? boolean? - #:character-mode (or/c 'wchar 'utf-8 'latin-1)) + #:character-mode (or/c 'wchar 'utf-8 'latin-1) + #:use-place boolean?) connection?)] [odbc-driver-connect (->* (string?) (#:notice-handler (or/c 'output 'error output-port? procedure?) #:strict-parameter-types? boolean? - #:character-mode (or/c 'wchar 'utf-8 'latin-1)) + #:character-mode (or/c 'wchar 'utf-8 'latin-1) + #:use-place boolean?) connection?)] [odbc-data-sources (-> (listof (list/c string? string?)))] diff --git a/collects/db/odbc.rkt b/collects/db/odbc.rkt index 0e332f97a9..d1f752c962 100644 --- a/collects/db/odbc.rkt +++ b/collects/db/odbc.rkt @@ -11,13 +11,15 @@ #:password (or/c string? #f) #:notice-handler (or/c 'output 'error output-port? procedure?) #:strict-parameter-types? boolean? - #:character-mode (or/c 'wchar 'utf-8 'latin-1)) + #:character-mode (or/c 'wchar 'utf-8 'latin-1) + #:use-place boolean?) connection?)] [odbc-driver-connect (->* (string?) (#:notice-handler (or/c 'output 'error output-port? procedure?) #:strict-parameter-types? boolean? - #:character-mode (or/c 'wchar 'utf-8 'latin-1)) + #:character-mode (or/c 'wchar 'utf-8 'latin-1) + #:use-place boolean?) connection?)] [odbc-data-sources (-> (listof (list/c string? string?)))] diff --git a/collects/db/private/generic/dsn.rkt b/collects/db/private/generic/dsn.rkt index e2be89f92a..5455726a0d 100644 --- a/collects/db/private/generic/dsn.rkt +++ b/collects/db/private/generic/dsn.rkt @@ -189,12 +189,12 @@ considered important. (define sqlite3-data-source (mk-specialized 'sqlite3-data-source 'sqlite3 0 - '(#:database #:mode #:busy-retry-limit #:busy-retry-delay))) + '(#:database #:mode #:busy-retry-limit #:busy-retry-delay #:use-place))) (define odbc-data-source (mk-specialized 'odbc-data-source 'odbc 0 '(#:dsn #:user #:password #:notice-handler - #:strict-parameter-types? #:character-mode))) + #:strict-parameter-types? #:character-mode #:use-place))) (provide/contract [struct data-source @@ -235,7 +235,8 @@ considered important. (#:database (or/c string? 'memory 'temporary) #:mode (or/c 'read-only 'read/write 'create) #:busy-retry-limit (or/c exact-nonnegative-integer? +inf.0) - #:busy-retry-delay (and/c rational? (not/c negative?))) + #:busy-retry-delay (and/c rational? (not/c negative?)) + #:use-place boolean?) data-source?)] [odbc-data-source (->* () @@ -244,5 +245,6 @@ considered important. #:password string? #:notice-handler (or/c 'output 'error) #:strict-parameter-types? boolean? - #:character-mode (or/c 'wchar 'utf-8 'latin-1)) + #:character-mode (or/c 'wchar 'utf-8 'latin-1) + #:use-place boolean?) data-source?)]) diff --git a/collects/db/private/generic/place-client.rkt b/collects/db/private/generic/place-client.rkt new file mode 100644 index 0000000000..d22dd81472 --- /dev/null +++ b/collects/db/private/generic/place-client.rkt @@ -0,0 +1,137 @@ +#lang racket/base +(require racket/class + racket/match + racket/place + racket/promise + racket/vector + ffi/unsafe/atomic + "interfaces.rkt" + "prepared.rkt" + "sql-data.rkt") +(provide place-connect + place-proxy-connection% + + sql-datum->sexpr + sexpr->sql-datum) + +(define connection-server-channel + (delay/sync + (dynamic-place 'db/private/generic/place-server 'connection-server))) + +(define (place-connect connection-spec proxy%) + (let-values ([(channel other-channel) (place-channel)]) + (place-channel-put (force connection-server-channel) + (list 'connect other-channel connection-spec)) + (match (place-channel-get channel) + [(list 'ok) + (new proxy% (channel channel))] + [(list 'error message) + (raise (make-exn:fail message (current-continuation-marks)))]))) + +(define place-proxy-connection% + (class* locking% (connection<%>) + (init-field channel) + (inherit call-with-lock + call-with-lock*) + (super-new) + + (define/private (call method-name . args) + (call-with-lock method-name (lambda () (call* method-name args #t)))) + (define/private (call/d method-name . args) + (call-with-lock* method-name (lambda () (call* method-name args #f)) #f #f)) + (define/private (call* method-name args need-connected?) + (cond [channel + (place-channel-put channel (cons method-name args)) + (match (place-channel-get channel) + [(cons 'values vals) + (apply values (for/list ([val (in-list vals)]) (translate-result val)))] + [(list 'error message) + (raise (make-exn:fail message (current-continuation-marks)))])] + [need-connected? + (unless channel + (error/not-connected method-name))] + [else (void)])) + + (define/override (connected?) + ;; FIXME: can underlying connection disconnect w/o us knowing? + (and channel #t)) + + (define/public (disconnect) + (call/d 'disconnect) + (set! channel #f)) + + (define/public (get-dbsystem) (error 'get-dbsystem "not implemented")) + (define/public (get-base) this) + + (define/public (query fsym stmt) + (call 'query fsym + (match stmt + [(? string?) (list 'string stmt)] + [(statement-binding pst _meta params) + (list 'statement-binding + (send pst get-handle) + (map sql-datum->sexpr params))]))) + + (define/public (prepare fsym stmt close-on-exec?) + (call 'prepare fsym stmt close-on-exec?)) + + (define/public (free-statement pst) + (start-atomic) + (let ([handle (send pst get-handle)]) + (send pst set-handle #f) + (end-atomic) + (when channel + (call/d 'free-statement handle)))) + + (define/public (transaction-status fsym) + (call 'transaction-status fsym)) + + (define/public (start-transaction fsym iso) + (call 'start-transaction fsym iso)) + + (define/public (end-transaction fsym mode) + (call 'end-transaction fsym mode)) + + (define/public (list-tables fsym schema) + (call 'list-tables fsym schema)) + + (define/private (translate-result x) + (match x + [(list 'simple-result y) + (simple-result y)] + [(list 'rows-result h rows) + (let ([rows + (for/list ([row (in-list rows)]) + (vector-map sexpr->sql-datum row))]) + (rows-result h rows))] + [(list 'prepared-statement handle close-on-exec? param-typeids result-dvecs) + (new prepared-statement% + (handle handle) + (close-on-exec? close-on-exec?) + (param-typeids param-typeids) + (result-dvecs result-dvecs) + (owner this))] + [_ x])) + )) + +(define (sql-datum->sexpr x) + (match x + [(? sql-null?) + 'sql-null] + [(sql-date Y M D) + (list 'sql-date Y M D)] + [(sql-time h m s ns tz) + (list 'sql-time h m s ns tz)] + [(sql-timestamp Y M D h m s ns tz) + (list 'sql-timestamp Y M D h m s ns tz)] + ;; FIXME: add sql-interval when implemented for odbc + [_ x])) + +(define (sexpr->sql-datum x) + (match x + ['sql-null sql-null] + [(list 'sql-date Y M D) (sql-date Y M D)] + [(list 'sql-time h m s ns tz) (sql-time h m s ns tz)] + [(list 'sql-timestamp Y M D h m s ns tz) + (sql-timestamp Y M D h m s ns tz)] + [else x])) diff --git a/collects/db/private/generic/place-server.rkt b/collects/db/private/generic/place-server.rkt new file mode 100644 index 0000000000..dba93176d4 --- /dev/null +++ b/collects/db/private/generic/place-server.rkt @@ -0,0 +1,147 @@ +#lang racket/base +(require (for-syntax racket/base) + racket/class + racket/match + racket/place + "lazy-require.rkt" + "interfaces.rkt" + "prepared.rkt" + "sql-data.rkt" + "place-client.rkt") +(provide connection-server) + +#| +Connection creation protocol + +client -> server on client-chan: (list 'connect conn-chan ) +server -> client on conn-chan: (or (list 'ok) + (list 'error string)) + +where ::= (list 'sqlite3 path/sym mode-sym delay-num limit-num) + | (list 'odbc string string/#f string/#f boolean symbol) +|# +(define (connection-server client-chan) + (let loop () + (serve client-chan) + (loop))) + +(define-lazy-require-definer define-main "../../main.rkt") + +(define-main + sqlite3-connect + odbc-connect + odbc-driver-connect) + +(define (serve client-chan) + (match (place-channel-get client-chan) + [(list 'connect conn-chan connect-spec) + (with-handlers ([exn:fail? + (lambda (e) + (place-channel-put conn-chan + (list 'error (exn-message e))))]) + (let* ([c + (match connect-spec + [(list 'sqlite3 db mode busy-retry-delay busy-retry-limit) + (sqlite3-connect #:database db + #:mode mode + #:busy-retry-delay busy-retry-delay + #:busy-retry-limit busy-retry-limit + #:use-place #f)] + [(list 'odbc dsn user password strict-param? char-mode) + (odbc-connect #:dsn dsn + #:user user + #:password password + #:strict-parameter-types? strict-param? + #:character-mode char-mode + #:use-place #f)] + [(list 'odbc-driver connection-string strict-param? char-mode) + (odbc-driver-connect connection-string + #:strict-parameter-types? strict-param? + #:character-mode char-mode + #:use-place #f)])] + [p (new proxy-server% (connection c) (channel conn-chan))]) + (place-channel-put conn-chan (list 'ok)) + (thread (lambda () (send p serve)))))])) + +#| +Connection methods protocol + +client -> server: (list ' arg ...) +server -> client: (or (list 'values result ...) + (list 'error string)) +|# + +(define proxy-server% + (class object% + (init-field connection + channel) + (super-new) + + (define pstmt-table (make-hash)) ;; int => prepared-statement + (define pstmt-counter 0) + + (define/public (serve) + (serve1) + (when connection (serve))) + + (define/private (serve1) + (with-handlers ([exn? + (lambda (e) + (place-channel-put channel (list 'error (exn-message e))))]) + (call-with-values + (lambda () + (match (place-channel-get channel) + [(list 'disconnect) + (send connection disconnect) + (set! connection #f)] + [(list 'free-statement pstmt-index) + (send connection free-statement (hash-ref pstmt-table pstmt-index)) + (hash-remove! pstmt-table pstmt-index)] + [msg + (define-syntax-rule (forward-methods (method (arg translate) ...) ...) + (match msg + [(list 'method arg ...) + (send connection method (translate arg) ...)] + ...)) + (define-syntax-rule (id x) x) + (forward-methods (connected?) + (query (w id) (s translate-in-stmt)) + (prepare (w id) (s id) (m id)) + (list-tables (w id) (s id)) + (start-transaction (w id) (m id)) + (end-transaction (w id) (m id)) + (transaction-status (w id)))])) + (lambda results + (let ([results (for/list ([result (in-list results)]) (translate-result result))]) + (place-channel-put channel (cons 'values results))))))) + + (define/private (translate-in-stmt x) + (match x + [(list 'string s) + s] + [(list 'statement-binding pstmt-index args) + (statement-binding (hash-ref pstmt-table pstmt-index) + null + (map sexpr->sql-datum args))])) + + (define/private (translate-result x) + (match x + [(simple-result y) + (list 'simple-result y)] + [(rows-result h rows) + (for ([row (in-list rows)]) + (for ([i (in-range (vector-length row))]) + (let* ([x (vector-ref row i)] + [nx (sql-datum->sexpr x)]) + (unless (eq? x nx) (vector-set! row i nx))))) + (list 'rows-result h rows)] + ;; FIXME: Assumes prepared-statement is concrete class, not interface. + [(? (lambda (x) (is-a? x prepared-statement%))) + (let ([pstmt-index (begin (set! pstmt-counter (add1 pstmt-counter)) pstmt-counter)]) + (hash-set! pstmt-table pstmt-index x) + (list 'prepared-statement + pstmt-index + (get-field close-on-exec? x) + (get-field param-typeids x) + (get-field result-dvecs x)))] + [_ x])))) diff --git a/collects/db/private/generic/prepared.rkt b/collects/db/private/generic/prepared.rkt index e5b6506051..e61e2b737a 100644 --- a/collects/db/private/generic/prepared.rkt +++ b/collects/db/private/generic/prepared.rkt @@ -8,10 +8,10 @@ ;; prepared-statement% (define prepared-statement% (class* object% (prepared-statement<%>) - (init-private handle ;; handle, determined by database system, #f means closed - close-on-exec? ;; boolean - param-typeids ;; (listof typeid) - result-dvecs) ;; (listof vector), layout depends on dbsys + (init-field handle ;; handle, determined by database system, #f means closed + close-on-exec? ;; boolean + param-typeids ;; (listof typeid) + result-dvecs) ;; (listof vector), layout depends on dbsys (init ([-owner owner])) (define owner (make-weak-box -owner)) diff --git a/collects/db/private/odbc/connection.rkt b/collects/db/private/odbc/connection.rkt index df9e2beb7f..486022f8f0 100644 --- a/collects/db/private/odbc/connection.rkt +++ b/collects/db/private/odbc/connection.rkt @@ -661,3 +661,19 @@ (define (field-dvec->typeid dvec) (vector-ref dvec 1)) + +#| +Historical note: I tried using ODBC async execution to avoid blocking +all Racket threads for a long time. + +1) The postgresql, mysql, and oracle drivers don't even support async +execution. Only DB2 (and probably SQL Server, but I didn't try it). + +2) Tests using the DB2 driver gave bafflind HY010 (function sequence +error). My best theory so far is that DB2 (or maybe unixodbc) requires +poll call arguments to be identical to original call arguments, which +means that I would have to replace all uses of (_ptr o X) with +something stable across invocations. + +All in all, not worth it, especially given #:use-place solution. +|# diff --git a/collects/db/private/odbc/main.rkt b/collects/db/private/odbc/main.rkt index e2e43d13f9..f138a4ae05 100644 --- a/collects/db/private/odbc/main.rkt +++ b/collects/db/private/odbc/main.rkt @@ -2,52 +2,62 @@ (require racket/class racket/contract "../generic/interfaces.rkt" + "../generic/place-client.rkt" "connection.rkt" "dbsystem.rkt" "ffi.rkt") (provide odbc-connect odbc-driver-connect odbc-data-sources - odbc-drivers - (rename-out [dbsystem odbc-dbsystem])) + odbc-drivers) (define (odbc-connect #:dsn dsn #:user [user #f] #:password [auth #f] #:notice-handler [notice-handler void] #:strict-parameter-types? [strict-parameter-types? #f] - #:character-mode [char-mode 'wchar]) - (let ([notice-handler (make-handler notice-handler "notice")]) - (call-with-env 'odbc-connect - (lambda (env) - (call-with-db 'odbc-connect env - (lambda (db) - (let ([status (SQLConnect db dsn user auth)]) - (handle-status* 'odbc-connect status db) - (new connection% - (env env) - (db db) - (notice-handler notice-handler) - (strict-parameter-types? strict-parameter-types?) - (char-mode char-mode))))))))) + #:character-mode [char-mode 'wchar] + #:use-place [use-place #f]) + (cond [use-place + (place-connect (list 'odbc dsn user auth strict-parameter-types? char-mode) + odbc-proxy%)] + [else + (let ([notice-handler (make-handler notice-handler "notice")]) + (call-with-env 'odbc-connect + (lambda (env) + (call-with-db 'odbc-connect env + (lambda (db) + (let ([status (SQLConnect db dsn user auth)]) + (handle-status* 'odbc-connect status db) + (new connection% + (env env) + (db db) + (notice-handler notice-handler) + (strict-parameter-types? strict-parameter-types?) + (char-mode char-mode))))))))])) (define (odbc-driver-connect connection-string #:notice-handler [notice-handler void] #:strict-parameter-types? [strict-parameter-types? #f] - #:character-mode [char-mode 'wchar]) - (let ([notice-handler (make-handler notice-handler "notice")]) - (call-with-env 'odbc-driver-connect - (lambda (env) - (call-with-db 'odbc-driver-connect env - (lambda (db) - (let ([status (SQLDriverConnect db connection-string SQL_DRIVER_NOPROMPT)]) - (handle-status* 'odbc-driver-connect status db) - (new connection% - (env env) - (db db) - (notice-handler notice-handler) - (strict-parameter-types? strict-parameter-types?) - (char-mode char-mode))))))))) + #:character-mode [char-mode 'wchar] + #:use-place [use-place #f]) + (cond [use-place + (place-connect (list 'odbc-driver connection-string strict-parameter-types? char-mode) + odbc-proxy%)] + [else + (let ([notice-handler (make-handler notice-handler "notice")]) + (call-with-env 'odbc-driver-connect + (lambda (env) + (call-with-db 'odbc-driver-connect env + (lambda (db) + (let ([status (SQLDriverConnect db connection-string SQL_DRIVER_NOPROMPT)]) + (handle-status* 'odbc-driver-connect status db) + (new connection% + (env env) + (db db) + (notice-handler notice-handler) + (strict-parameter-types? strict-parameter-types?) + (char-mode char-mode))))))))])) (define (odbc-data-sources) (define server-buf (make-bytes 1024)) @@ -97,6 +107,12 @@ (let ([=-pos (caar m)]) (cons (substring s 0 =-pos) (substring s (+ 1 =-pos)))))))) + +(define odbc-proxy% + (class place-proxy-connection% + (super-new) + (define/override (get-dbsystem) dbsystem))) + ;; ---- ;; Aux functions to free handles on error. diff --git a/collects/db/private/sqlite3/main.rkt b/collects/db/private/sqlite3/main.rkt index d326c268ee..a2db4a1701 100644 --- a/collects/db/private/sqlite3/main.rkt +++ b/collects/db/private/sqlite3/main.rkt @@ -1,41 +1,51 @@ #lang racket/base (require racket/class - racket/contract ffi/file + "../generic/place-client.rkt" "connection.rkt" "dbsystem.rkt" "ffi.rkt") -(provide sqlite3-connect - (rename-out [dbsystem sqlite3-dbsystem])) +(provide sqlite3-connect) -(define (sqlite3-connect #:database path-or-sym +(define (sqlite3-connect #:database path #:mode [mode 'read/write] #:busy-retry-delay [busy-retry-delay 0.1] - #:busy-retry-limit [busy-retry-limit 10]) + #:busy-retry-limit [busy-retry-limit 10] + #:use-place [use-place #f]) (let ([path - (cond [(symbol? path-or-sym) - (case path-or-sym - ;; Private, temporary in-memory - [(memory) #":memory:"] - ;; Private, temporary on-disk - [(temporary) #""])] - [(or (path? path-or-sym) (string? path-or-sym)) - (let ([path (cleanse-path (path->complete-path path-or-sym))]) - (security-guard-check-file 'sqlite3-connect - path - (case mode - ((read-only) '(read)) - (else '(read write)))) - (path->bytes path))])]) - (let-values ([(db open-status) - (sqlite3_open_v2 path - (case mode - ((read-only) SQLITE_OPEN_READONLY) - ((read/write) SQLITE_OPEN_READWRITE) - ((create) - (+ SQLITE_OPEN_READWRITE SQLITE_OPEN_CREATE))))]) - (handle-status* 'sqlite3-connect open-status db) - (new connection% - (db db) - (busy-retry-limit busy-retry-limit) - (busy-retry-delay busy-retry-delay))))) + (case path + ((memory temporary) path) + (else + (let ([path (cleanse-path (path->complete-path path))]) + (security-guard-check-file 'sqlite3-connect + path + (case mode + ((read-only) '(read)) + (else '(read write)))) + path)))]) + (cond [use-place + (place-connect (list 'sqlite3 path mode busy-retry-delay busy-retry-limit) + sqlite-place-proxy%)] + [else + (let ([path-bytes + (case path + ((memory) #":memory:") + ((temporary) #"") + (else (path->bytes path)))]) + (let-values ([(db open-status) + (sqlite3_open_v2 path-bytes + (case mode + ((read-only) SQLITE_OPEN_READONLY) + ((read/write) SQLITE_OPEN_READWRITE) + ((create) + (+ SQLITE_OPEN_READWRITE SQLITE_OPEN_CREATE))))]) + (handle-status* 'sqlite3-connect open-status db) + (new connection% + (db db) + (busy-retry-limit busy-retry-limit) + (busy-retry-delay busy-retry-delay))))]))) + +(define sqlite-place-proxy% + (class place-proxy-connection% + (super-new) + (define/override (get-dbsystem) dbsystem))) diff --git a/collects/db/scribblings/config.rkt b/collects/db/scribblings/config.rkt index 33befe0b57..2b79af2683 100644 --- a/collects/db/scribblings/config.rkt +++ b/collects/db/scribblings/config.rkt @@ -8,6 +8,9 @@ (for-label (all-from-out racket/base) (all-from-out racket/contract))) +(define (tech/reference . pre-flows) + (apply tech #:doc '(lib "scribblings/reference/reference.scrbl") pre-flows)) + ;; ---- (define the-eval (make-base-eval)) diff --git a/collects/db/scribblings/connect.scrbl b/collects/db/scribblings/connect.scrbl index c4bbfac0fc..0b0e064bf9 100644 --- a/collects/db/scribblings/connect.scrbl +++ b/collects/db/scribblings/connect.scrbl @@ -16,6 +16,22 @@ administrative functions for managing connections. @declare-exporting[db] +There are four kinds of base connection, and they are divided into two +groups: @deftech{wire-based connections} and @deftech{FFI-based +connections}. PostgreSQL and MySQL connections are wire-based, and +SQLite and ODBC connections are FFI-based. + +Wire-based connections communicate using @tech/reference{ports}, which +do not cause other Racket threads to block. In contrast, all Racket +threads are blocked during an FFI call, so FFI-based connections can +seriously degrade the interactivity of a Racket program, particularly +if long-running queries are performed using the connection. This +problem can be avoided by creating the FFI-based connection in a +separate @tech/reference{place} using the @racket[#:use-place] +keyword argument. Such a connection will not block all Racket threads +during queries; the disadvantage is the cost of creating and +communicating with a separate @tech/reference{place}. + Base connections are made using the following functions. @defproc[(postgresql-connect [#:user user string?] @@ -188,7 +204,8 @@ Base connections are made using the following functions. [#:busy-retry-limit busy-retry-limit (or/c exact-nonnegative-integer? +inf.0) 10] [#:busy-retry-delay busy-retry-delay - (and/c rational? (not/c negative?)) 0.1]) + (and/c rational? (not/c negative?)) 0.1] + [#:use-place use-place boolean? #f]) connection?]{ Opens the SQLite database at the file named by @racket[database], if @@ -214,6 +231,10 @@ Base connections are made using the following functions. attempted once. If after @racket[busy-retry-limit] retries the operation still does not succeed, an exception is raised. + If @racket[use-place] is true, the actual connection is created in + a distinct @tech/reference{place} for database connections and a + proxy is returned. + If the connection cannot be made, an exception is raised. @(examples/results @@ -234,7 +255,8 @@ Base connections are made using the following functions. [#:strict-parameter-types? strict-parameter-types? boolean? #f] [#:character-mode character-mode (or/c 'wchar 'utf-8 'latin-1) - 'wchar]) + 'wchar] + [#:use-place use-place boolean? #f]) connection?]{ Creates a connection to the ODBC Data Source named @racket[dsn]. The @@ -258,6 +280,10 @@ Base connections are made using the following functions. See @secref["odbc-status"] for notes on specific ODBC drivers and recommendations for connection options. + If @racket[use-place] is true, the actual connection is created in + a distinct @tech/reference{place} for database connections and a + proxy is returned. + If the connection cannot be made, an exception is raised. } @@ -269,7 +295,8 @@ Base connections are made using the following functions. [#:strict-parameter-types? strict-parameter-types? boolean? #f] [#:character-mode character-mode (or/c 'wchar 'utf-8 'latin-1) - 'wchar]) + 'wchar] + [#:use-place use-place boolean? #f]) connection?]{ Creates a connection using an ODBC connection string containing a @@ -606,7 +633,8 @@ ODBC's DSNs. [#:busy-retry-limit busy-retry-limit (or/c exact-nonnegative-integer? +inf.0) @#,absent] [#:busy-retry-delay busy-retry-delay - (and/c rational? (not/c negative?)) @#,absent]) + (and/c rational? (not/c negative?)) @#,absent] + [#:use-place use-place boolean? @#,absent]) data-source?] @defproc[(odbc-data-source [#:dsn dsn (or/c string? #f) @#,absent] diff --git a/collects/db/sqlite3.rkt b/collects/db/sqlite3.rkt index 4641941086..f0d1c9b492 100644 --- a/collects/db/sqlite3.rkt +++ b/collects/db/sqlite3.rkt @@ -9,5 +9,6 @@ (->* (#:database (or/c path-string? 'memory 'temporary)) (#:mode (or/c 'read-only 'read/write 'create) #:busy-retry-limit (or/c exact-nonnegative-integer? +inf.0) - #:busy-retry-delay (and/c rational? (not/c negative?))) + #:busy-retry-delay (and/c rational? (not/c negative?)) + #:use-place any/c) any/c)]) diff --git a/collects/tests/db/all-tests.rkt b/collects/tests/db/all-tests.rkt index c247cea7b0..6b49295867 100644 --- a/collects/tests/db/all-tests.rkt +++ b/collects/tests/db/all-tests.rkt @@ -130,7 +130,16 @@ Testing profiles are flattened, not hierarchical. (define sqlite-unit (dbconf->unit (dbconf "sqlite3, memory" - (data-source 'sqlite3 '(#:database memory) '((db:test (issl))))))) + (data-source 'sqlite3 + '(#:database memory) + '((db:test (issl))))))) + +(define sqlite/p-unit + (dbconf->unit + (dbconf "sqlite3, memory, with #:use-place=#t" + (data-source 'sqlite3 + '(#:database memory #:use-place #t) + '((db:test (issl async))))))) ;; ---- @@ -176,6 +185,9 @@ Testing profiles are flattened, not hierarchical. (define sqlite-test (specialize-test sqlite-unit)) +(define sqlite/p-test + (specialize-test sqlite/p-unit)) + (define generic-test (make-test-suite "Generic tests (no db)" (list gen-sql-types:test @@ -217,7 +229,9 @@ Testing profiles are flattened, not hierarchical. (make-all-tests label (get-dbconf (string->symbol label)))))] [tests (cond [(or include-sqlite? (null? labels)) - (cons (cons "sqlite3, memory" sqlite-test) tests)] + (list* (cons "sqlite3, memory" sqlite-test) + (cons "sqlite3, memory, #:use-place=#t" sqlite/p-test) + tests)] [else tests])] [tests (cond [(or include-generic? (null? labels)) diff --git a/collects/tests/db/db/concurrent.rkt b/collects/tests/db/db/concurrent.rkt index ea75f654cb..0f25a08de7 100644 --- a/collects/tests/db/db/concurrent.rkt +++ b/collects/tests/db/db/concurrent.rkt @@ -62,50 +62,48 @@ (for ([t (in-hash-keys threads)]) (sync t)))))))) -;; ---- - -(define pool-test - (test-suite "connection pools" - (test-case "lease, limit, release" - (let* ([counter 0] - [p (connection-pool (lambda () (set! counter (+ 1 counter)) (connect-for-test)) - #:max-connections 2)] - [c1 (connection-pool-lease p)] - [c2 (connection-pool-lease p)]) - ;; Two created - (check-equal? counter 2) - ;; Can't create new one yet - (check-exn exn:fail? (lambda () (connection-pool-lease p))) - ;; But if we free one... - (disconnect c2) - (check-equal? (connected? c2) #f) - (let ([c3 (connection-pool-lease p)]) - (check-equal? counter 2 "not new") ;; used idle, not new connection - (check-equal? (connected? c3) #t)))) - (test-case "release on evt" - (let* ([p (connection-pool connect-for-test #:max-connections 2)] - [sema (make-semaphore 0)] - [c1 (connection-pool-lease p sema)]) - (check-equal? (connected? c1) #t) - ;; Closes when evt ready - (begin (semaphore-post sema) (sleep 0.1)) - (check-equal? (connected? c1) #f))) - (test-case "release on custodian" - (let* ([p (connection-pool connect-for-test #:max-connections 2)] - [cust (make-custodian)] - [c1 (connection-pool-lease p cust)]) - (check-equal? (connected? c1) #t) - ;; Closes when custodian shutdown - (begin (custodian-shutdown-all cust) (sleep 0.1)) - (check-equal? (connected? c1) #f))))) +(define (async-test) + (test-case "asynchronous execution" + (unless (ANYFLAGS 'ismy 'isora 'isdb2) + (call-with-connection + (lambda (c) + (query-exec c "create temporary table nums (n integer)") + (for ([i (in-range 40)]) + (query-exec c (sql "insert into nums (n) values ($1)") i)) + (let* ([the-sql "select cast(max(a.n * b.n *c.n * d.n) as varchar) \ + from nums a, nums b, nums c, nums d"] + [pst (prepare c the-sql)] + [sema (make-semaphore 0)] + [peek (semaphore-peek-evt sema)] + [counter 0] + [thd + (thread (lambda () + (let loop () + (sync peek) + (set! counter (add1 counter)) + (sleep 0.01) + (loop))))]) + (let ([start (current-inexact-milliseconds)]) + (semaphore-post sema) + (query-value c pst) + (semaphore-wait sema) + (let ([end (current-inexact-milliseconds)]) + (when (ANYFLAGS 'postgresql 'mysql 'async) + (when #f + (printf "counter = ~s\n" counter) + (printf "time elapsed = ~s\n" (- end start))) + ;; If c does not execute asynchronously, expect counter to be about 0. + (check-pred positive? counter) + (let ([expected-counter (/ (- end start) (* 0.01 1000))]) + (check > counter (* 0.5 expected-counter)))))))))))) ;; ---- (define test (test-suite "Concurrency" + (async-test) ;; Tests whether connections are properly locked. (test-concurrency 1) (test-concurrency 2) (test-concurrency 20) - (kill-safe-test #t) - pool-test)) + (kill-safe-test #t))) diff --git a/collects/tests/db/db/query.rkt b/collects/tests/db/db/query.rkt index 0d7038380d..e404c40cb6 100644 --- a/collects/tests/db/db/query.rkt +++ b/collects/tests/db/db/query.rkt @@ -300,6 +300,41 @@ (check-prep-once (lambda () (virtual-connection (connection-pool connect-and-setup)))))))) +(define pool-tests + (test-suite "connection pools" + (test-case "lease, limit, release" + (let* ([counter 0] + [p (connection-pool (lambda () (set! counter (+ 1 counter)) (connect-for-test)) + #:max-connections 2)] + [c1 (connection-pool-lease p)] + [c2 (connection-pool-lease p)]) + ;; Two created + (check-equal? counter 2) + ;; Can't create new one yet + (check-exn exn:fail? (lambda () (connection-pool-lease p))) + ;; But if we free one... + (disconnect c2) + (check-equal? (connected? c2) #f) + (let ([c3 (connection-pool-lease p)]) + (check-equal? counter 2 "not new") ;; used idle, not new connection + (check-equal? (connected? c3) #t)))) + (test-case "release on evt" + (let* ([p (connection-pool connect-for-test #:max-connections 2)] + [sema (make-semaphore 0)] + [c1 (connection-pool-lease p sema)]) + (check-equal? (connected? c1) #t) + ;; Closes when evt ready + (begin (semaphore-post sema) (sleep 0.1)) + (check-equal? (connected? c1) #f))) + (test-case "release on custodian" + (let* ([p (connection-pool connect-for-test #:max-connections 2)] + [cust (make-custodian)] + [c1 (connection-pool-lease p cust)]) + (check-equal? (connected? c1) #t) + ;; Closes when custodian shutdown + (begin (custodian-shutdown-all cust) (sleep 0.1)) + (check-equal? (connected? c1) #f))))) + (define test (test-suite "query API" (simple-tests 'string) @@ -309,4 +344,5 @@ low-level-tests misc-tests virtual-statement-tests + pool-tests error-tests)) From 19b1ff101c1340327a34787363744b0e23c7c455 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 31 Aug 2011 00:06:10 -0600 Subject: [PATCH 044/235] db: fixed kill-safe-connection, improved tests --- collects/db/private/generic/connect-util.rkt | 2 +- collects/db/private/generic/prepared.rkt | 2 +- collects/tests/db/all-tests.rkt | 4 +++ collects/tests/db/config.rkt | 6 +++-- collects/tests/db/db/connection.rkt | 27 +++++++++++++++----- collects/tests/db/db/sql-types.rkt | 13 +++++----- 6 files changed, 37 insertions(+), 17 deletions(-) diff --git a/collects/db/private/generic/connect-util.rkt b/collects/db/private/generic/connect-util.rkt index 6d4074fbcc..8cf6af3f12 100644 --- a/collects/db/private/generic/connect-util.rkt +++ b/collects/db/private/generic/connect-util.rkt @@ -22,7 +22,7 @@ (loop))))) (define/public (call proc) - (thread-resume mthread) + (thread-resume mthread (current-thread)) (let ([result #f] [sema (make-semaphore 0)]) (channel-put req-channel diff --git a/collects/db/private/generic/prepared.rkt b/collects/db/private/generic/prepared.rkt index e61e2b737a..8c9ed4bffa 100644 --- a/collects/db/private/generic/prepared.rkt +++ b/collects/db/private/generic/prepared.rkt @@ -81,7 +81,7 @@ (send owner free-statement this)))) (define/public (register-finalizer) - (thread-resume finalizer-thread) + (thread-resume finalizer-thread (current-thread)) (will-register will-executor this (lambda (pst) (send pst finalize)))) (super-new) diff --git a/collects/tests/db/all-tests.rkt b/collects/tests/db/all-tests.rkt index 6b49295867..42b1d03fe6 100644 --- a/collects/tests/db/all-tests.rkt +++ b/collects/tests/db/all-tests.rkt @@ -114,6 +114,9 @@ Testing profiles are flattened, not hierarchical. ;; ---- +;; Set below by command-line parsing +(define kill-safe? #f) + (define (dbconf->unit x) (match x [(dbconf dbtestname (and r (data-source connector _args exts))) @@ -219,6 +222,7 @@ Testing profiles are flattened, not hierarchical. (command-line #:once-each [("--gui") "Run tests in RackUnit GUI" (set! gui? #t)] + [("-k" "--killsafe") "Wrap with kill-safe-connection" (set! kill-safe? #t)] [("-g" "--generic") "Run generic tests" (set! include-generic? #t)] [("-s" "--sqlite3") "Run sqlite3 in-memory db tests" (set! include-sqlite? #t)] [("-f" "--config-file") file "Use configuration file" (pref-file file)] diff --git a/collects/tests/db/config.rkt b/collects/tests/db/config.rkt index 53730b70ee..434698cf6b 100644 --- a/collects/tests/db/config.rkt +++ b/collects/tests/db/config.rkt @@ -11,7 +11,8 @@ (dbtestname connect dbsys - dbflags)) + dbflags + kill-safe?)) (define-signature test^ (test)) (define-signature config^ @@ -37,7 +38,8 @@ (define NOISY? #f) (define (connect-for-test) - (connect)) + (cond [kill-safe? (kill-safe-connection (connect))] + [else (connect)])) (define test-data '((0 "nothing") diff --git a/collects/tests/db/db/connection.rkt b/collects/tests/db/db/connection.rkt index 2e9c52d5be..77ba036012 100644 --- a/collects/tests/db/db/connection.rkt +++ b/collects/tests/db/db/connection.rkt @@ -1,8 +1,10 @@ #lang racket/unit (require (for-syntax racket/base) + racket/class rackunit "../config.rkt" - db/base) + db/base + (only-in db/private/generic/interfaces locking%)) (import config^ database^) (export test^) @@ -30,22 +32,33 @@ (check-true (dbsystem? sys)) (check-pred symbol? (dbsystem-name sys)))))) - (test-case "connected?, disconnect work w/ custodian 'damage'" + (test-case "connected?, disconnect work w/ custodian damage" (let ([c0 (current-custodian)] [c1 (make-custodian)]) (let ([cx (parameterize ((current-custodian c1)) (connect-for-test))]) - ;; cx's ports (if applicable) are controlled by c1 + ;; cx's ports (if applicable) are managed by c1 (check-true (connected? cx)) (custodian-shutdown-all c1) (check-completes (lambda () (connected? cx)) "connected?") (when (memq dbsys '(mysql postgresql)) + ;; wire-based connection is disconnected; it had better know it (check-false (connected? cx))) - (check-completes (lambda () (disconnect cx)) "disconnect")))) + (check-completes (lambda () (disconnect cx)) "disconnect") + (check-false (connected? cx))))) - ;; FIXME: Still need to test the disconnect works on cx left locked - ;; because of kill-thread (currently probably doesn't for sqlite3,odbc). - ;; ie: "connected?, disconnect work w/ kill-thread 'damage'" + (test-case "connected?, disconnect work w/ kill-thread damage" + (let ([cx (connect-for-test)]) + (when (is-a? cx locking%) + (check-true (connected? cx)) + (let ([thd + (thread + (lambda () + (send cx call-with-lock 'test (lambda () (sync never-evt)))))]) + (kill-thread thd) + (check-completes (lambda () (connected? cx)) "connected?") + (check-completes (lambda () (disconnect cx)) "disconnect") + (check-false (connected? cx)))))) )) (define TIMEOUT 2) ;; seconds diff --git a/collects/tests/db/db/sql-types.rkt b/collects/tests/db/db/sql-types.rkt index ed5aa436bc..402de55fb4 100644 --- a/collects/tests/db/db/sql-types.rkt +++ b/collects/tests/db/db/sql-types.rkt @@ -212,12 +212,13 @@ (check-roundtrip c 0) (check-roundtrip c 10) (check-roundtrip c -5) - (check-roundtrip c 1/2) - (check-roundtrip c 1/40) - (check-roundtrip c #e1234567890.0987654321) - (check-roundtrip c 1/10) - (check-roundtrip c 1/400000) - (check-roundtrip c 12345678901234567890) + (unless (TESTFLAGS 'odbc 'ismy) + (check-roundtrip c 12345678901234567890) + (check-roundtrip c 1/2) + (check-roundtrip c 1/40) + (check-roundtrip c #e1234567890.0987654321) + (check-roundtrip c 1/10) + (check-roundtrip c 1/400000)) (when (supported? 'numeric-infinities) (check-roundtrip c +nan.0)))))) From 8611435269f7b93b120f19f17f60fd0747720bf6 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 31 Aug 2011 02:02:39 -0600 Subject: [PATCH 045/235] db: improved locking Tests suggest new locking is faster, but primary benefit is detecting when thread holding lock is killed. --- collects/db/private/generic/interfaces.rkt | 83 ++++++++++++++-------- 1 file changed, 52 insertions(+), 31 deletions(-) diff --git a/collects/db/private/generic/interfaces.rkt b/collects/db/private/generic/interfaces.rkt index c8ad693a70..73af6fba0f 100644 --- a/collects/db/private/generic/interfaces.rkt +++ b/collects/db/private/generic/interfaces.rkt @@ -1,5 +1,6 @@ #lang racket/base -(require racket/class) +(require racket/class + ffi/unsafe/atomic) (provide connection<%> dbsystem<%> prepared-statement<%> @@ -188,27 +189,33 @@ ;; Connection base class (locking) -;; Disabled for now, because this is an 80% solution. Unfortunately, I -;; think a 100% solution would require an auxiliary kill-safe thread -;; with multiple thread switches *per lock acquisition*. At that -;; point, might as well just use kill-safe connection. -(define USE-LOCK-HOLDER? #f) - (define locking% (class object% ;; == Communication locking - (define lock (make-semaphore 1)) - - ;; Ideally, we would like to be able to detect if a thread has + ;; Goal: we would like to be able to detect if a thread has ;; acquired the lock and then died, leaving the connection - ;; permanently locked. Roughly, we would like this: if lock is - ;; held by thread th, then lock-holder = (thread-dead-evt th), - ;; and if lock is not held, then lock-holder = never-evt. - ;; Unfortunately, there are intervals when this is not true. - ;; Also, since lock-holder changes, reference might be stale, so - ;; need to double-check. + ;; permanently locked. + ;; + ;; lock-holder=(thread-dead-evt thd) iff thd has acquired inner-lock + ;; - lock-holder, inner-lock always modified together within + ;; atomic block + ;; + ;; Thus if (thread-dead-evt thd) is ready, thd died holding + ;; inner-lock, so hopelessly locked. + ;; + ;; outer-sema = inner-lock + ;; - outer-sema, inner-lock always modified together within atomic + ;; + ;; The outer-lock just prevents threads from spinning polling + ;; inner-lock. If a thread gets past outer-lock and dies before + ;; acquiring inner-lock, ok, because outer-lock still open at that + ;; point, so other threads can enter outer-lock and acquire inner-lock. + + (define outer-sema (make-semaphore 1)) + (define outer-lock (semaphore-peek-evt outer-sema)) + (define inner-lock (make-semaphore 1)) (define lock-holder never-evt) ;; Delay async calls (eg, notice handler) until unlock @@ -220,21 +227,32 @@ (call-with-lock* who proc #f #t)) (define/public-final (call-with-lock* who proc hopeless require-connected?) - (let* ([me (thread-dead-evt (current-thread))] - [result (sync lock lock-holder)]) - (cond [(eq? result lock) - ;; Acquired lock - (when USE-LOCK-HOLDER? (set! lock-holder me)) - (when (and require-connected? (not (connected?))) - (semaphore-post lock) - (error/not-connected who)) - (with-handlers ([values (lambda (e) (unlock) (raise e))]) - (begin0 (proc) (unlock)))] + (let ([me (thread-dead-evt (current-thread))] + [result (sync outer-lock lock-holder)]) + (cond [(eq? result outer-lock) + ;; Got past outer stage + (let ([proceed? + (begin (start-atomic) + (let ([proceed? (semaphore-try-wait? inner-lock)]) + (when proceed? + (set! lock-holder me) + (semaphore-wait outer-sema)) + (end-atomic) + proceed?))]) + (cond [proceed? + ;; Acquired lock + ;; - lock-holder = me, and outer-lock is closed again + (when (and require-connected? (not (connected?))) + (unlock) + (error/not-connected who)) + (with-handlers ([values (lambda (e) (unlock) (raise e))]) + (begin0 (proc) (unlock)))] + [else + ;; Didn't acquire lock; retry + (call-with-lock* who proc hopeless require-connected?)]))] [(eq? result lock-holder) ;; Thread holding lock is dead - (if hopeless - (hopeless) - (error/hopeless who))] + (if hopeless (hopeless) (error/hopeless who))] [else ;; lock-holder was stale; retry (call-with-lock* who proc hopeless require-connected?)]))) @@ -242,8 +260,11 @@ (define/private (unlock) (let ([async-calls (reverse delayed-async-calls)]) (set! delayed-async-calls null) - (when USE-LOCK-HOLDER? (set! lock-holder never-evt)) - (semaphore-post lock) + (start-atomic) + (set! lock-holder never-evt) + (semaphore-post inner-lock) + (semaphore-post outer-sema) + (end-atomic) (for-each call-with-continuation-barrier async-calls))) ;; needs overriding From a5bda8e0cdbed54d75b0fd13639d93ca9c5997ca Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 31 Aug 2011 02:12:40 -0600 Subject: [PATCH 046/235] db: moved private contracts to db/base, removed useless requires --- collects/db/TODO | 5 +- collects/db/base.rkt | 251 ++++++++++++++++++- collects/db/main.rkt | 7 +- collects/db/mysql.rkt | 2 +- collects/db/postgresql.rkt | 2 +- collects/db/private/generic/connect-util.rkt | 32 +-- collects/db/private/generic/dsn.rkt | 82 ++---- collects/db/private/generic/functions.rkt | 117 +-------- collects/db/private/generic/main.rkt | 68 ----- collects/db/private/generic/sql-convert.rkt | 1 - collects/db/private/mysql/main.rkt | 9 +- collects/db/private/odbc/dbsystem.rkt | 5 +- collects/db/private/odbc/ffi.rkt | 3 +- collects/db/private/odbc/main.rkt | 1 - collects/db/private/postgresql/main.rkt | 7 +- collects/db/private/sqlite3/dbsystem.rkt | 4 +- collects/db/scribblings/config.rkt | 1 - collects/db/sqlite3.rkt | 2 +- collects/db/util/private/geometry.rkt | 3 +- 19 files changed, 289 insertions(+), 313 deletions(-) delete mode 100644 collects/db/private/generic/main.rkt diff --git a/collects/db/TODO b/collects/db/TODO index 8a91f306d1..3a69ba3572 100644 --- a/collects/db/TODO +++ b/collects/db/TODO @@ -1,4 +1,3 @@ -internal docs ---- Testing @@ -31,11 +30,11 @@ Types Misc +- internal docs + - use ffi/unsafe/alloc to simplify odbc handle allocation - add ODBC-like functions for inspecting schemas (list-tables, etc) - - util/schema (?), util/info (for information_schema) (?) - - at least, table-exists? : string [...] -> boolean? - for wrapped/managed connections, detect if underlying connection gets disconnected by server (eg, times out after 10 minutes of inactivity) diff --git a/collects/db/base.rkt b/collects/db/base.rkt index 158b0a7093..7fc39c6d71 100644 --- a/collects/db/base.rkt +++ b/collects/db/base.rkt @@ -1,9 +1,248 @@ #lang racket/base (require racket/contract - "private/generic/main.rkt" - "private/generic/connect-util.rkt" - "private/generic/dsn.rkt") + unstable/prop-contract) -(provide (all-from-out "private/generic/main.rkt") - (all-from-out "private/generic/dsn.rkt") - (all-from-out "private/generic/connect-util.rkt")) +;; ============================================================ + +(require "private/generic/interfaces.rkt" + "private/generic/sql-data.rkt") + +(provide (struct-out simple-result) + (struct-out rows-result) + statement-binding?) + +(provide sql-null + sql-null? + sql-null->false + false->sql-null) + +(provide/contract + [struct sql-date ([year exact-integer?] + [month (integer-in 0 12)] + [day (integer-in 0 31)])] + [struct sql-time ([hour (integer-in 0 23)] + [minute (integer-in 0 59)] + [second (integer-in 0 61)] ;; leap seconds + [nanosecond (integer-in 0 (sub1 #e1e9))] + [tz (or/c #f exact-integer?)])] + [struct sql-timestamp ([year exact-integer?] + [month (integer-in 0 12)] + [day (integer-in 0 31)] + [hour (integer-in 0 23)] + [minute (integer-in 0 59)] + [second (integer-in 0 61)] + [nanosecond (integer-in 0 (sub1 #e1e9))] + [tz (or/c #f exact-integer?)])] + [struct sql-interval ([years exact-integer?] + [months exact-integer?] + [days exact-integer?] + [hours exact-integer?] + [minutes exact-integer?] + [seconds exact-integer?] + [nanoseconds exact-integer?])] + + [sql-day-time-interval? + (-> any/c boolean?)] + [sql-year-month-interval? + (-> any/c boolean?)] + [sql-interval->sql-time + (->* (sql-interval?) (any/c) + any)] + [sql-time->sql-interval + (-> sql-time? sql-day-time-interval?)] + + [make-sql-bits + (-> exact-nonnegative-integer? sql-bits?)] + [sql-bits? + (-> any/c boolean?)] + [sql-bits-length + (-> sql-bits? exact-nonnegative-integer?)] + [sql-bits-ref + (-> sql-bits? exact-nonnegative-integer? boolean?)] + [sql-bits-set! + (-> sql-bits? exact-nonnegative-integer? boolean? void?)] + [sql-bits->list + (-> sql-bits? (listof boolean?))] + [list->sql-bits + (-> (listof boolean?) sql-bits?)] + [sql-bits->string + (-> sql-bits? string?)] + [string->sql-bits + (-> string? sql-bits?)]) + +;; ============================================================ + +(require "private/generic/functions.rkt") + +(provide (rename-out [in-query* in-query])) + +(provide/contract + [connection? + (-> any/c any)] + [disconnect + (-> connection? any)] + [connected? + (-> connection? any)] + [connection-dbsystem + (-> connection? dbsystem?)] + [dbsystem? + (-> any/c any)] + [dbsystem-name + (-> dbsystem? symbol?)] + [dbsystem-supported-types + (-> dbsystem? (listof symbol?))] + + [statement? + (-> any/c any)] + [prepared-statement? + (-> any/c any)] + [prepared-statement-parameter-types + (-> prepared-statement? (or/c list? #f))] + [prepared-statement-result-types + (-> prepared-statement? (or/c list? #f))] + + [query-exec + (->* (connection? statement?) () #:rest list? any)] + [query-rows + (->* (connection? statement?) () #:rest list? (listof vector?))] + [query-list + (->* (connection? statement?) () #:rest list? list?)] + [query-row + (->* (connection? statement?) () #:rest list? vector?)] + [query-maybe-row + (->* (connection? statement?) () #:rest list? (or/c #f vector?))] + [query-value + (->* (connection? statement?) () #:rest list? any)] + [query-maybe-value + (->* (connection? statement?) () #:rest list? any)] + [query + (->* (connection? statement?) () #:rest list? any)] + + [prepare + (-> connection? (or/c string? virtual-statement?) any)] + [bind-prepared-statement + (-> prepared-statement? list? any)] + + [rename virtual-statement* virtual-statement + (-> (or/c string? (-> dbsystem? string?)) + virtual-statement?)] + [virtual-statement? + (-> any/c boolean?)] + + [start-transaction + (->* (connection?) + (#:isolation (or/c 'serializable 'repeatable-read 'read-committed 'read-uncommitted #f)) + void?)] + [commit-transaction + (-> connection? void?)] + [rollback-transaction + (-> connection? void?)] + [in-transaction? + (-> connection? boolean?)] + [needs-rollback? + (-> connection? boolean?)] + [call-with-transaction + (->* (connection? (-> any)) + (#:isolation (or/c 'serializable 'repeatable-read 'read-committed 'read-uncommitted #f)) + void?)] + + [prop:statement + (struct-type-property/c + (-> any/c connection? + statement?))] + + [list-tables + (->* (connection?) + (#:schema (or/c 'search-or-current 'search 'current)) + (listof string?))] + [table-exists? + (->* (connection? string?) + (#:schema (or/c 'search-or-current 'search 'current) + #:case-sensitive? any/c) + boolean?)] + + [group-rows + (->* (rows-result? + #:group (or/c (vectorof string?) (listof (vectorof string?)))) + (#:group-mode (listof (or/c 'preserve-null-rows 'list))) + rows-result?)]) + +;; ============================================================ + +(require "private/generic/connect-util.rkt") + +(provide/contract + [kill-safe-connection + (-> connection? connection?)] + [virtual-connection + (->* ((or/c (-> connection?) connection-pool?)) + () + connection?)] + [connection-pool + (->* ((-> connection?)) + (#:max-connections (or/c (integer-in 1 10000) +inf.0) + #:max-idle-connections (or/c (integer-in 1 10000) +inf.0)) + connection-pool?)] + [connection-pool? + (-> any/c boolean?)] + [connection-pool-lease + (->* (connection-pool?) + ((or/c custodian? evt?)) + connection?)]) + +;; ============================================================ + +(require "private/generic/dsn.rkt") + +(provide dsn-connect) ;; can't express "or any kw at all" w/ ->* contract +(provide/contract + [struct data-source + ([connector connector?] + [args arglist?] + [extensions (listof (list/c symbol? writable-datum?))])] + [current-dsn-file (parameter/c path-string?)] + [get-dsn + (->* (symbol?) (any/c #:dsn-file path-string?) any)] + [put-dsn + (->* (symbol? (or/c data-source? #f)) (#:dsn-file path-string?) void?)] + [postgresql-data-source + (->* () + (#:user string? + #:database string? + #:server string? + #:port exact-positive-integer? + #:socket (or/c string? 'guess) + #:password (or/c string? #f) + #:allow-cleartext-password? boolean? + #:ssl (or/c 'yes 'optional 'no) + #:notice-handler (or/c 'output 'error) + #:notification-handler (or/c 'output 'error)) + data-source?)] + [mysql-data-source + (->* () + (#:user string? + #:database string? + #:server string? + #:port exact-positive-integer? + #:socket (or/c string? 'guess) + #:password (or/c string? #f) + #:notice-handler (or/c 'output 'error)) + data-source?)] + [sqlite3-data-source + (->* () + (#:database (or/c string? 'memory 'temporary) + #:mode (or/c 'read-only 'read/write 'create) + #:busy-retry-limit (or/c exact-nonnegative-integer? +inf.0) + #:busy-retry-delay (and/c rational? (not/c negative?)) + #:use-place boolean?) + data-source?)] + [odbc-data-source + (->* () + (#:dsn string? + #:user string? + #:password string? + #:notice-handler (or/c 'output 'error) + #:strict-parameter-types? boolean? + #:character-mode (or/c 'wchar 'utf-8 'latin-1) + #:use-place boolean?) + data-source?)]) diff --git a/collects/db/main.rkt b/collects/db/main.rkt index 5d759ecc66..673c48b3e5 100644 --- a/collects/db/main.rkt +++ b/collects/db/main.rkt @@ -2,7 +2,6 @@ (require (for-syntax racket/base) "private/generic/lazy-require.rkt" racket/runtime-path - racket/promise racket/contract "base.rkt") (provide (all-from-out "base.rkt")) @@ -49,7 +48,7 @@ #:ssl-context ssl-client-context? #:notice-handler (or/c 'output 'error output-port? procedure?) #:notification-handler (or/c 'output 'error output-port? procedure?)) - any/c)] + connection?)] [postgresql-guess-socket-path (-> path-string?)] [postgresql-password-hash @@ -64,7 +63,7 @@ #:port (or/c exact-positive-integer? #f) #:socket (or/c path-string? 'guess #f) #:notice-handler (or/c 'output 'error output-port? procedure?)) - any/c)] + connection?)] [mysql-guess-socket-path (-> path-string?)] [mysql-password-hash @@ -77,7 +76,7 @@ #:busy-retry-limit (or/c exact-nonnegative-integer? +inf.0) #:busy-retry-delay (and/c rational? (not/c negative?)) #:use-place boolean?) - any/c)] + connection?)] ;; Duplicates contracts at odbc.rkt [odbc-connect diff --git a/collects/db/mysql.rkt b/collects/db/mysql.rkt index 001cdfaade..ba78e4ce2c 100644 --- a/collects/db/mysql.rkt +++ b/collects/db/mysql.rkt @@ -13,7 +13,7 @@ #:port (or/c exact-positive-integer? #f) #:socket (or/c path-string? 'guess #f) #:notice-handler (or/c 'output 'error output-port? procedure?)) - any/c)] + connection?)] [mysql-guess-socket-path (-> path-string?)] [mysql-password-hash diff --git a/collects/db/postgresql.rkt b/collects/db/postgresql.rkt index 2830bce7c2..e36267e82f 100644 --- a/collects/db/postgresql.rkt +++ b/collects/db/postgresql.rkt @@ -18,7 +18,7 @@ #:ssl-context ssl-client-context? #:notice-handler (or/c 'output 'error output-port? procedure?) #:notification-handler (or/c 'output 'error output-port? procedure?)) - any/c)] + connection?)] [postgresql-guess-socket-path (-> path-string?)] [postgresql-password-hash diff --git a/collects/db/private/generic/connect-util.rkt b/collects/db/private/generic/connect-util.rkt index 8cf6af3f12..87d23a0523 100644 --- a/collects/db/private/generic/connect-util.rkt +++ b/collects/db/private/generic/connect-util.rkt @@ -1,8 +1,11 @@ #lang racket/base -(require racket/contract - racket/class - "interfaces.rkt" - (only-in "functions.rkt" connection?)) +(require racket/class + "interfaces.rkt") +(provide kill-safe-connection + virtual-connection + connection-pool + connection-pool? + connection-pool-lease) ;; manager% implements kill-safe manager thread w/ request channel (define manager% @@ -376,24 +379,3 @@ (uerror 'connection-pool-lease "cannot obtain connection; connection pool limit reached")) result)) - -;; ======================================== - -(provide/contract - [kill-safe-connection - (-> connection? connection?)] - [virtual-connection - (->* ((or/c (-> connection?) connection-pool?)) - () - connection?)] - [connection-pool - (->* ((-> connection?)) - (#:max-connections (or/c (integer-in 1 10000) +inf.0) - #:max-idle-connections (or/c (integer-in 1 10000) +inf.0)) - connection-pool?)] - [connection-pool? - (-> any/c boolean?)] - [connection-pool-lease - (->* (connection-pool?) - ((or/c custodian? evt?)) - connection?)]) diff --git a/collects/db/private/generic/dsn.rkt b/collects/db/private/generic/dsn.rkt index 5455726a0d..177b659cc1 100644 --- a/collects/db/private/generic/dsn.rkt +++ b/collects/db/private/generic/dsn.rkt @@ -1,12 +1,21 @@ #lang racket/base (require "lazy-require.rkt" - racket/contract racket/match racket/file racket/list - racket/runtime-path - racket/promise - "main.rkt") + racket/runtime-path) +(provide dsn-connect + (struct-out data-source) + connector? + arglist? + writable-datum? + current-dsn-file + get-dsn + put-dsn + postgresql-data-source + mysql-data-source + sqlite3-data-source + odbc-data-source) (define-lazy-require-definer define-main "../../main.rkt") @@ -47,15 +56,15 @@ considered important. (define none (gensym 'none)) -(define (datum? x) +(define (writable-datum? x) (or (symbol? x) (string? x) (number? x) (boolean? x) (null? x) (and (pair? x) - (datum? (car x)) - (datum? (cdr x))))) + (writable-datum? (car x)) + (writable-datum? (cdr x))))) (define (connector? x) (memq x '(postgresql mysql sqlite3 odbc))) @@ -72,11 +81,11 @@ considered important. (reverse kwargs))] [(keyword? (car x)) (cond [(null? (cdr x)) (fail "keyword without argument: ~a" (car x))] - [(datum? (cadr x)) + [(writable-datum? (cadr x)) (loop (cddr x) pargs (cons (list (car x) (cadr x)) kwargs))] [else (fail "expected readable datum: ~e" (cadr x))])] - [(datum? (car x)) + [(writable-datum? (car x)) (loop (cdr x) (cons (car x) pargs) kwargs)] [else (fail "expected readable datum: ~e" (car x))])) (fail "expected list"))) @@ -93,7 +102,7 @@ considered important. (if (list? x) (map (lambda (x) (match x - [(list (? symbol? key) (? datum? value)) + [(list (? symbol? key) (? writable-datum? value)) x] [else (fail "expected extension entry: ~e" x)])) x) @@ -195,56 +204,3 @@ considered important. (mk-specialized 'odbc-data-source 'odbc 0 '(#:dsn #:user #:password #:notice-handler #:strict-parameter-types? #:character-mode #:use-place))) - -(provide/contract - [struct data-source - ([connector connector?] - [args arglist?] - [extensions (listof (list/c symbol? datum?))])] - [dsn-connect procedure?] ;; Can't express "or any kw at all" w/ ->* contract. - [current-dsn-file (parameter/c path-string?)] - [get-dsn - (->* (symbol?) (any/c #:dsn-file path-string?) any)] - [put-dsn - (->* (symbol? (or/c data-source? #f)) (#:dsn-file path-string?) void?)] - [postgresql-data-source - (->* () - (#:user string? - #:database string? - #:server string? - #:port exact-positive-integer? - #:socket (or/c string? 'guess) - #:password (or/c string? #f) - #:allow-cleartext-password? boolean? - #:ssl (or/c 'yes 'optional 'no) - #:notice-handler (or/c 'output 'error) - #:notification-handler (or/c 'output 'error)) - data-source?)] - [mysql-data-source - (->* () - (#:user string? - #:database string? - #:server string? - #:port exact-positive-integer? - #:socket (or/c string? 'guess) - #:password (or/c string? #f) - #:notice-handler (or/c 'output 'error)) - data-source?)] - [sqlite3-data-source - (->* () - (#:database (or/c string? 'memory 'temporary) - #:mode (or/c 'read-only 'read/write 'create) - #:busy-retry-limit (or/c exact-nonnegative-integer? +inf.0) - #:busy-retry-delay (and/c rational? (not/c negative?)) - #:use-place boolean?) - data-source?)] - [odbc-data-source - (->* () - (#:dsn string? - #:user string? - #:password string? - #:notice-handler (or/c 'output 'error) - #:strict-parameter-types? boolean? - #:character-mode (or/c 'wchar 'utf-8 'latin-1) - #:use-place boolean?) - data-source?)]) diff --git a/collects/db/private/generic/functions.rkt b/collects/db/private/generic/functions.rkt index d5bd0e8f20..554fb73fb9 100644 --- a/collects/db/private/generic/functions.rkt +++ b/collects/db/private/generic/functions.rkt @@ -1,11 +1,10 @@ #lang racket/base (require (for-syntax racket/base) - racket/contract racket/vector - unstable/prop-contract racket/class "interfaces.rkt" (only-in "sql-data.rkt" sql-null sql-null?)) +(provide (all-defined-out)) ;; == Administrative procedures @@ -42,9 +41,6 @@ (statement-binding? x) (prop:statement? x))) -(define complete-statement? - (or/c string? statement-binding?)) - (define (bind-prepared-statement pst params) (send pst bind 'bind-prepared-statement params)) @@ -304,110 +300,6 @@ ;; list-tables* : ... -> (listof vector) ;; Return full catalog/schema/table/type list. -;; ======================================== - -(define preparable/c (or/c string? virtual-statement?)) - -(provide (rename-out [in-query* in-query])) - -(provide/contract - [connection? - (-> any/c any)] - [disconnect - (-> connection? any)] - [connected? - (-> connection? any)] - [connection-dbsystem - (-> connection? dbsystem?)] - [dbsystem? - (-> any/c any)] - [dbsystem-name - (-> dbsystem? symbol?)] - [dbsystem-supported-types - (-> dbsystem? (listof symbol?))] - - [statement? - (-> any/c any)] - [prepared-statement? - (-> any/c any)] - [prepared-statement-parameter-types - (-> prepared-statement? (or/c list? #f))] - [prepared-statement-result-types - (-> prepared-statement? (or/c list? #f))] - - [query-exec - (->* (connection? statement?) () #:rest list? any)] - [query-rows - (->* (connection? statement?) () #:rest list? (listof vector?))] - [query-list - (->* (connection? statement?) () #:rest list? list?)] - [query-row - (->* (connection? statement?) () #:rest list? vector?)] - [query-maybe-row - (->* (connection? statement?) () #:rest list? (or/c #f vector?))] - [query-value - (->* (connection? statement?) () #:rest list? any)] - [query-maybe-value - (->* (connection? statement?) () #:rest list? any)] - [query - (->* (connection? statement?) () #:rest list? any)] - - #| - [in-query - (->* (connection? statement?) () #:rest list? sequence?)] - |# - - [prepare - (-> connection? preparable/c any)] - [bind-prepared-statement - (-> prepared-statement? list? any)] - - [rename virtual-statement* virtual-statement - (-> (or/c string? (-> dbsystem? string?)) - virtual-statement?)] - [virtual-statement? - (-> any/c boolean?)] - - [start-transaction - (->* (connection?) - (#:isolation (or/c 'serializable 'repeatable-read 'read-committed 'read-uncommitted #f)) - void?)] - [commit-transaction - (-> connection? void?)] - [rollback-transaction - (-> connection? void?)] - [in-transaction? - (-> connection? boolean?)] - [needs-rollback? - (-> connection? boolean?)] - [call-with-transaction - (->* (connection? (-> any)) - (#:isolation (or/c 'serializable 'repeatable-read 'read-committed 'read-uncommitted #f)) - void?)] - - [prop:statement - (struct-type-property/c - (-> any/c connection? - statement?))] - - [list-tables - (->* (connection?) - (#:schema (or/c 'search-or-current 'search 'current)) - (listof string?))] - [table-exists? - (->* (connection? string?) - (#:schema (or/c 'search-or-current 'search 'current) - #:case-sensitive? any/c) - boolean?)] - -#| - [get-schemas - (-> connection? (listof vector?))] - [get-tables - (-> connection? (listof vector?))] -|#) - - ;; ======================================== (define (group-rows result @@ -553,10 +445,3 @@ invert-outer? as-list?)]) (vector-append key (vector residuals))))))])) - -(provide/contract - [group-rows - (->* (rows-result? - #:group (or/c (vectorof string?) (listof (vectorof string?)))) - (#:group-mode (listof (or/c 'preserve-null-rows 'list))) - rows-result?)]) diff --git a/collects/db/private/generic/main.rkt b/collects/db/private/generic/main.rkt deleted file mode 100644 index 505209c3c1..0000000000 --- a/collects/db/private/generic/main.rkt +++ /dev/null @@ -1,68 +0,0 @@ -#lang racket/base -(require racket/contract - "interfaces.rkt" - "sql-data.rkt" - "functions.rkt") -(provide (struct-out simple-result) - (struct-out rows-result) - statement-binding? - (all-from-out "functions.rkt")) - -(provide sql-null - sql-null? - sql-null->false - false->sql-null) - -(provide/contract - [struct sql-date ([year exact-integer?] - [month (integer-in 0 12)] - [day (integer-in 0 31)])] - [struct sql-time ([hour (integer-in 0 23)] - [minute (integer-in 0 59)] - [second (integer-in 0 61)] ;; leap seconds - [nanosecond (integer-in 0 (sub1 #e1e9))] - [tz (or/c #f exact-integer?)])] - [struct sql-timestamp ([year exact-integer?] - [month (integer-in 0 12)] - [day (integer-in 0 31)] - [hour (integer-in 0 23)] - [minute (integer-in 0 59)] - [second (integer-in 0 61)] - [nanosecond (integer-in 0 (sub1 #e1e9))] - [tz (or/c #f exact-integer?)])] - [struct sql-interval ([years exact-integer?] - [months exact-integer?] - [days exact-integer?] - [hours exact-integer?] - [minutes exact-integer?] - [seconds exact-integer?] - [nanoseconds exact-integer?])] - - [sql-day-time-interval? - (-> any/c boolean?)] - [sql-year-month-interval? - (-> any/c boolean?)] - [sql-interval->sql-time - (->* (sql-interval?) (any/c) - any)] - [sql-time->sql-interval - (-> sql-time? sql-day-time-interval?)] - - [make-sql-bits - (-> exact-nonnegative-integer? sql-bits?)] - [sql-bits? - (-> any/c boolean?)] - [sql-bits-length - (-> sql-bits? exact-nonnegative-integer?)] - [sql-bits-ref - (-> sql-bits? exact-nonnegative-integer? boolean?)] - [sql-bits-set! - (-> sql-bits? exact-nonnegative-integer? boolean? void?)] - [sql-bits->list - (-> sql-bits? (listof boolean?))] - [list->sql-bits - (-> (listof boolean?) sql-bits?)] - [sql-bits->string - (-> sql-bits? string?)] - [string->sql-bits - (-> string? sql-bits?)]) diff --git a/collects/db/private/generic/sql-convert.rkt b/collects/db/private/generic/sql-convert.rkt index ac6eac4dc8..897a7e1742 100644 --- a/collects/db/private/generic/sql-convert.rkt +++ b/collects/db/private/generic/sql-convert.rkt @@ -1,5 +1,4 @@ #lang racket/base -(require "sql-data.rkt") ;; ======================================== diff --git a/collects/db/private/mysql/main.rkt b/collects/db/private/mysql/main.rkt index 80d142e2be..e03057c8c3 100644 --- a/collects/db/private/mysql/main.rkt +++ b/collects/db/private/mysql/main.rkt @@ -1,16 +1,13 @@ #lang racket/base -(require racket/contract - racket/class +(require racket/class racket/tcp file/sha1 "../generic/interfaces.rkt" "../generic/socket.rkt" - "connection.rkt" - "dbsystem.rkt") + "connection.rkt") (provide mysql-connect mysql-guess-socket-path - mysql-password-hash - (rename-out [dbsystem mysql-dbsystem])) + mysql-password-hash) (define (mysql-connect #:user user #:database database diff --git a/collects/db/private/odbc/dbsystem.rkt b/collects/db/private/odbc/dbsystem.rkt index f6ade4e336..bbef44b51d 100644 --- a/collects/db/private/odbc/dbsystem.rkt +++ b/collects/db/private/odbc/dbsystem.rkt @@ -1,11 +1,8 @@ #lang racket/base (require racket/class - ffi/unsafe - ffi/unsafe/atomic "../generic/interfaces.rkt" "../generic/sql-data.rkt" - "../generic/sql-convert.rkt" - "ffi.rkt") + "../generic/sql-convert.rkt") (provide dbsystem supported-typeid?) diff --git a/collects/db/private/odbc/ffi.rkt b/collects/db/private/odbc/ffi.rkt index 404cd0db38..370190b06d 100644 --- a/collects/db/private/odbc/ffi.rkt +++ b/collects/db/private/odbc/ffi.rkt @@ -1,6 +1,5 @@ #lang racket/base -(require (rename-in racket/contract [-> c->]) - ffi/unsafe +(require ffi/unsafe ffi/unsafe/define "ffi-constants.rkt") (provide (all-from-out "ffi-constants.rkt")) diff --git a/collects/db/private/odbc/main.rkt b/collects/db/private/odbc/main.rkt index f138a4ae05..b5a63c6f70 100644 --- a/collects/db/private/odbc/main.rkt +++ b/collects/db/private/odbc/main.rkt @@ -1,6 +1,5 @@ #lang racket/base (require racket/class - racket/contract "../generic/interfaces.rkt" "../generic/place-client.rkt" "connection.rkt" diff --git a/collects/db/private/postgresql/main.rkt b/collects/db/private/postgresql/main.rkt index 698ca42f7e..9f3311bc80 100644 --- a/collects/db/private/postgresql/main.rkt +++ b/collects/db/private/postgresql/main.rkt @@ -1,16 +1,13 @@ #lang racket/base (require racket/class - racket/contract racket/tcp openssl "../generic/interfaces.rkt" "../generic/socket.rkt" - "connection.rkt" - "dbsystem.rkt") + "connection.rkt") (provide postgresql-connect postgresql-guess-socket-path - postgresql-password-hash - (rename-out [dbsystem postgresql-dbsystem])) + postgresql-password-hash) (define (postgresql-connect #:user user #:database database diff --git a/collects/db/private/sqlite3/dbsystem.rkt b/collects/db/private/sqlite3/dbsystem.rkt index 12d1e2d1d6..86de61b153 100644 --- a/collects/db/private/sqlite3/dbsystem.rkt +++ b/collects/db/private/sqlite3/dbsystem.rkt @@ -1,8 +1,6 @@ #lang racket/base (require racket/class - "../generic/interfaces.rkt" - "../generic/sql-data.rkt" - "ffi-constants.rkt") + "../generic/interfaces.rkt") (provide dbsystem) (define sqlite3-dbsystem% diff --git a/collects/db/scribblings/config.rkt b/collects/db/scribblings/config.rkt index 2b79af2683..c3be75a1ed 100644 --- a/collects/db/scribblings/config.rkt +++ b/collects/db/scribblings/config.rkt @@ -1,7 +1,6 @@ #lang racket/base (require scribble/manual scribble/eval - racket/sandbox (for-label racket/base racket/contract)) (provide (all-defined-out) diff --git a/collects/db/sqlite3.rkt b/collects/db/sqlite3.rkt index f0d1c9b492..26f17efc10 100644 --- a/collects/db/sqlite3.rkt +++ b/collects/db/sqlite3.rkt @@ -11,4 +11,4 @@ #:busy-retry-limit (or/c exact-nonnegative-integer? +inf.0) #:busy-retry-delay (and/c rational? (not/c negative?)) #:use-place any/c) - any/c)]) + connection?)]) diff --git a/collects/db/util/private/geometry.rkt b/collects/db/util/private/geometry.rkt index c674fbb3aa..07617a7961 100644 --- a/collects/db/util/private/geometry.rkt +++ b/collects/db/util/private/geometry.rkt @@ -1,6 +1,5 @@ #lang racket/base -(require racket/contract - racket/list) +(require racket/list) (provide (all-defined-out)) #| From 468bfc5437298495b9e1160f4968feab48b465d2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 29 Aug 2011 13:21:24 -0600 Subject: [PATCH 047/235] fix "GRacketCGC.app" install --- src/gracket/Makefile.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/gracket/Makefile.in b/src/gracket/Makefile.in index d39ef4d155..8ccc0b3d8d 100644 --- a/src/gracket/Makefile.in +++ b/src/gracket/Makefile.in @@ -217,7 +217,7 @@ install-wx_mac: install-wx_mac-cgc: cd ..; $(ICP) -r gracket/GRacket@CGC@.app "$(prefix)/GRacket@CGC_CAP_INSTALLED@.app" @RUN_RACKET_CGC@ -cqu "$(srcdir)/../mac/rename-app.rkt" "$(prefix)/GRacket@CGC_CAP_INSTALLED@.app" "GRacket@CGC@" "GRacket@CGC_CAP_INSTALLED@" - /usr/bin/install_name_tool -change "@executable_path/../../../Racket.framework/Versions/$(FWVERSION)/Racket" "@FRAMEWORK_PREFIX@Racket.framework/Versions/$(FWVERSION)/Racket" "$(prefix)/GRacket@CGC_CAP_INSTALLED@.app/Contents/MacOS/GRacket@CGC_CAP_INSTALLED@" + /usr/bin/install_name_tool -change "@executable_path/../../../../racket/Racket.framework/Versions/$(FWVERSION)/Racket" "@FRAMEWORK_PREFIX@Racket.framework/Versions/$(FWVERSION)/Racket" "$(prefix)/GRacket@CGC_CAP_INSTALLED@.app/Contents/MacOS/GRacket@CGC_CAP_INSTALLED@" @RUN_RACKET_CGC@ -cu "$(srcdir)/../racket/collects-path.rkt" "$(prefix)/GRacket@CGC_CAP_INSTALLED@.app/Contents/MacOS/GRacket@CGC_CAP_INSTALLED@" ../../../collects @STRIP_DEBUG@ "$(prefix)/GRacket@CGC_CAP_INSTALLED@.app/Contents/MacOS/GRacket@CGC_CAP_INSTALLED@" From 5978717fa378c503c2a987b493468c532214bbdd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 30 Aug 2011 14:34:47 -0600 Subject: [PATCH 048/235] use closesocket() etc. for scheme_close_socket_fd() --- src/racket/src/network.c | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/src/racket/src/network.c b/src/racket/src/network.c index 3c2c6af94a..a5233b3e7d 100644 --- a/src/racket/src/network.c +++ b/src/racket/src/network.c @@ -2514,32 +2514,32 @@ void scheme_socket_to_ports(intptr_t s, const char *name, int takeover, } intptr_t scheme_dup_socket(intptr_t fd) { -#ifdef USE_WINSOCK_TCP +#ifdef USE_SOCKETS_TCP +# ifdef USE_WINSOCK_TCP intptr_t nsocket; WSAPROTOCOL_INFO protocolInfo; WSADuplicateSocket(fd, GetCurrentProcessId(), &protocolInfo); nsocket = WSASocket(FROM_PROTOCOL_INFO, FROM_PROTOCOL_INFO, FROM_PROTOCOL_INFO, &protocolInfo, 0, WSA_FLAG_OVERLAPPED); + REGISTER_SOCKET(nsocket); return nsocket; -#else +# else intptr_t nfd; do { nfd = dup(fd); } while (nfd == -1 && errno == EINTR); return nfd; +# endif +#else + return -1; #endif } -void scheme_close_socket_fd(intptr_t fd) { -# ifdef USE_WINSOCK_TCP - close(fd); -# else - { - intptr_t rc; - do { - rc = close(fd); - } while (rc == -1 && errno == EINTR); - } -# endif +void scheme_close_socket_fd(intptr_t fd) +{ +#ifdef USE_SOCKETS_TCP + UNREGISTER_SOCKET(fd); + closesocket(fd); +#endif } /*========================================================================*/ From d75aaa3c0e8abe111adf36ef7914ab00e576a870 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 31 Aug 2011 06:37:37 -0600 Subject: [PATCH 049/235] fix printed form of place channels --- src/racket/src/type.c | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/racket/src/type.c b/src/racket/src/type.c index 98f1bbb915..2c4d588850 100644 --- a/src/racket/src/type.c +++ b/src/racket/src/type.c @@ -297,12 +297,13 @@ scheme_init_type () set_name(_scheme_values_types_, ""); set_name(_scheme_compiled_values_types_, ""); + set_name(scheme_place_type, ""); + set_name(scheme_place_async_channel_type, ""); + set_name(scheme_place_bi_channel_type, ""); + #ifdef MZ_GC_BACKTRACE set_name(scheme_rt_meta_cont, ""); #endif - set_name(scheme_place_type, ""); - set_name(scheme_place_async_channel_type, ""); - set_name(scheme_place_bi_channel_type, ""); } Scheme_Type scheme_make_type(const char *name) From d8c04a7d57249963c1e581447d48a1943d12798b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 31 Aug 2011 09:48:26 -0600 Subject: [PATCH 050/235] try to fix bundle script for new "cache.rktd" format --- collects/meta/build/bundle | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/collects/meta/build/bundle b/collects/meta/build/bundle index c7e080a1ea..5f6c5119fa 100755 --- a/collects/meta/build/bundle +++ b/collects/meta/build/bundle @@ -5,6 +5,7 @@ (require racket/cmdline racket/runtime-path racket/match racket/promise racket/list ; for use in specs too + racket/string racket/file (only-in racket/system system) (except-in racket/mpair mappend) meta/checker (prefix-in dist: meta/dist-specs) meta/specs) @@ -239,7 +240,13 @@ (let* ([collects (or (tree-filter "/racket/collects/" (car trees)) (error 'make-info-domain "got no collects in tree"))] [info (filter (lambda (x) - (let ([x (path->string (bytes->path (car x)))]) + (define p (car x)) + (unless (and (list? p) + ((length p) . >= . 2) + (eq? 'info (car p)) + (andmap bytes? (cdr p))) + (error 'bundle "unexpected path form in cache.rktd: ~e" p)) + (let ([x (string-join (map bytes->string/utf-8 (cdr p)) "/")]) (pair? (tree-filter (concat "/racket/collects/" x) collects)))) *info-domain-cache*)]) From 145828527f2665bac77c3bc97de618759e6060e3 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Wed, 31 Aug 2011 11:09:38 -0500 Subject: [PATCH 051/235] Fixes handling of pattern variables that look like metafunctions --- .../redex/private/reduction-semantics.rkt | 11 +++++---- .../redex/private/rewrite-side-conditions.rkt | 3 +-- .../judgment-form-definition.rktd | 24 +++++++++++++++++++ collects/redex/tests/tl-test.rkt | 13 ++++++++++ 4 files changed, 45 insertions(+), 6 deletions(-) diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt index d82651e81e..f59b444e8f 100644 --- a/collects/redex/private/reduction-semantics.rkt +++ b/collects/redex/private/reduction-semantics.rkt @@ -1895,15 +1895,18 @@ (loop (cdr rest-modes) rest-terms rest-ctcs (+ 1 pos))))))) (define-for-syntax (mode-check mode clauses nts syn-err-name) - (define ((check-template named-vars) temp bound) + (define ((check-template bound-anywhere) temp bound) (let check ([t temp]) (syntax-case t (unquote) [(unquote . _) (raise-syntax-error syn-err-name "unquote unsupported" t)] [x (identifier? #'x) - (when (and (or (id-binds? nts #t #'x) (free-id-table-ref named-vars #'x #f)) - (not (free-id-table-ref bound #'x #f))) + (unless (cond [(free-id-table-ref bound-anywhere #'x #f) + (free-id-table-ref bound #'x #f)] + [(id-binds? nts #t #'x) + (term-fn? (syntax-local-value #'x (λ () #f)))] + [else #t]) (raise-syntax-error syn-err-name "unbound pattern variable" #'x))] [(u ...) (for-each check (syntax->list #'(u ...)))] @@ -1956,7 +1959,7 @@ (for ([clause clauses]) (define do-tmpl (check-template - (fold-clause (bind 'name-only) void (make-immutable-free-id-table) clause))) + (fold-clause (bind 'rhs-only) void (make-immutable-free-id-table) clause))) (fold-clause (bind 'rhs-only) do-tmpl (make-immutable-free-id-table) clause))) ;; Defined as a macro instead of an ordinary phase 1 function so that the diff --git a/collects/redex/private/rewrite-side-conditions.rkt b/collects/redex/private/rewrite-side-conditions.rkt index 577402c8a5..57d0413ea6 100644 --- a/collects/redex/private/rewrite-side-conditions.rkt +++ b/collects/redex/private/rewrite-side-conditions.rkt @@ -161,8 +161,7 @@ (and (identifier? (syntax x)) ((case mode [(rhs-only) binds-in-right-hand-side?] - [(binds-anywhere) binds?] - [(name-only) (λ (_1 _2 _3) #f)]) + [(binds-anywhere) binds?]) all-nts bind-names? (syntax x))) (cons (make-id/depth (syntax x) depth) names)] [else names]))] diff --git a/collects/redex/tests/syn-err-tests/judgment-form-definition.rktd b/collects/redex/tests/syn-err-tests/judgment-form-definition.rktd index 1cb8d0d51a..284564f050 100644 --- a/collects/redex/tests/syn-err-tests/judgment-form-definition.rktd +++ b/collects/redex/tests/syn-err-tests/judgment-form-definition.rktd @@ -182,4 +182,28 @@ #:mode (name I) [(name binder) premise ellipsis]) + (void))) + +(#rx"unbound pattern variable" + ([x f_7]) + (let () + (define-language L + (f any)) + (define-judgment-form L + #:mode (J1 O) + [(J1 x)]) + (void))) + +(#rx"unbound pattern variable" + ([use f_2]) ([outer-def f_2] [inner-def f_2]) + (let () + (define-language L + (f any)) + (define-metafunction L + [(outer-def) ()]) + (define-judgment-form L + #:mode (K I I O) + [(K a any_1 x) + (K b (use) (name inner-def any))] + [(K b any K-b-out)]) (void))) \ No newline at end of file diff --git a/collects/redex/tests/tl-test.rkt b/collects/redex/tests/tl-test.rkt index 9b31935a95..6a9ab71b79 100644 --- a/collects/redex/tests/tl-test.rkt +++ b/collects/redex/tests/tl-test.rkt @@ -1822,6 +1822,19 @@ (judgment-holds (R a any)))) 'a) '(a b))) + + ; a call to a metafunction that looks like a pattern variable + (let () + (define result 'result) + (define-language L + (f any)) + (define-judgment-form L + #:mode (J O) + [(J (f_2))]) + (define-metafunction L + [(f_2) ,result]) + (test (judgment-holds (J any) any) + (list result))) ; ; From 36219c4b93b9a7cb87fc9c5f0118edab2adeab43 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 31 Aug 2011 11:58:37 -0400 Subject: [PATCH 052/235] Use reference implementation for srfi/11. Closes PR 12147. --- collects/srfi/11.rkt | 73 ++++++++++++++++++++++++- collects/tests/srfi/11/srfi-11-test.rkt | 9 +++ collects/tests/srfi/all-srfi-tests.rkt | 56 +++++++++---------- collects/tests/srfi/load-srfis.rktl | 1 + 4 files changed, 109 insertions(+), 30 deletions(-) create mode 100644 collects/tests/srfi/11/srfi-11-test.rkt diff --git a/collects/srfi/11.rkt b/collects/srfi/11.rkt index 2762552933..fdb915219f 100644 --- a/collects/srfi/11.rkt +++ b/collects/srfi/11.rkt @@ -1,3 +1,72 @@ -;; Supported by core PLT: -#lang scheme/base +;; The versions from `racket/base' don't support rest args. + +#| + +Modified to use `syntax-parse' and multiple macros by Sam +Tobin-Hochstadt, 2011. + +The original: + +Copyright (C) Lars T Hansen (1999). All Rights Reserved. + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation +files (the "Software"), to deal in the Software without restriction, +including without limitation the rights to use, copy, modify, merge, +publish, distribute, sublicense, and/or sell copies of the Software, +and to permit persons to whom the Software is furnished to do so, +subject to the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +|# + +#lang racket/base +(require (for-syntax racket/base syntax/parse)) + +(define-syntax let-values + (syntax-parser + ((let-values (?binding ...) ?body0 ?body1 ...) + #'(let-values/bind (?binding ...) () (begin ?body0 ?body1 ...))))) + +(define-syntax let-values/bind + (syntax-parser + ((let-values/bind () ?tmps ?body) + #'(let ?tmps ?body)) + ((let-values/bind ((?b0 ?e0) ?binding ...) ?tmps ?body) + #'(let-values/mktmp ?b0 ?e0 () (?binding ...) ?tmps ?body)))) + +(define-syntax let-values/mktmp + (syntax-parser + ((let-values/mktmp () ?e0 ?args ?bindings ?tmps ?body) + #'(call-with-values + (lambda () ?e0) + (lambda ?args + (let-values/bind ?bindings ?tmps ?body)))) + + ((let-values/mktmp (?a . ?b) ?e0 (?arg ...) ?bindings (?tmp ...) ?body) + #'(let-values/mktmp ?b ?e0 (?arg ... x) ?bindings (?tmp ... (?a x)) ?body)) + + ((let-values/mktmp ?a ?e0 (?arg ...) ?bindings (?tmp ...) ?body) + #'(call-with-values (lambda () ?e0) + (lambda (?arg ... . x) + (let-values/bind ?bindings (?tmp ... (?a x)) ?body)))))) + +(define-syntax let*-values + (syntax-parser + ((let*-values () ?body0 ?body1 ...) + #'(begin ?body0 ?body1 ...)) + + ((let*-values (?binding0 ?binding1 ...) ?body0 ?body1 ...) + #'(let-values (?binding0) + (let*-values (?binding1 ...) ?body0 ?body1 ...))))) + (provide let-values let*-values) diff --git a/collects/tests/srfi/11/srfi-11-test.rkt b/collects/tests/srfi/11/srfi-11-test.rkt new file mode 100644 index 0000000000..9d5c69996e --- /dev/null +++ b/collects/tests/srfi/11/srfi-11-test.rkt @@ -0,0 +1,9 @@ +#lang racket/base + +(require srfi/11 rackunit) +(provide srfi-11-tests) + +(define srfi-11-tests + (test-suite + "Tests for SRFI 11" + (check-equal? (let-values ((x (values 1 2 3))) x) '(1 2 3) "PR 12147"))) diff --git a/collects/tests/srfi/all-srfi-tests.rkt b/collects/tests/srfi/all-srfi-tests.rkt index 12933bf9cd..8c171119d6 100644 --- a/collects/tests/srfi/all-srfi-tests.rkt +++ b/collects/tests/srfi/all-srfi-tests.rkt @@ -1,28 +1,28 @@ -(module all-srfi-tests mzscheme - - (require rackunit) - (require "1/all-1-tests.rkt" - "2/and-let-test.rkt" - "4/srfi-4-test.rkt" - "13/string-test.rkt" - "14/char-set-test.rkt" - "26/cut-test.rkt" - "40/all-srfi-40-tests.rkt" - "43/all-srfi-43-tests.rkt" - "69/hash-tests.rkt") - (provide all-srfi-tests) - - (define all-srfi-tests - (test-suite - "all-srfi-tests" - all-1-tests - and-let*-tests - string-tests - char-set-tests - cut-tests - all-srfi-40-tests - all-srfi-43-tests - hash-tests - srfi-4-tests - )) - ) +#lang racket/base +(require rackunit) +(require "1/all-1-tests.rkt" + "2/and-let-test.rkt" + "4/srfi-4-test.rkt" + "11/srfi-11-test.rkt" + "13/string-test.rkt" + "14/char-set-test.rkt" + "26/cut-test.rkt" + "40/all-srfi-40-tests.rkt" + "43/all-srfi-43-tests.rkt" + "69/hash-tests.rkt") +(provide all-srfi-tests) + +(define all-srfi-tests + (test-suite + "all-srfi-tests" + all-1-tests + and-let*-tests + string-tests + char-set-tests + cut-tests + all-srfi-40-tests + all-srfi-43-tests + hash-tests + srfi-4-tests + srfi-11-tests + )) diff --git a/collects/tests/srfi/load-srfis.rktl b/collects/tests/srfi/load-srfis.rktl index 26c7bf11b8..011e9344fe 100644 --- a/collects/tests/srfi/load-srfis.rktl +++ b/collects/tests/srfi/load-srfis.rktl @@ -10,6 +10,7 @@ (require srfi/7) (require srfi/8) (require srfi/9) +(require srfi/11) (require srfi/13) (require srfi/14) (require srfi/17) From 166efdd2ecd52c291d7f860d7117ec85cf39f707 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 31 Aug 2011 12:18:12 -0400 Subject: [PATCH 053/235] Move interactive helpers away from prims.rkt. --- collects/typed-scheme/base-env/prims.rkt | 35 ++---------------------- collects/typed-scheme/core.rkt | 26 +++++++++++++++++- 2 files changed, 28 insertions(+), 33 deletions(-) diff --git a/collects/typed-scheme/base-env/prims.rkt b/collects/typed-scheme/base-env/prims.rkt index 57ad6f505b..e5762a3830 100644 --- a/collects/typed-scheme/base-env/prims.rkt +++ b/collects/typed-scheme/base-env/prims.rkt @@ -37,7 +37,6 @@ This file defines two sorts of primitives. All of them are provided into any mod racket/flonum ; for for/flvector and for*/flvector mzlib/etc (for-syntax - racket/match syntax/parse racket/syntax racket/base @@ -51,9 +50,6 @@ This file defines two sorts of primitives. All of them are provided into any mod "../env/type-name-env.rkt" "../private/type-contract.rkt" "for-clauses.rkt" - "../tc-setup.rkt" - "../typecheck/tc-toplevel.rkt" - "../typecheck/tc-app-helper.rkt" "../types/utils.rkt") "../types/numeric-predicates.rkt") (provide index?) ; useful for assert, and racket doesn't have it @@ -173,36 +169,11 @@ This file defines two sorts of primitives. All of them are provided into any mod #,(internal #'(require/typed-internal name (Any -> Boolean : ty))))])) (define-syntax (:type stx) - (syntax-parse stx - [(_ ty:expr) - #`(display #,(format "~a\n" (parse-type #'ty)))])) - -;; Prints the _entire_ type. May be quite large. + (error ":type is only valid at the top-level of an interaction")) (define-syntax (:print-type stx) - (syntax-parse stx - [(_ e:expr) - #`(display #,(format "~a\n" - (tc-setup #'stx #'e 'top-level expanded tc-toplevel-form type - (match type - [(tc-result1: t f o) t] - [(tc-results: t) (cons 'Values t)]))))])) - -;; given a function and a desired return type, fill in the blanks + (error ":print-type is only valid at the top-level of an interaction")) (define-syntax (:query-result-type stx) - (syntax-parse stx - [(_ op:expr desired-type:expr) - (let ([expected (parse-type #'desired-type)]) - (tc-setup #'stx #'op 'top-level expanded tc-toplevel-form type - (match type - [(tc-result1: (and t (Function: _)) f o) - (let ([cleaned (cleanup-type t expected)]) - #`(display - #,(match cleaned - [(Function: '()) - "Desired return type not in the given function's range."] - [(Function: arrs) - (format "~a\n" cleaned)])))] - [_ (error (format "~a: not a function" (syntax->datum #'op) ))])))])) + (error ":query-result-type is only valid at the top-level of an interaction")) (define-syntax (require/opaque-type stx) (define-syntax-class name-exists-kw diff --git a/collects/typed-scheme/core.rkt b/collects/typed-scheme/core.rkt index deab5b85fd..a49ed44cd6 100644 --- a/collects/typed-scheme/core.rkt +++ b/collects/typed-scheme/core.rkt @@ -3,7 +3,7 @@ (require (rename-in "utils/utils.rkt" [infer r:infer]) (for-syntax racket/base) (for-template racket/base) - (private with-types type-contract) + (private with-types type-contract parse-type) (except-in syntax/parse id) racket/match racket/syntax unstable/match racket/list (types utils convenience) @@ -11,6 +11,7 @@ (env type-name-env type-alias-env) (r:infer infer) (rep type-rep) + (for-template (only-in (base-env prims) :type :print-type :query-result-type)) (except-in (utils utils tc-utils arm) infer) (only-in (r:infer infer-dummy) infer-param) "tc-setup.rkt") @@ -52,6 +53,29 @@ (syntax-parse stx [(_ . ((~datum module) . rest)) #'(module . rest)] + [(_ . ((~literal :type) ty:expr)) + #`(display #,(format "~a\n" (parse-type #'ty)))] + ;; Prints the _entire_ type. May be quite large. + [(_ . ((~literal :print-type) e:expr)) + #`(display #,(format "~a\n" + (tc-setup #'stx #'e 'top-level expanded tc-toplevel-form type + (match type + [(tc-result1: t f o) t] + [(tc-results: t) (cons 'Values t)]))))] + ;; given a function and a desired return type, fill in the blanks + [(_ . ((~literal :query-result-type) op:expr desired-type:expr)) + (let ([expected (parse-type #'desired-type)]) + (tc-setup #'stx #'op 'top-level expanded tc-toplevel-form type + (match type + [(tc-result1: (and t (Function: _)) f o) + (let ([cleaned (cleanup-type t expected)]) + #`(display + #,(match cleaned + [(Function: '()) + "Desired return type not in the given function's range."] + [(Function: arrs) + (format "~a\n" cleaned)])))] + [_ (error (format "~a: not a function" (syntax->datum #'op) ))])))] [(_ . form) (tc-setup stx #'form 'top-level body2 tc-toplevel-form type From 0449c3b397a6f77723c5d649a0320f3ca8c8737c Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 31 Aug 2011 12:30:36 -0400 Subject: [PATCH 054/235] Remove useless requires. --- collects/typed-scheme/core.rkt | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/collects/typed-scheme/core.rkt b/collects/typed-scheme/core.rkt index a49ed44cd6..97ba666916 100644 --- a/collects/typed-scheme/core.rkt +++ b/collects/typed-scheme/core.rkt @@ -1,19 +1,16 @@ #lang racket/base -(require (rename-in "utils/utils.rkt" [infer r:infer]) +(require (rename-in "utils/utils.rkt") (for-syntax racket/base) (for-template racket/base) (private with-types type-contract parse-type) (except-in syntax/parse id) racket/match racket/syntax unstable/match racket/list (types utils convenience) - (typecheck typechecker provide-handling tc-toplevel tc-app-helper) - (env type-name-env type-alias-env) - (r:infer infer) + (typecheck provide-handling tc-toplevel tc-app-helper) (rep type-rep) (for-template (only-in (base-env prims) :type :print-type :query-result-type)) - (except-in (utils utils tc-utils arm) infer) - (only-in (r:infer infer-dummy) infer-param) + (utils utils tc-utils arm) "tc-setup.rkt") (provide mb-core ti-core wt-core) From 8dbb879b0fcc1858034b09840163560213c36671 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 31 Aug 2011 13:03:23 -0500 Subject: [PATCH 055/235] adjust timeout for planet tests to 2x the number of seconds it takes to run on my (slowish) laptop --- collects/meta/props | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/meta/props b/collects/meta/props index a47747ed78..c3d80495b9 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1566,7 +1566,7 @@ path/s is either such a string or a list of them. "collects/tests/planet/examples/dummy-module.rkt" drdr:command-line #f "collects/tests/planet/examples/scribblings-package" drdr:command-line #f "collects/tests/planet/lang.rkt" drdr:command-line (raco "make" *) -"collects/tests/planet/run-all.rkt" drdr:command-line (racket *) drdr:timeout 8000 +"collects/tests/planet/run-all.rkt" drdr:command-line (racket *) drdr:timeout 240 "collects/tests/planet/test-docs-complete.rkt" drdr:command-line (raco "make" *) "collects/tests/planet/thread-safe-resolver.rkt" drdr:command-line (raco "make" *) drdr:timeout 1000 "collects/tests/planet/version.rkt" drdr:command-line (raco "make" *) From b105093f61163cd1be12e27ed8e459976fcfea20 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 31 Aug 2011 14:19:16 -0400 Subject: [PATCH 056/235] Fix the Compiled-Non-Module-Expression type. Closes PR 12150. --- collects/typed-scheme/types/abbrev.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-scheme/types/abbrev.rkt index 8e107d2bd3..a8bccb7720 100644 --- a/collects/typed-scheme/types/abbrev.rkt +++ b/collects/typed-scheme/types/abbrev.rkt @@ -164,7 +164,7 @@ (make-Base 'Compiled-Non-Module-Expression #'(and/c compiled-expression? (not/c compiled-module-expression?)) (conjoin compiled-expression? (negate compiled-module-expression?)) - #'-CompiledExpression)) + #'-Compiled-Non-Module-Expression)) (define -Compiled-Expression (*Un -Compiled-Module-Expression -Compiled-Non-Module-Expression)) (define -Prompt-Tag (make-Base 'Prompt-Tag #'continuation-prompt-tag? continuation-prompt-tag? #'-Prompt-Tag)) (define -Cont-Mark-Set (make-Base 'Continuation-Mark-Set #'continuation-mark-set? continuation-mark-set? #'-Cont-Mark-Set)) From d028b63a08388ca19d97f612e9e982f2fbea4225 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 31 Aug 2011 15:53:10 -0400 Subject: [PATCH 057/235] Fix flag name in raco exe docs. --- collects/scribblings/raco/exe.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/raco/exe.scrbl b/collects/scribblings/raco/exe.scrbl index 71fa170e8f..cb2d6f6f0e 100644 --- a/collects/scribblings/raco/exe.scrbl +++ b/collects/scribblings/raco/exe.scrbl @@ -37,7 +37,7 @@ Library modules or other files that are referenced dynamically---through @racket[eval], @racket[load], or @racket[dynamic-require]---are not automatically embedded into the created executable. Such modules can be explicitly included using the -@DFlag{lib} flag to @exec{raco exe}. Alternately, use +@exec{++lib} flag to @exec{raco exe}. Alternately, use @racket[define-runtime-path] to embed references to the run-time files in the executable; the files are then copied and packaged together with the executable when creating a distribution (as described in From 168291c89df4a3311a382208cec71dd727117307 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 31 Aug 2011 16:53:29 -0400 Subject: [PATCH 058/235] Use the right Scribble form for flags. --- collects/scribblings/raco/exe.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/raco/exe.scrbl b/collects/scribblings/raco/exe.scrbl index cb2d6f6f0e..2d02b26628 100644 --- a/collects/scribblings/raco/exe.scrbl +++ b/collects/scribblings/raco/exe.scrbl @@ -37,7 +37,7 @@ Library modules or other files that are referenced dynamically---through @racket[eval], @racket[load], or @racket[dynamic-require]---are not automatically embedded into the created executable. Such modules can be explicitly included using the -@exec{++lib} flag to @exec{raco exe}. Alternately, use +@DPFlag{lib} flag to @exec{raco exe}. Alternately, use @racket[define-runtime-path] to embed references to the run-time files in the executable; the files are then copied and packaged together with the executable when creating a distribution (as described in From bdee3509b7df692ffcbf1d9f4d9fe9dec38d39e2 Mon Sep 17 00:00:00 2001 From: John Griffin Date: Wed, 31 Aug 2011 14:24:25 -0500 Subject: [PATCH 059/235] adjust debugger to print smaller version of values to improve performance --- collects/gui-debugger/debug-tool.rkt | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/collects/gui-debugger/debug-tool.rkt b/collects/gui-debugger/debug-tool.rkt index cc4757977d..b55144723d 100644 --- a/collects/gui-debugger/debug-tool.rkt +++ b/collects/gui-debugger/debug-tool.rkt @@ -132,6 +132,10 @@ (> size (vector-length v))) '... (truncate-value (vector-ref v i) size (sub1 depth)))))] + [(bytes? v) + (if (> (bytes-length v) size) + (subbytes v 0 size) + v)] [else v])) (define filename->defs @@ -1141,7 +1145,7 @@ (for-each (lambda (name/value) (let ([name (format "~a" (syntax-e (first name/value)))] - [value (format " => ~s\n" (second name/value))]) + [value (format " => ~s\n" (truncate-value (second name/value) 100 5))]) (send variables-text insert name) (send variables-text change-style bold-sd (- (send variables-text last-position) (string-length name)) From fb4ae5d83d563c925e2924e9f41abb7c95185d01 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 31 Aug 2011 17:35:31 -0500 Subject: [PATCH 060/235] add some ellipses to the debugger value truncation --- collects/gui-debugger/debug-tool.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/gui-debugger/debug-tool.rkt b/collects/gui-debugger/debug-tool.rkt index b55144723d..0ca426e48e 100644 --- a/collects/gui-debugger/debug-tool.rkt +++ b/collects/gui-debugger/debug-tool.rkt @@ -134,7 +134,7 @@ (truncate-value (vector-ref v i) size (sub1 depth)))))] [(bytes? v) (if (> (bytes-length v) size) - (subbytes v 0 size) + (bytes-append (subbytes v 0 size) #"...") v)] [else v])) From a98fd7f60b6fd481bf5874c2db59a025063ab971 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 31 Aug 2011 19:04:14 -0500 Subject: [PATCH 061/235] fixed a leak in the compile locking protocol implementation and added better logging --- collects/compiler/cm.rkt | 50 ++++++++++++++++++++-------------------- 1 file changed, 25 insertions(+), 25 deletions(-) diff --git a/collects/compiler/cm.rkt b/collects/compiler/cm.rkt index 480e751ed4..36364fa35b 100644 --- a/collects/compiler/cm.rkt +++ b/collects/compiler/cm.rkt @@ -694,30 +694,36 @@ (define zo-path (list-ref req 1)) (define response-manager-side (list-ref req 2)) (define died-chan-manager-side (list-ref req 3)) + (define compilation-thread-id (list-ref req 4)) (case command [(lock) (cond [(hash-ref currently-locked-files zo-path #f) + (log-info (format "compile-lock: ~s ~a already locked" zo-path compilation-thread-id)) (set! pending-requests (cons (pending response-manager-side zo-path died-chan-manager-side) pending-requests)) (loop)] [else + (log-info (format "compile-lock: ~s ~a obtained lock" zo-path compilation-thread-id)) (hash-set! currently-locked-files zo-path #t) (place-channel-put response-manager-side #t) (set! running-compiles (cons (running zo-path died-chan-manager-side) running-compiles)) (loop)])] [(unlock) - (define (same-bytes? pending) (equal? (pending-zo-path pending) zo-path)) - (define to-unlock (filter same-bytes? pending-requests)) - (set! pending-requests (filter (compose not same-bytes?) pending-requests)) + (log-info (format "compile-lock: ~s ~a unlocked" zo-path compilation-thread-id)) + (define (same-pending-zo-path? pending) (equal? (pending-zo-path pending) zo-path)) + (define to-unlock (filter same-pending-zo-path? pending-requests)) + (set! pending-requests (filter (compose not same-pending-zo-path?) pending-requests)) (for ([pending (in-list to-unlock)]) (place-channel-put (pending-response-chan pending) #f)) (hash-remove! currently-locked-files zo-path) + (set! running-compiles (filter (λ (a-running) (not (equal? (running-zo-path a-running) zo-path))) + running-compiles)) (loop)]))) (for/list ([running-compile (in-list running-compiles)]) (handle-evt (running-died-chan-manager-side running-compile) - (λ (_) + (λ (compilation-thread-id) (define zo-path (running-zo-path running-compile)) (set! running-compiles (remove running-compile running-compiles)) (define same-zo-pending @@ -725,9 +731,11 @@ pending-requests)) (cond [(null? same-zo-pending) - (hash-set! currently-locked-files zo-path #f) + (log-info (format "compile-lock: ~s ~a died; no else waiting" zo-path compilation-thread-id)) + (hash-remove! currently-locked-files zo-path) (loop)] [else + (log-info (format "compile-lock: ~s ~a died; someone else waiting" zo-path compilation-thread-id)) (define to-be-running (car same-zo-pending)) (set! pending-requests (remq to-be-running pending-requests)) (place-channel-put (pending-response-chan to-be-running) #t) @@ -743,44 +751,33 @@ (define add-monitor-chan (make-channel)) (define kill-monitor-chan (make-channel)) - (define (clean-up-hash) - (for ([key+val (in-list (hash-map monitor-threads list))]) - (define key (list-ref key+val 0)) - (define val (list-ref key+val 1)) - (unless (weak-box-value val) - (hash-remove! monitor-threads key)))) - (when custodian (parameterize ([current-custodian custodian]) (thread (λ () (let loop () (sync - (if (zero? (hash-count monitor-threads)) - never-evt - (handle-evt (alarm-evt (+ (current-inexact-milliseconds) 500)) - (λ (arg) - (clean-up-hash) - (loop)))) (handle-evt add-monitor-chan (λ (arg) (define-values (zo-path monitor-thread) (apply values arg)) - (hash-set! monitor-threads zo-path (make-weak-box monitor-thread)) - (clean-up-hash) + (hash-set! monitor-threads zo-path monitor-thread) (loop))) (handle-evt kill-monitor-chan (λ (zo-path) - (define thd/f (weak-box-value (hash-ref monitor-threads zo-path))) + (define thd/f (hash-ref monitor-threads zo-path #f)) (when thd/f (kill-thread thd/f)) (hash-remove! monitor-threads zo-path) - (clean-up-hash) (loop))))))))) (λ (command zo-path) + (define compiling-thread (current-thread)) (define-values (response-builder-side response-manager-side) (place-channel)) (define-values (died-chan-compiling-side died-chan-manager-side) (place-channel)) - (place-channel-put build-side-chan (list command zo-path response-manager-side died-chan-manager-side)) - (define compiling-thread (current-thread)) + (place-channel-put build-side-chan (list command + zo-path + response-manager-side + died-chan-manager-side + (eq-hash-code compiling-thread))) (cond [(eq? command 'lock) (define monitor-thread @@ -789,7 +786,10 @@ (thread (λ () (thread-wait compiling-thread) - (place-channel-put died-chan-compiling-side 'dead)))))) + ;; compiling thread died; alert the server + ;; & remove this thread from the table + (place-channel-put died-chan-compiling-side (eq-hash-code compiling-thread)) + (channel-put kill-monitor-chan zo-path)))))) (when monitor-thread (channel-put add-monitor-chan (list zo-path monitor-thread))) (define res (place-channel-get response-builder-side)) (when monitor-thread From fd5019ddea08153befd665c51a1a2ec045d8233f Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 31 Aug 2011 20:26:31 -0500 Subject: [PATCH 062/235] added one more log line --- collects/drracket/private/expanding-place.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/drracket/private/expanding-place.rkt b/collects/drracket/private/expanding-place.rkt index ec4e805a2f..d4b302a417 100644 --- a/collects/drracket/private/expanding-place.rkt +++ b/collects/drracket/private/expanding-place.rkt @@ -44,6 +44,7 @@ (define (abort-job job) (custodian-shutdown-all (job-cust job)) + (log-info "expanding-place.rkt: kill") (place-channel-put (job-response-pc job) #f)) (struct exn:access exn:fail ()) From 93e1b634a381d4648bb1c2645aeefeeb623eb7ce Mon Sep 17 00:00:00 2001 From: James Ian Johnson Date: Tue, 30 Aug 2011 14:42:32 -0400 Subject: [PATCH 063/235] Added let and define forms that generalize let-values, let*-values and define-values --- collects/racket/match/define-forms.rkt | 79 +++++++++++++++++----- collects/racket/match/legacy-match.rkt | 3 +- collects/racket/match/match.rkt | 3 +- collects/scribblings/reference/match.scrbl | 24 ++++++- 4 files changed, 87 insertions(+), 22 deletions(-) diff --git a/collects/racket/match/define-forms.rkt b/collects/racket/match/define-forms.rkt index 608ba1c735..4671724b82 100644 --- a/collects/racket/match/define-forms.rkt +++ b/collects/racket/match/define-forms.rkt @@ -2,6 +2,7 @@ (require (for-syntax scheme/base racket/syntax + (only-in racket/list append* append-map) unstable/sequence syntax/parse "parse.rkt" @@ -12,20 +13,22 @@ (provide define-forms) (define-syntax-rule (define-forms parse-id - match match* match-lambda match-lambda* - match-lambda** match-let match-let* - match-define match-letrec + match match* match-lambda match-lambda* + match-lambda** match-let match-let* + match-let-values match-let*-values + match-define match-define-values match-letrec match/derived match*/derived) (... (begin (provide match match* match-lambda match-lambda* match-lambda** - match-let match-let* match-define match-letrec - match/derived match*/derived) + match-let match-let* match-let-values match-let*-values + match-define match-define-values match-letrec + match/derived match*/derived match-define-values) (define-syntax (match* stx) (syntax-parse stx [(_ es . clauses) (go parse-id stx #'es #'clauses)])) - + (define-syntax (match*/derived stx) (syntax-parse stx [(_ es orig-stx . clauses) @@ -35,7 +38,7 @@ (syntax-parse stx [(_ arg:expr clauses ...) (go/one parse-id stx #'arg #'(clauses ...))])) - + (define-syntax (match/derived stx) (syntax-parse stx [(_ arg:expr orig-stx clauses ...) @@ -47,14 +50,14 @@ (with-syntax* ([arg (generate-temporary)] [body #`(match/derived arg #,stx . clauses)]) (syntax/loc stx (lambda (arg) body)))])) - + (define-syntax (match-lambda* stx) (syntax-parse stx [(_ . clauses) (with-syntax* ([arg (generate-temporary)] [body #`(match/derived arg #,stx . clauses)]) (syntax/loc stx (lambda arg body)))])) - + (define-syntax (match-lambda** stx) (syntax-parse stx [(_ (~and clauses [(pats ...) . rhs]) ...) @@ -64,17 +67,17 @@ ;; there's lots of duplication here to handle named let ;; some factoring out would do a lot of good - (define-syntax (match-let stx) + (define-syntax (match-let stx) (syntax-parse stx [(_ nm:id (~and clauses ([pat init-exp:expr] ...)) body1 body ...) (with-syntax* ([vars (generate-temporaries #'(pat ...))] - [loop-body #`(match*/derived vars #,stx + [loop-body #`(match*/derived vars #,stx [(pat ...) (let () body1 body ...)])]) #'(letrec ([nm (lambda vars loop-body)]) (nm init-exp ...)))] [(_ (~and clauses ([pat init-exp:expr] ...)) body1 body ...) - #`(match*/derived (init-exp ...) #,stx + #`(match*/derived (init-exp ...) #,stx [(pat ...) (let () body1 body ...)])])) (define-syntax (match-let* stx) @@ -82,17 +85,43 @@ [(_ () body1 body ...) #'(let () body1 body ...)] [(_ ([pat exp] rest-pats ...) body1 body ...) - #`(match*/derived + #`(match*/derived (exp) #,stx - [(pat) #,(syntax/loc stx (match-let* (rest-pats ...) + [(pat) #,(syntax/loc stx (match-let* (rest-pats ...) body1 body ...))])])) + (define-syntax (match-let-values stx) + (syntax-parse stx + [(_ (~and clauses ([(patses ...) rhses:expr] ...)) body1 body ...) + (define-values (let-clauses match-clauses) + (for/lists (let-clauses match-clauses) + ([pats (syntax->list #'((patses ...) ...))] + [rhs (syntax->list #'(rhses ...))]) + (with-syntax ([(pats ...) pats] + [(ids ...) (generate-temporaries pats)]) + (values #`[(ids ...) #,rhs] + #`([pats ids] ...))))) + #`(let-values #,let-clauses + #,(quasisyntax/loc stx + (match-let #,(append-map syntax->list match-clauses) + (let () body1 body ...))))])) + + (define-syntax (match-let*-values stx) + (syntax-parse stx + [(_ () body1 body ...) + #'(let () body1 body ...)] + [(_ ([pats rhs] rest-pats ...) body1 body ...) + #`(match-let-values ([pats rhs]) + #,(syntax/loc stx (match-let*-values (rest-pats ...) + body1 body ...)))])) + + (define-syntax (match-letrec stx) (syntax-parse stx [(_ ((~and cl [pat exp]) ...) body1 body ...) (quasisyntax/loc stx - (let () + (let () #,@(for/list ([c (in-syntax #'(cl ...))] [p (in-syntax #'(pat ...))] [e (in-syntax #'(exp ...))]) @@ -100,10 +129,26 @@ body1 body ...))])) (define-syntax (match-define stx) - (syntax-parse stx + (syntax-parse stx [(_ pat rhs:expr) (let ([p (parse-id #'pat)]) (with-syntax ([vars (bound-vars p)]) (quasisyntax/loc stx (define-values vars (match*/derived (rhs) #,stx - [(pat) (values . vars)])))))]))))) + [(pat) (values . vars)])))))])) + + (define-syntax (match-define-values stx) + (syntax-parse stx + [(_ (pats ...) rhs:expr) + (define ppats (map parse-id (syntax->list #'(pats ...)))) + (define bound-vars-list (map bound-vars ppats)) + (with-syntax ([(ids ...) (generate-temporaries #'(pats ...))] + [(pat-vars ...) bound-vars-list] + [vars (append* bound-vars-list)]) + (quasisyntax/loc stx + (define-values vars + (let-values ([(ids ...) rhs]) + (apply values + (append + (match*/derived (ids) #,stx + [(pats) (list . pat-vars)]) ...))))))]))))) diff --git a/collects/racket/match/legacy-match.rkt b/collects/racket/match/legacy-match.rkt index b9abbfd220..c30ee7c8fe 100644 --- a/collects/racket/match/legacy-match.rkt +++ b/collects/racket/match/legacy-match.rkt @@ -17,4 +17,5 @@ (define-forms parse/legacy match match* match-lambda match-lambda* match-lambda** match-let match-let* - match-define match-letrec match/derived match*/derived) + match-let-values match-let*-values + match-define match-define-values match-letrec match/derived match*/derived) diff --git a/collects/racket/match/match.rkt b/collects/racket/match/match.rkt index edb5761519..5951422d0c 100644 --- a/collects/racket/match/match.rkt +++ b/collects/racket/match/match.rkt @@ -19,4 +19,5 @@ (define-forms parse match match* match-lambda match-lambda* match-lambda** match-let match-let* - match-define match-letrec match/derived match*/derived) + match-let-values match-let*-values + match-define match-define-values match-letrec match/derived match*/derived) diff --git a/collects/scribblings/reference/match.scrbl b/collects/scribblings/reference/match.scrbl index b5e653f50b..99380f8d3b 100644 --- a/collects/scribblings/reference/match.scrbl +++ b/collects/scribblings/reference/match.scrbl @@ -339,7 +339,7 @@ In more detail, patterns match as follows: @racket[quasiquote] expression form, @racketidfont{unquote} and @racketidfont{unquote-splicing} escape back to normal patterns. - + @examples[ #:eval match-eval (match '(1 2 3) @@ -360,7 +360,7 @@ In more detail, patterns match as follows: [(pat ...+) (=> id) body ...+]])]{ Matches a sequence of values against each clause in order, matching only when all patterns in a clause match. Each clause must have the -same number of patterns as the number of @racket[val-expr]s. +same number of patterns as the number of @racket[val-expr]s. @examples[#:eval match-eval (match* (1 2 3) @@ -413,6 +413,14 @@ bindings of each @racket[pat] are available in each subsequent x) ]} +@defform[(match-let-values ([(pat ...) expr] ...) body ...+)]{ + +Like @racket[match-let], but generalizes @racket[let-values].} + +@defform[(match-let*-values ([(pat ...) expr] ...) body ...+)]{ + +Like @racket[match-let*], but generalizes @racket[let*-values].} + @defform[(match-letrec ([pat expr] ...) body ...+)]{ Like @racket[match-let], but generalizes @racket[letrec].} @@ -429,6 +437,16 @@ matching against the result of @racket[expr]. b ]} +@defform[(match-define-values (pat ...) expr)]{ + +Like @racket[match-define] but for when expr produces multiple values. + +@examples[ +#:eval match-eval +(match-define-values (a b) (values 1 2)) +b +]} + @; ---------------------------------------- @defproc[(exn:misc:match? [v any/c]) boolean?]{ @@ -465,7 +483,7 @@ whether multiple uses of an identifier match the ``same'' value. The default is @racket[equal?].} @deftogether[[@defform[(match/derived val-expr original-datum clause ...)] - @defform[(match*/derived (val-expr ...) original-datum clause* ...)]]]{ + @defform[(match*/derived (val-expr ...) original-datum clause* ...)]]]{ Like @racket[match] and @racket[match*] respectively, but includes a sub-expression to be used as the source for all syntax errors within the form. For example, @racket[match-lambda] expands to @racket[match/derived] so that From dc61372f3c01e7d8e6fc881de2113de8e69f1674 Mon Sep 17 00:00:00 2001 From: James Ian Johnson Date: Tue, 30 Aug 2011 19:23:36 -0400 Subject: [PATCH 064/235] Implemented Sam's suggested changes for new forms, and added a new match/values form. --- collects/racket/match/define-forms.rkt | 110 ++++---- collects/racket/match/legacy-match.rkt | 2 +- collects/racket/match/match.rkt | 2 +- collects/scribblings/reference/match.scrbl | 7 + collects/tests/match/examples.rkt | 286 +++++++++++---------- 5 files changed, 228 insertions(+), 179 deletions(-) diff --git a/collects/racket/match/define-forms.rkt b/collects/racket/match/define-forms.rkt index 4671724b82..ec6e1fd758 100644 --- a/collects/racket/match/define-forms.rkt +++ b/collects/racket/match/define-forms.rkt @@ -12,18 +12,42 @@ (provide define-forms) +;; each pat matches a value in a multi-valued expression +(define-for-syntax (match-values-clause->let-clause pats rhs) + (with-syntax ([(pats ...) pats] + [(ids ...) (generate-temporaries pats)]) + ;; rhs evaluates to number of ids values. + ;; patterns should match against each id. + (values #'(ids ...) + #`[(ids ...) #,rhs]))) + +(define-for-syntax (match-values-clauses->let-clauses patses rhses) + (for/lists (idses let-clauses) + ([pats (syntax->list patses)] + [rhs (syntax->list rhses)]) + (match-values-clause->let-clause pats rhs))) + +(define-for-syntax (all-same-length stx-listses) + (let loop ([listses (syntax->list stx-listses)] + [the-length #f]) + (cond [(null? listses) #t] + [the-length + (and (= the-length (length (syntax->list (car listses)))) + (loop (cdr listses) the-length))] + [else (loop (cdr listses) (length (syntax->list (car listses))))]))) + (define-syntax-rule (define-forms parse-id match match* match-lambda match-lambda* match-lambda** match-let match-let* match-let-values match-let*-values match-define match-define-values match-letrec - match/derived match*/derived) + match/values match/derived match*/derived) (... (begin (provide match match* match-lambda match-lambda* match-lambda** match-let match-let* match-let-values match-let*-values match-define match-define-values match-letrec - match/derived match*/derived match-define-values) + match/values match/derived match*/derived match-define-values) (define-syntax (match* stx) (syntax-parse stx [(_ es . clauses) @@ -44,6 +68,16 @@ [(_ arg:expr orig-stx clauses ...) (go/one parse-id #'orig-stx #'arg #'(clauses ...))])) + (define-syntax (match/values stx) + (syntax-parse stx + [(_ arg:expr [(pats ...) rhs:expr] [(patses ...) rhses:expr] ...) + #:fail-unless (all-same-length #'((pats ...) (patses ...) ...)) + "All clauses must have the same number of patterns" + (define-values (ids let-clause) + (match-values-clause->let-clause #'(pats ...) #'rhs)) + #`(let-values ([#,ids arg]) + (match*/derived #,ids #,stx [(pats ...) rhs] [(patses ...) rhses] ...))])) + (define-syntax (match-lambda stx) (syntax-parse stx [(_ . clauses) @@ -65,6 +99,29 @@ [body #`(match*/derived vars #,stx clauses ...)]) (syntax/loc stx (lambda vars body)))])) + + (define-syntax (match-let-values stx) + (syntax-parse stx + [(_ (~and clauses ([(patses ...) rhses:expr] ...)) body1 body ...) + (define-values (idses let-clauses) + (match-values-clauses->let-clauses #'((patses ...) ...) #'(rhses ...))) + #`(let-values #,let-clauses + (match*/derived #,(append-map syntax->list idses) #,stx + [(patses ... ...) + (let () body1 body ...)]))])) + + (define-syntax (match-let*-values stx) + (syntax-parse stx + [(_ () body1 body ...) + #'(let () body1 body ...)] + [(_ ([(pats ...) rhs] rest-pats ...) body1 body ...) + (define-values (ids let-clause) + (match-values-clause->let-clause #'(pats ...) #'rhs)) + #`(let-values (#,let-clause) + (match*/derived #,ids #,stx + [(pats ...) #,(syntax/loc stx (match-let*-values (rest-pats ...) + body1 body ...))]))])) + ;; there's lots of duplication here to handle named let ;; some factoring out would do a lot of good (define-syntax (match-let stx) @@ -76,46 +133,11 @@ [(pat ...) (let () body1 body ...)])]) #'(letrec ([nm (lambda vars loop-body)]) (nm init-exp ...)))] - [(_ (~and clauses ([pat init-exp:expr] ...)) body1 body ...) - #`(match*/derived (init-exp ...) #,stx - [(pat ...) (let () body1 body ...)])])) - - (define-syntax (match-let* stx) - (syntax-parse stx - [(_ () body1 body ...) - #'(let () body1 body ...)] - [(_ ([pat exp] rest-pats ...) body1 body ...) - #`(match*/derived - (exp) - #,stx - [(pat) #,(syntax/loc stx (match-let* (rest-pats ...) - body1 body ...))])])) - - (define-syntax (match-let-values stx) - (syntax-parse stx - [(_ (~and clauses ([(patses ...) rhses:expr] ...)) body1 body ...) - (define-values (let-clauses match-clauses) - (for/lists (let-clauses match-clauses) - ([pats (syntax->list #'((patses ...) ...))] - [rhs (syntax->list #'(rhses ...))]) - (with-syntax ([(pats ...) pats] - [(ids ...) (generate-temporaries pats)]) - (values #`[(ids ...) #,rhs] - #`([pats ids] ...))))) - #`(let-values #,let-clauses - #,(quasisyntax/loc stx - (match-let #,(append-map syntax->list match-clauses) - (let () body1 body ...))))])) - - (define-syntax (match-let*-values stx) - (syntax-parse stx - [(_ () body1 body ...) - #'(let () body1 body ...)] - [(_ ([pats rhs] rest-pats ...) body1 body ...) - #`(match-let-values ([pats rhs]) - #,(syntax/loc stx (match-let*-values (rest-pats ...) - body1 body ...)))])) + [(_ ([pat init-exp:expr] ...) body1 body ...) + #`(match-let-values ([(pat) init-exp] ...) body1 body ...)])) + (define-syntax-rule (match-let* ([pat exp] ...) body1 body ...) + (match-let*-values ([(pat) exp] ...) body1 body ...)) (define-syntax (match-letrec stx) (syntax-parse stx @@ -149,6 +171,6 @@ (define-values vars (let-values ([(ids ...) rhs]) (apply values - (append - (match*/derived (ids) #,stx - [(pats) (list . pat-vars)]) ...))))))]))))) + (append + (match*/derived (ids) #,stx + [(pats) (list . pat-vars)]) ...))))))]))))) diff --git a/collects/racket/match/legacy-match.rkt b/collects/racket/match/legacy-match.rkt index c30ee7c8fe..e607fbd2b8 100644 --- a/collects/racket/match/legacy-match.rkt +++ b/collects/racket/match/legacy-match.rkt @@ -18,4 +18,4 @@ (define-forms parse/legacy match match* match-lambda match-lambda* match-lambda** match-let match-let* match-let-values match-let*-values - match-define match-define-values match-letrec match/derived match*/derived) + match-define match-define-values match-letrec match/values match/derived match*/derived) diff --git a/collects/racket/match/match.rkt b/collects/racket/match/match.rkt index 5951422d0c..345b66ea5c 100644 --- a/collects/racket/match/match.rkt +++ b/collects/racket/match/match.rkt @@ -20,4 +20,4 @@ (define-forms parse match match* match-lambda match-lambda* match-lambda** match-let match-let* match-let-values match-let*-values - match-define match-define-values match-letrec match/derived match*/derived) + match-define match-define-values match-letrec match/values match/derived match*/derived) diff --git a/collects/scribblings/reference/match.scrbl b/collects/scribblings/reference/match.scrbl index 99380f8d3b..ff4a96ca4a 100644 --- a/collects/scribblings/reference/match.scrbl +++ b/collects/scribblings/reference/match.scrbl @@ -368,6 +368,13 @@ same number of patterns as the number of @racket[val-expr]s. ] } +@defform[(match/values expr clause clause ...)]{ +If @racket[expr] evaluates to @racket[n] values, then match all @racket[n] +values against the patterns in @racket[clause ...]. Each clause must contain +exactly @racket[n] patterns. At least one clause is required to determine how +many values to expect from @racket[expr]. +} + @defform[(match-lambda clause ...)]{ Equivalent to @racket[(lambda (id) (match id clause ...))]. diff --git a/collects/tests/match/examples.rkt b/collects/tests/match/examples.rkt index d7f2ad870a..e26d375315 100644 --- a/collects/tests/match/examples.rkt +++ b/collects/tests/match/examples.rkt @@ -1,6 +1,6 @@ #lang scheme/base -(require scheme/match +(require scheme/match scheme/mpair scheme/control scheme/foreign (for-syntax scheme/base) @@ -54,10 +54,10 @@ (provide new-tests) (define new-tests - (test-suite + (test-suite "new tests for match" - - (comp + + (comp 1 (match (list 1 2 3) [(list x ...) (=> unmatch) @@ -66,26 +66,26 @@ (error 'bad)) 0)] [_ 1])) - - (comp + + (comp '(1 2 3) (match (vector 1 2 3) [(vector (? number? x) ...) x] [_ 2])) - + (comp 2 (match (vector 'a 1 2 3) [(vector (? number? x) ...) x] [_ 2])) - + (comp 3 (match (list 'a 1 2 3) [(vector (? number? x) ...) x] [_ 3])) - - + + (comp -1 (match (vector 1 2 3) [(or (list x) x) -1] @@ -94,7 +94,7 @@ [(vector a b) 2] [(vector a b c) 3] [(box _) 4])) - + (comp 12 (match (list 12 12) [(list x x) x] @@ -103,8 +103,8 @@ (match (list 1 0) [(list x x) x] [_ 13])) - - + + (comp 6 (let () @@ -123,84 +123,84 @@ [(cons x y) (+ x y)] [_ 0]))) - + (comp 6 (match (make-X 1 2 3) [(X: a b c) (+ a b c)])) - - - (comp + + + (comp '(6 3 100 6) (list (f (cons 1 2) (cons 3 4)) (f (box 1) (box 2)) (f (list 10 20 30) (list 40)) (f (vector 1 2 3) (vector 4)))) - + (comp '(one (2 num) bool neither) (list (g 1) (g 2) (g #f) (g "foo"))) - + (comp (split (list (list 1 2) (list 'a 'b) (list 'x 'y))) '((1 a x) (2 b y))) (comp (split2 (list (list 1 2) (list 'a 'b) (list 'x 'y))) '((1 a) (2 b) (x y))) - + (comp 'yes (match (list (box 2) 2) [(list (or (box x) (list x)) x) 'yes] [_ 'no])) - + (comp 'no (parameterize ([match-equality-test eq?]) (match (list (cons 1 1) (cons 1 1)) [(list x x) 'yes] [_ 'no]))) - + (comp 'no (match (list (box 2) 3) [(list (or (box x) (list x)) x) 'yes] [_ 'no])) - + (comp 2 (match (list 'one 'three) [(list 'one 'two) 1] [(list 'one 'three) 2] [(list 'two 'three) 3])) - (comp + (comp 2 (match (list 'one 'three) [(cons 'one (cons 'two '())) 1] [(cons 'one (cons 'three '())) 2] [(cons 'two (cons 'three '())) 3])) - + (comp 'yes (match '(1 x 2 y 3 z) [(list-no-order 1 2 3 'x 'y 'z) 'yes] [_ 'no])) - + ;; NOT WORKING YET (comp '(x y z) (match '(1 x 2 y 3 z) [(list-no-order 1 2 3 r1 r2 r3) (list r1 r2 r3)] [_ 'no])) - + (comp '(x y z) (match '(1 x 2 y 3 z) [(list-no-order 1 2 3 rest ...) rest] [_ 'no])) - + (comp 'yes (match '(a (c d)) @@ -209,18 +209,18 @@ (list-no-order 'c 'd))) 'yes] [_ 'no])) - - - (comp + + + (comp '((1 2) (a b 1 2)) (let () (define-syntax-rule (match-lambda . cl) (lambda (e) (match e . cl))) - + (define (make-nil) '()) (define nil? null?) - + (define make-:: (match-lambda ((list-no-order (list '|1| a) (list '|2| d)) @@ -229,7 +229,7 @@ (define (::-content p) (list (list '|1| (car p)) (list '|2| (cdr p)))) - + (define my-append (match-lambda ((list-no-order (list '|1| (? nil?)) @@ -245,11 +245,11 @@ (list (my-append (list (list '|1| '()) (list '|2| '(1 2)))) - + (my-append (list (list '|1| '(a b)) (list '|2| '(1 2))))))) - - + + (comp 'yes (match @@ -260,63 +260,63 @@ (cons '|2| (cdr p))))) (hash-table ('|1| _) ('|2| _))))) 'yes] [_ 'no])) - + ;; examples from docs - + (comp 'yes (match '(1 2 3) [(list (not 4) ...) 'yes] [_ 'no])) - + (comp 'no (match '(1 4 3) [(list (not 4) ...) 'yes] [_ 'no])) - + (comp 1 (match '(1 2) [(or (list a 1) (list a 2)) a] [_ 'bad])) - + (comp '(2 3) - (match '(1 (2 3) 4) + (match '(1 (2 3) 4) [(list _ (and a (list _ ...)) _) a] [_ 'bad])) - - - - (comp + + + + (comp 'yes (match "apple" [(regexp #rx"p+(.)" (list _ "l")) 'yes] [_ 'no])) - (comp + (comp 'no (match "append" [(regexp #rx"p+(.)" (list _ "l")) 'yes] [_ 'no])) - - - (comp + + + (comp 'yes (match "apple" [(regexp #rx"p+" ) 'yes] [_ 'no])) - (comp + (comp 'no (match "banana" [(regexp #rx"p+") 'yes] [_ 'no])) - - (comp + + (comp '(0 1) (let () (define-struct tree (val left right)) - - (match (make-tree 0 (make-tree 1 #f #f) #f) + + (match (make-tree 0 (make-tree 1 #f #f) #f) [(struct tree (a (struct tree (b _ _)) _)) (list a b)] [_ 'no]))) - + (comp 1 (match #&1 [(box a) a] @@ -325,120 +325,120 @@ (match #hasheq(("a" . 1) ("b" . 2)) [(hash-table ("b" b) ("a" a)) (list b a)] [_ 'no])) - + (comp #t (andmap string? (match #hasheq(("b" . 2) ("a" . 1)) [(hash-table (key val) ...) key] [_ 'no]))) - + (comp (match #(1 (2) (2) (2) 5) [(vector 1 (list a) ..3 5) a] [_ 'no]) '(2 2 2)) - + (comp '(1 3 4 5) - (match '(1 2 3 4 5 6) + (match '(1 2 3 4 5 6) [(list-no-order 6 2 y ...) y] [_ 'no])) - + (comp 1 - (match '(1 2 3) + (match '(1 2 3) [(list-no-order 3 2 x) x])) (comp '((1 2 3) 4) - (match '(1 2 3 . 4) + (match '(1 2 3 . 4) [(list-rest a ... d) (list a d)])) - + (comp 4 (match '(1 2 3 . 4) [(list-rest a b c d) d])) - + ;; different behavior from the way match used to be (comp '(2 3 4) (match '(1 2 3 4 5) - [(list 1 a ..3 5) a] + [(list 1 a ..3 5) a] [_ 'else])) - + (comp '((1 2 3 4) ()) (match (list 1 2 3 4 5) [(list x ... y ... 5) (list x y)] [_ 'no])) - + (comp '((1 3 2) (4)) (match (list 1 3 2 3 4 5) [(list x ... 3 y ... 5) (list x y)] [_ 'no])) - + (comp '(3 2 1) (match '(1 2 3) [(list a b c) (list c b a)])) - + (comp '(2 3) (match '(1 2 3) [(list 1 a ...) a])) - + (comp 'else (match '(1 2 3) [(list 1 a ..3) a] [_ 'else])) - + (comp '(2 3 4) (match '(1 2 3 4) [(list 1 a ..3) a] [_ 'else])) - + (comp '(2 2 2) (match '(1 (2) (2) (2) 5) [(list 1 (list a) ..3 5) a] [_ 'else])) - + (comp #t (match "yes" ["yes" #t] ["no" #f])) - + (comp 3 (match '(1 2 3) [(list _ _ a) a])) (comp '(3 2 1) - (match '(1 2 3) - [(list a b a) (list a b)] + (match '(1 2 3) + [(list a b a) (list a b)] [(list a b c) (list c b a)])) - + (comp '(2 '(x y z) 1) - (match '(1 '(x y z) 2) - [(list a b a) (list a b)] + (match '(1 '(x y z) 2) + [(list a b a) (list a b)] [(list a b c) (list c b a)])) - + (comp '(1 '(x y z)) - (match '(1 '(x y z) 1) - [(list a b a) (list a b)] + (match '(1 '(x y z) 1) + [(list a b a) (list a b)] [(list a b c) (list c b a)])) - + (comp '(2 3) (match '(1 2 3) [`(1 ,a ,(? odd? b)) (list a b)])) - + (comp '(2 1 (1 2 3 4)) - (match-let ([(list a b) '(1 2)] - [(vector x ...) #(1 2 3 4)]) + (match-let ([(list a b) '(1 2)] + [(vector x ...) #(1 2 3 4)]) (list b a x))) - - - + + + (comp '(1 2 3 4) - (match-let* ([(list a b) '(#(1 2 3 4) 2)] - [(vector x ...) a]) + (match-let* ([(list a b) '(#(1 2 3 4) 2)] + [(vector x ...) a]) x)) - + (comp 2 (let () (match-define (list a b) '(1 2)) b)) - + (comp 'yes (match '(number_1 . number_2) [`(variable-except ,@(list vars ...)) @@ -446,7 +446,7 @@ [(? list?) 'no] [_ 'yes])) - + (comp "yes" (match '((555)) @@ -454,7 +454,7 @@ (list-no-order 555))) "yes") (_ "no"))) ;; prints "no" - + (comp "yes" (match '((555)) @@ -462,7 +462,7 @@ (list 555))) "yes") (_ "no"))) ;; prints "yes" - + (comp "yes" (match '((555)) @@ -470,36 +470,36 @@ (list-no-order 555))) "yes") (_ "no"))) ;; prints "yes" - + (comp '("a") (match "a" ((regexp #rx"a" x) x))) - (comp '(#"a") + (comp '(#"a") (match #"a" ((regexp #rx"a" x) x) [_ 'no])) - + (comp 'yes (match #"a" (#"a" 'yes))) - + (comp 'yes (with-handlers ([exn:fail:syntax? (lambda _ 'yes)]) (expand #'(match-lambda ((a ?) #f))) 'no)) (comp 'yes (with-handlers ([exn:fail:syntax? (lambda _ 'yes)]) (expand #'(match-lambda ((?) #f))) 'no)) - + (comp 'yes (let () - + (m:define-match-expander exp1 #:plt-match (lambda (stx) (syntax-case stx () ((_match (x y)) #'(list (list x y)))))) - + (m:define-match-expander exp2 #:plt-match (lambda (stx) (syntax-case stx () ((_match x y) #'(exp1 (x y)))))) - + (define (test tp) (match tp ((exp2 x y) x))) 'yes)) @@ -510,28 +510,28 @@ (let () (define (foo x) (match x [1 (+ x x)])) (foo 1))) - - + + (comp 'yes (match (make-empt) [(struct empt ()) 'yes] [_ 'no])) - + (comp 'yes (m:match (make-empt) [($ empt) 'yes] [_ 'no])) - + (comp 3 (match (mcons 1 2) [(mcons a b) (+ a b)] [_ 'no])) - + (comp 3 (match (mlist 1 2) [(mlist a b) (+ a b)] [_ 'no])) - + (comp 3 (match (mlist 1 2) [(mlist a ...) (apply + a)] @@ -539,7 +539,7 @@ (comp 1 (match (box 'x) ('#&x 1) (else #f))) - + (comp 2 (match (vector 1 2) ('#(1 2) 2) (else #f))) @@ -548,7 +548,7 @@ [values (lambda _ 'no)]) (match 1) 'no)) - + (comp 'yes (with-handlers ([exn:fail:syntax? (lambda _ 'yes)] [values (lambda _ 'no)]) @@ -560,49 +560,49 @@ 0)))) ;; raises error - (comp 'yes (with-handlers ([exn:fail:syntax? (lambda _ 'yes)]) + (comp 'yes (with-handlers ([exn:fail:syntax? (lambda _ 'yes)]) (expand (quote-syntax (match '(1 x 2 y 3 z) [(list-no-order 1 2 3 rest ... e) rest] [_ 'no]))) 'no)) - (comp '((2 4) (2 1)) + (comp '((2 4) (2 1)) (match '(3 2 4 3 2 1) - [(list x y ... x z ...) + [(list x y ... x z ...) (list y z)])) (comp '(1 2) (match-let ([(vector a b) (vector 1 2)]) (list a b))) - + (comp '(4 5) (let-values ([(x y) (match 1 [(or (and x 2) (and x 3) (and x 4)) 3] [_ (values 4 5)])]) (list x y))) - + (comp 'bad - (match #(1) + (match #(1) [(vector a b) a] [else 'bad])) (comp '(1 2) - (call-with-values - (lambda () + (call-with-values + (lambda () (match 'foo [_ (=> skip) (skip)] [_ (values 1 2)])) list)) (comp 0 (let ([z (make-parameter 0)]) (match 1 - [(? number?) (=> f) (parameterize ([z 1]) (f))] + [(? number?) (=> f) (parameterize ([z 1]) (f))] [(? number?) (z)]))) - + ;; make sure the prompts don't interfere (comp 12 (% (let ([z (make-parameter 0)]) (match 1 - [(? number?) (=> f) (parameterize ([z 1]) (fcontrol 5))] + [(? number?) (=> f) (parameterize ([z 1]) (fcontrol 5))] [(? number?) (z)])) (lambda _ 12))) @@ -611,7 +611,7 @@ (match 3 [(or) 1] [_ 4])) - + (comp '((1 2) 3) (match `(begin 1 2 3) [`(begin ,es ... ,en) @@ -619,14 +619,14 @@ (comp '(a b c) (let () - + (define-struct foo (a b c) #:prefab) (match (make-foo 'a 'b 'c) [`#s(foo ,x ,y ,z) (list x y z)]))) (comp '(a b c) (let () - + (define-struct foo (a b c) #:prefab) (define-struct (bar foo) (d) #:prefab) (match (make-bar 'a 'b 'c 1) @@ -639,11 +639,11 @@ ([x _double*] [y _double*] [a _double*])) - + (match (make-pose 1 2 3) [(struct pose (x y a)) "Gotcha!"] [else "Epic fail!"]))) - + (comp #f (match (list 'a 'b 'c) [(or (list a b) @@ -653,17 +653,17 @@ (list a)))) #t] [_ #f])) - + (comp '(2 7) (let () (define-match-expander foo (syntax-rules () [(_) 1]) - (syntax-id-rules (set!) + (syntax-id-rules (set!) [(set! _ v) v] [(_) 2])) (list (foo) (set! foo 7)))) - + (comp 0 (let () (define-match-expander foo @@ -672,4 +672,24 @@ [(foo) 0] [_ 1]))) + (comp '(1 2 4) + (call-with-values + (λ () (match-let-values ([(x y) (values 1 2)] [(3 w) (values 3 4)]) + (list x y w))) + list)) + + (comp '(1 3 4) + (call-with-values + (λ () (match-let*-values ([(x y) (values 1 2)] [(y w) (values 3 4)]) + (list x y w))) + list)) + + (comp '(1 2 3) + (match/values (values 1 2 3) + [(x y z) (list x y z)])) + + (comp '(1 2) + (let () (match-define-values (x y 3) (values 1 2 3)) + (list x y))) + )) From 3f23a67d578547a4a7aaebcde4fb6c167a9667d4 Mon Sep 17 00:00:00 2001 From: James Ian Johnson Date: Wed, 31 Aug 2011 11:45:28 -0400 Subject: [PATCH 065/235] Fixed the duplicate identifier bug in match-define-values and changed identifiers to conform to naming conventions. --- collects/racket/match/define-forms.rkt | 85 ++++++++-------------- collects/scribblings/reference/match.scrbl | 4 +- collects/tests/match/examples.rkt | 4 +- 3 files changed, 34 insertions(+), 59 deletions(-) diff --git a/collects/racket/match/define-forms.rkt b/collects/racket/match/define-forms.rkt index ec6e1fd758..ff116d5134 100644 --- a/collects/racket/match/define-forms.rkt +++ b/collects/racket/match/define-forms.rkt @@ -2,7 +2,7 @@ (require (for-syntax scheme/base racket/syntax - (only-in racket/list append* append-map) + (only-in racket/list append* remove-duplicates) unstable/sequence syntax/parse "parse.rkt" @@ -12,30 +12,6 @@ (provide define-forms) -;; each pat matches a value in a multi-valued expression -(define-for-syntax (match-values-clause->let-clause pats rhs) - (with-syntax ([(pats ...) pats] - [(ids ...) (generate-temporaries pats)]) - ;; rhs evaluates to number of ids values. - ;; patterns should match against each id. - (values #'(ids ...) - #`[(ids ...) #,rhs]))) - -(define-for-syntax (match-values-clauses->let-clauses patses rhses) - (for/lists (idses let-clauses) - ([pats (syntax->list patses)] - [rhs (syntax->list rhses)]) - (match-values-clause->let-clause pats rhs))) - -(define-for-syntax (all-same-length stx-listses) - (let loop ([listses (syntax->list stx-listses)] - [the-length #f]) - (cond [(null? listses) #t] - [the-length - (and (= the-length (length (syntax->list (car listses)))) - (loop (cdr listses) the-length))] - [else (loop (cdr listses) (length (syntax->list (car listses))))]))) - (define-syntax-rule (define-forms parse-id match match* match-lambda match-lambda* match-lambda** match-let match-let* @@ -70,13 +46,10 @@ (define-syntax (match/values stx) (syntax-parse stx - [(_ arg:expr [(pats ...) rhs:expr] [(patses ...) rhses:expr] ...) - #:fail-unless (all-same-length #'((pats ...) (patses ...) ...)) - "All clauses must have the same number of patterns" - (define-values (ids let-clause) - (match-values-clause->let-clause #'(pats ...) #'rhs)) - #`(let-values ([#,ids arg]) - (match*/derived #,ids #,stx [(pats ...) rhs] [(patses ...) rhses] ...))])) + [(_ arg:expr [(pats ...) rhs:expr] [(patss ...) rhss:expr] ...) + (with-syntax ([(ids ...) (generate-temporaries #'(pats ...))]) + #`(let-values ([(ids ...) arg]) + (match*/derived (ids ...) #,stx [(pats ...) rhs] [(patss ...) rhss] ...)))])) (define-syntax (match-lambda stx) (syntax-parse stx @@ -102,25 +75,27 @@ (define-syntax (match-let-values stx) (syntax-parse stx - [(_ (~and clauses ([(patses ...) rhses:expr] ...)) body1 body ...) - (define-values (idses let-clauses) - (match-values-clauses->let-clauses #'((patses ...) ...) #'(rhses ...))) + [(_ (~and clauses ([(patss ...) rhss:expr] ...)) body1 body ...) + (define-values (idss let-clauses) + (for/lists (idss let-clauses) + ([pats (syntax->list #'((patss ...) ...))] + [rhs (syntax->list #'(rhss ...))]) + (define ids (generate-temporaries pats)) + (values ids #`[#,ids #,rhs]))) #`(let-values #,let-clauses - (match*/derived #,(append-map syntax->list idses) #,stx - [(patses ... ...) - (let () body1 body ...)]))])) + (match*/derived #,(append* idss) #,stx + [(patss ... ...) (let () body1 body ...)]))])) (define-syntax (match-let*-values stx) (syntax-parse stx [(_ () body1 body ...) #'(let () body1 body ...)] [(_ ([(pats ...) rhs] rest-pats ...) body1 body ...) - (define-values (ids let-clause) - (match-values-clause->let-clause #'(pats ...) #'rhs)) - #`(let-values (#,let-clause) - (match*/derived #,ids #,stx - [(pats ...) #,(syntax/loc stx (match-let*-values (rest-pats ...) - body1 body ...))]))])) + (with-syntax ([(ids ...) (generate-temporaries #'(pats ...))]) + #`(let-values ([(ids ...) rhs]) + (match*/derived (ids ...) #,stx + [(pats ...) #,(syntax/loc stx (match-let*-values (rest-pats ...) + body1 body ...))])))])) ;; there's lots of duplication here to handle named let ;; some factoring out would do a lot of good @@ -130,7 +105,7 @@ (with-syntax* ([vars (generate-temporaries #'(pat ...))] [loop-body #`(match*/derived vars #,stx - [(pat ...) (let () body1 body ...)])]) + [(pat ...) (let () body1 body ...)])]) #'(letrec ([nm (lambda vars loop-body)]) (nm init-exp ...)))] [(_ ([pat init-exp:expr] ...) body1 body ...) @@ -162,15 +137,13 @@ (define-syntax (match-define-values stx) (syntax-parse stx [(_ (pats ...) rhs:expr) - (define ppats (map parse-id (syntax->list #'(pats ...)))) - (define bound-vars-list (map bound-vars ppats)) - (with-syntax ([(ids ...) (generate-temporaries #'(pats ...))] - [(pat-vars ...) bound-vars-list] - [vars (append* bound-vars-list)]) + (define bound-vars-list (remove-duplicates + (foldr (λ (pat vars) + (append (bound-vars (parse-id pat)) vars)) + '() (syntax->list #'(pats ...))) + bound-identifier=?)) + (with-syntax ([(ids ...) (generate-temporaries #'(pats ...))]) (quasisyntax/loc stx - (define-values vars - (let-values ([(ids ...) rhs]) - (apply values - (append - (match*/derived (ids) #,stx - [(pats) (list . pat-vars)]) ...))))))]))))) + (define-values #,bound-vars-list + (match/values rhs + [(pats ...) (values . #,bound-vars-list)]))))]))))) diff --git a/collects/scribblings/reference/match.scrbl b/collects/scribblings/reference/match.scrbl index ff4a96ca4a..512874c58b 100644 --- a/collects/scribblings/reference/match.scrbl +++ b/collects/scribblings/reference/match.scrbl @@ -444,9 +444,11 @@ matching against the result of @racket[expr]. b ]} -@defform[(match-define-values (pat ...) expr)]{ +@defform[(match-define-values (pat pats ...) expr)]{ Like @racket[match-define] but for when expr produces multiple values. +Like match/values, it requires at least one pattern to determine the +number of values to expect. @examples[ #:eval match-eval diff --git a/collects/tests/match/examples.rkt b/collects/tests/match/examples.rkt index e26d375315..5ba01a0993 100644 --- a/collects/tests/match/examples.rkt +++ b/collects/tests/match/examples.rkt @@ -675,13 +675,13 @@ (comp '(1 2 4) (call-with-values (λ () (match-let-values ([(x y) (values 1 2)] [(3 w) (values 3 4)]) - (list x y w))) + (values x y w))) list)) (comp '(1 3 4) (call-with-values (λ () (match-let*-values ([(x y) (values 1 2)] [(y w) (values 3 4)]) - (list x y w))) + (values x y w))) list)) (comp '(1 2 3) From 216aee244f5c0fe826643618c3889d2ee83c5bb1 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 31 Aug 2011 22:14:09 -0500 Subject: [PATCH 066/235] adjust drracket so that it copies the definitions text before evaluating it this means that various things that try to color and otherwise show info by changing the way the editor looks no longer need to worry about whether it is locked and delay things in some complicated way. also, this means that users can edit while drracket is running the program which is hopefully less confusing. --- collects/drracket/private/syncheck/gui.rkt | 1 + collects/drracket/private/unit.rkt | 29 ++++++++-------------- 2 files changed, 11 insertions(+), 19 deletions(-) diff --git a/collects/drracket/private/syncheck/gui.rkt b/collects/drracket/private/syncheck/gui.rkt index 8555ecf944..5bdb6b7db1 100644 --- a/collects/drracket/private/syncheck/gui.rkt +++ b/collects/drracket/private/syncheck/gui.rkt @@ -1711,6 +1711,7 @@ If the namespace does not, they are colored the unbound color. (define module-language? (is-a? (drracket:language-configuration:language-settings-language settings) drracket:module-language:module-language<%>)) + (send definitions-text-copy set-style-list (send definitions-text get-style-list)) ;; speeds up the copy (send definitions-text copy-self-to definitions-text-copy) (with-lock/edit-sequence definitions-text-copy diff --git a/collects/drracket/private/unit.rkt b/collects/drracket/private/unit.rkt index 547643f8ea..a2565c26b4 100644 --- a/collects/drracket/private/unit.rkt +++ b/collects/drracket/private/unit.rkt @@ -1146,12 +1146,10 @@ module browser threading seems wrong. (define/public-final (set-i _i) (set! i _i)) (define/public (disable-evaluation) (set! enabled? #f) - (send defs lock #t) (send ints lock #t) (send frame disable-evaluation-in-tab this)) (define/public (enable-evaluation) (set! enabled? #t) - (send defs lock #f) (send ints lock #f) (send frame enable-evaluation-in-tab this)) (define/public (get-enabled) enabled?) @@ -2647,23 +2645,16 @@ module browser threading seems wrong. (send interactions-text reset-console) (send interactions-text clear-undos) - (let ([start 0]) - (send definitions-text split-snip start) - (let* ([name (send definitions-text get-port-name)] - [text-port (open-input-text-editor definitions-text start 'end values name #t)]) - (port-count-lines! text-port) - (let* ([line (send definitions-text position-paragraph start)] - [column (- start (send definitions-text paragraph-start-position line))] - [relocated-port (relocate-input-port text-port - (+ line 1) - column - (+ start 1))]) - (port-count-lines! relocated-port) - (send interactions-text evaluate-from-port - relocated-port - #t - (λ () - (send interactions-text clear-undos)))))))) + (define name (send definitions-text get-port-name)) + (define defs-copy (new text%)) + (send defs-copy set-style-list (send definitions-text get-style-list)) ;; speeds up the copy + (send definitions-text copy-self-to defs-copy) + (define text-port (open-input-text-editor defs-copy 0 'end values name #t)) + (send interactions-text evaluate-from-port + text-port + #t + (λ () + (send interactions-text clear-undos))))) (inherit revert save) (define/private (check-if-save-file-up-to-date) From 3c688f6a6805336ac2faf467806d1a893d99a0a4 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 1 Sep 2011 07:27:04 -0400 Subject: [PATCH 067/235] Start on Typed Racket release notes. --- doc/release-notes/typed-racket/HISTORY.txt | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 doc/release-notes/typed-racket/HISTORY.txt diff --git a/doc/release-notes/typed-racket/HISTORY.txt b/doc/release-notes/typed-racket/HISTORY.txt new file mode 100644 index 0000000000..015d098446 --- /dev/null +++ b/doc/release-notes/typed-racket/HISTORY.txt @@ -0,0 +1,4 @@ +5.1.3.* +- Performance work: delayed environment evaluation +- Support `racket'-style optional arguments +- Changes to support new-style keyword argument expansion From ff140d721cb2da3e08323892ac28e8d77bbc4a87 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 31 Aug 2011 10:28:59 -0600 Subject: [PATCH 068/235] remove doc for non-existent function --- collects/scribblings/reference/stx-trans.scrbl | 16 ---------------- 1 file changed, 16 deletions(-) diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index 71059b4780..0da27eea60 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -640,22 +640,6 @@ resulting identifier is @tech{tainted}. @transform-time[]} -@defproc[(syntax-local-armer) - ((syntax?) (any/c any/c) . ->* . syntax?)]{ - -Returns a procedure that captures the declaration-time code inspector -of the module in which a syntax transformer was bound (if a syntax -transformer is being applied) or the module being visited. The result -is a procedure like @racket[syntax-taint-arm], except that the -optional third argument is automatically the captured inspector. - -The @racket[syntax-local-armer] function is needed by -macro-generating macros, where a syntax object in the generated macro -needs to be protected using the code inspector of the generating -macro's module. - -@transform-time[]} - @defproc[(syntax-local-certifier [active? boolean? #f]) ((syntax?) (any/c (or/c procedure? #f)) . ->* . syntax?)]{ From e7ec9f5eb7c157fa3d9ab4c1dc87ee5be89611e4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 31 Aug 2011 10:29:12 -0600 Subject: [PATCH 069/235] document `scribble/pdf-render; --- collects/scribblings/scribble/renderer.scrbl | 21 ++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/collects/scribblings/scribble/renderer.scrbl b/collects/scribblings/scribble/renderer.scrbl index 2b59580fa2..56dfb2d17b 100644 --- a/collects/scribblings/scribble/renderer.scrbl +++ b/collects/scribblings/scribble/renderer.scrbl @@ -15,11 +15,17 @@ (intro))) @(begin - (define-syntax-rule (def-render-mixin id) + (define-syntax-rule (def-html-render-mixin id) (begin (require (for-label scribble/html-render)) (define id @racket[render-mixin]))) - (def-render-mixin html:render-mixin)) + (def-html-render-mixin html:render-mixin)) +@(begin + (define-syntax-rule (def-latex-render-mixin id) + (begin + (require (for-label scribble/latex-render)) + (define id @racket[render-mixin]))) + (def-latex-render-mixin latex:render-mixin)) @title[#:tag "renderer"]{Renderers} @@ -281,3 +287,14 @@ files.} @defmixin[render-mixin (render%) ()]{ Specializes a @racket[render%] class for generating Latex input.}} + +@; ---------------------------------------- + +@section{PDF Renderer} + +@defmodule/local[scribble/pdf-render]{ + +@defmixin[render-mixin (render%) ()]{ + +Specializes a @racket[render%] class for generating PDF output via +Latex, building on @|latex:render-mixin| from @racketmodname[scribble/latex-render].}} From c5588f87e33d913c9932c5ca5568764f0cac890c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 31 Aug 2011 19:29:55 -0600 Subject: [PATCH 070/235] fix mach-o updating --- collects/compiler/private/mach-o.rkt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/compiler/private/mach-o.rkt b/collects/compiler/private/mach-o.rkt index aee2b31617..45fe573a55 100644 --- a/collects/compiler/private/mach-o.rkt +++ b/collects/compiler/private/mach-o.rkt @@ -56,6 +56,7 @@ [link-edit-addr 0] [link-edit-offset 0] [link-edit-len 0] + [link-edit-vmlen 0] [dyld-info-pos #f] [dyld-info-offs #f]) ;; (printf "~a cmds, length 0x~x\n" cnt cmdssz) @@ -82,6 +83,7 @@ (set! link-edit-64? 64?) (set! link-edit-pos pos) (set! link-edit-addr vmaddr) + (set! link-edit-vmlen vmlen) (set! link-edit-offset offset) (set! link-edit-len len) (when (link-edit-len . < . 0) @@ -145,7 +147,7 @@ [out-offset (if move-link-edit? link-edit-offset (+ link-edit-offset (round-up-page link-edit-len)))] - [out-addr (+ link-edit-addr (round-up-page link-edit-len))]) + [out-addr (+ link-edit-addr (round-up-page link-edit-vmlen))]) (unless ((+ end-cmd new-cmd-sz) . < . min-used) (error 'check-header "no room for a new section load command (current end is ~a; min used is ~a)" From 3f11ef9b119b2afbd19afa1f35fc90dd2cfce527 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 1 Sep 2011 07:06:20 -0600 Subject: [PATCH 071/235] report some errors instead of potentially ignoring them --- collects/mred/private/wx/cocoa/queue.rkt | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 04614d67f1..42c848ed6f 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -89,8 +89,10 @@ (define-appserv TransformProcessType (_fun _ProcessSerialNumber-pointer _uint32 -> _OSStatus)) -(void (TransformProcessType (make-ProcessSerialNumber 0 kCurrentProcess) - kProcessTransformToForegroundApplication)) +(let ([v (TransformProcessType (make-ProcessSerialNumber 0 kCurrentProcess) + kProcessTransformToForegroundApplication)]) + (unless (zero? v) + (log-error (format "error from TransformProcessType: ~a" v)))) (define app-delegate (tell (tell MyApplicationDelegate alloc) init)) (tellv app setDelegate: app-delegate) @@ -108,8 +110,9 @@ (define-appserv CGDisplayRegisterReconfigurationCallback (_fun (_fun #:atomic? #t -> _void) _pointer -> _int32)) (define (on-screen-changed) (post-dummy-event)) -(void - (CGDisplayRegisterReconfigurationCallback on-screen-changed #f)) +(let ([v (CGDisplayRegisterReconfigurationCallback on-screen-changed #f)]) + (unless (zero? v) + (log-error (format "error from CGDisplayRegisterReconfigurationCallback: ~a" v)))) (tellv app finishLaunching) From 9d5f45a9d1ff254b2d677801ced48026f9948fa6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 1 Sep 2011 07:06:39 -0600 Subject: [PATCH 072/235] gtk: fix border (when requested) for canvas% with scrollbars --- collects/mred/private/wx/gtk/canvas.rkt | 3 ++- collects/mred/private/wx/gtk/panel.rkt | 18 ++++++++++-------- collects/mred/private/wx/gtk/window.rkt | 4 ++++ 3 files changed, 16 insertions(+), 9 deletions(-) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 0091e46230..abe4cff19c 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -280,7 +280,8 @@ (unless (eq? client-gtk container-gtk) (gtk_fixed_set_has_window client-gtk #t)) ; imposes clipping (when has-border? - (gtk_container_set_border_width h margin)) + (gtk_container_set_border_width h margin) + (connect-expose-border h)) (gtk_box_pack_start h v #t #t 0) (gtk_box_pack_start v client-gtk #t #t 0) (gtk_box_pack_start h v2 #f #f 0) diff --git a/collects/mred/private/wx/gtk/panel.rkt b/collects/mred/private/wx/gtk/panel.rkt index 566d601b8a..8fe82e7161 100644 --- a/collects/mred/private/wx/gtk/panel.rkt +++ b/collects/mred/private/wx/gtk/panel.rkt @@ -35,14 +35,16 @@ [gray #x8000]) (when gc (gdk_gc_set_rgb_fg_color gc (make-GdkColor 0 gray gray gray)) - (let ([a (widget-allocation gtk)] - [no-window? (not (zero? (bitwise-and (get-gtk-object-flags gtk) - GTK_NO_WINDOW)))]) - (gdk_draw_rectangle win gc #f - (if no-window? (GtkAllocation-x a) 0) - (if no-window? (GtkAllocation-y a) 0) - (sub1 (GtkAllocation-width a)) - (sub1 (GtkAllocation-height a)))) + (let* ([a (widget-allocation gtk)] + [w (sub1 (GtkAllocation-width a))] + [h (sub1 (GtkAllocation-height a))]) + (let loop ([gtk gtk] [x 0] [y 0]) + (if (not (zero? (bitwise-and (get-gtk-object-flags gtk) GTK_NO_WINDOW))) + ;; no window: + (let ([a (widget-allocation gtk)]) + (loop (widget-parent gtk) (+ x (GtkAllocation-x a)) (+ y (GtkAllocation-y a)))) + ;; found window: + (gdk_draw_rectangle win gc #f x y w h)))) (gdk_gc_unref gc))) #f)) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 9bbca2874f..ef2a9b2feb 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -42,6 +42,7 @@ widget-window widget-allocation + widget-parent the-accelerator-group gtk_window_add_accel_group @@ -105,6 +106,9 @@ (define (widget-window gtk) (GtkWidgetT-window (cast gtk _GtkWidget _GtkWidgetT-pointer))) +(define (widget-parent gtk) + (GtkWidgetT-parent (cast gtk _GtkWidget _GtkWidgetT-pointer))) + (define (widget-allocation gtk) (GtkWidgetT-alloc (cast gtk _GtkWidget _GtkWidgetT-pointer))) From 459d2422e3ad8383e2a580bef3ddf4c67c65867c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 1 Sep 2011 07:13:13 -0600 Subject: [PATCH 073/235] gtk: fix menu-item shortcut updating --- collects/mred/private/wx/gtk/menu.rkt | 41 ++++++++++++++------------- 1 file changed, 22 insertions(+), 19 deletions(-) diff --git a/collects/mred/private/wx/gtk/menu.rkt b/collects/mred/private/wx/gtk/menu.rkt index 7402c4bbc6..78f93bfee2 100644 --- a/collects/mred/private/wx/gtk/menu.rkt +++ b/collects/mred/private/wx/gtk/menu.rkt @@ -181,25 +181,27 @@ (unless (unbox cnb) (cb this e))))))) - (define/private (adjust-shortcut item-gtk title) + (define/private (adjust-shortcut item-gtk title need-clear?) (let ([m (regexp-match #rx"\t(Ctrl[+])?(Shift[+])?(Meta[+])?(Alt[+])?(.|[0-9]+)$" title)]) - (when m - (let ([mask (+ (if (list-ref m 1) GDK_CONTROL_MASK 0) - (if (list-ref m 2) GDK_SHIFT_MASK 0) - (if (list-ref m 3) GDK_MOD1_MASK 0) - (if (list-ref m 4) GDK_META_MASK 0))] - [code (let ([s (list-ref m 5)]) - (if (= 1 (string-length s)) - (gdk_unicode_to_keyval - (char->integer (string-ref s 0))) - (string->number s)))]) - (unless (zero? code) - (let ([accel-path (format "/Hardwired/~a" title)]) - (gtk_accel_map_add_entry accel-path - code - mask) - (gtk_menu_item_set_accel_path item-gtk accel-path))))))) + (if m + (let ([mask (+ (if (list-ref m 1) GDK_CONTROL_MASK 0) + (if (list-ref m 2) GDK_SHIFT_MASK 0) + (if (list-ref m 3) GDK_MOD1_MASK 0) + (if (list-ref m 4) GDK_META_MASK 0))] + [code (let ([s (list-ref m 5)]) + (if (= 1 (string-length s)) + (gdk_unicode_to_keyval + (char->integer (string-ref s 0))) + (string->number s)))]) + (unless (zero? code) + (let ([accel-path (format "/Hardwired/~a" title)]) + (gtk_accel_map_add_entry accel-path + code + mask) + (gtk_menu_item_set_accel_path item-gtk accel-path)))) + (when need-clear? + (gtk_menu_item_set_accel_path item-gtk #f))))) (public [append-item append]) (define (append-item i label help-str-or-submenu chckable?) @@ -226,7 +228,7 @@ [menu-item i] [parent this])]) (set! items (append items (list (list item item-gtk label chckable?)))) - (adjust-shortcut item-gtk label))) + (adjust-shortcut item-gtk label #f))) (gtk_menu_shell_append gtk item-gtk) (gtk_widget_show item-gtk)))) @@ -258,7 +260,8 @@ (let ([gtk (find-gtk item)]) (when gtk (gtk_label_set_text_with_mnemonic (gtk_bin_get_child gtk) - (fixup-mnemonic str))))) + (fixup-mnemonic str)) + (adjust-shortcut gtk str #t)))) (define/public (enable item on?) (let ([gtk (find-gtk item)]) From db0db9463e37db805d5692938749177464334018 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 1 Sep 2011 08:49:05 -0600 Subject: [PATCH 074/235] adjust -X handling to make `raco exe' work on Unix Closes PR 12151 --- collects/scribblings/reference/startup.scrbl | 7 ++++- src/racket/cmdline.inc | 27 ++++++++++++-------- 2 files changed, 23 insertions(+), 11 deletions(-) diff --git a/collects/scribblings/reference/startup.scrbl b/collects/scribblings/reference/startup.scrbl index fcca28afc8..c38310af17 100644 --- a/collects/scribblings/reference/startup.scrbl +++ b/collects/scribblings/reference/startup.scrbl @@ -242,7 +242,12 @@ flags: @item{@FlagFirst{X} @nonterm{dir} or @DFlagFirst{collects} @nonterm{dir} : Sets @nonterm{dir} as the path to the main collection of libraries by making @racket[(find-system-path - 'collects-dir)] produce @nonterm{dir}.} + 'collects-dir)] produce @nonterm{dir}. If @nonterm{dir} is an + empty string, then @racket[(find-system-path 'collects-dir)] + returns @filepath{.}, but + @racket[current-library-collection-paths] is initialized to + the empty list and @racket[use-collection-link-paths] is + initialized to @racket[#f].} @item{@FlagFirst{S} @nonterm{dir} or @DFlagFirst{search} @nonterm{dir} : Adds @nonterm{dir} to the default library diff --git a/src/racket/cmdline.inc b/src/racket/cmdline.inc index 8fd36f5f7a..3372ca2af3 100644 --- a/src/racket/cmdline.inc +++ b/src/racket/cmdline.inc @@ -860,7 +860,11 @@ static int run_from_cmd_line(int argc, char *_argv[], } argv++; --argc; - collects_path = check_make_path(prog, real_switch, argv[0]); + if (!*(argv[0])) { + /* #f => no collects path */ + collects_path = scheme_false; + } else + collects_path = check_make_path(prog, real_switch, argv[0]); was_config_flag = 1; break; case 'A': @@ -1175,16 +1179,19 @@ static int run_from_cmd_line(int argc, char *_argv[], #ifndef NO_FILE_SYSTEM_UTILS /* Setup path for "collects" collection directory: */ if (!collects_path) { - if (!_coldir[_coldir_offset]) { - /* empty list of directories => don't set collection dirs - and don't use collection links files */ - skip_coll_dirs = 1; - scheme_set_ignore_link_paths(1); - collects_path = scheme_make_path("."); - } else + if (!_coldir[_coldir_offset]) + collects_path = scheme_false; + else collects_path = scheme_make_path(_coldir XFORM_OK_PLUS _coldir_offset); - } else + } else if (!SCHEME_FALSEP(collects_path)) collects_path = scheme_path_to_complete_path(collects_path, NULL); + if (SCHEME_FALSEP(collects_path)) { + /* empty list of directories => don't set collection dirs + and don't use collection links files */ + skip_coll_dirs = 1; + scheme_set_ignore_link_paths(1); + collects_path = scheme_make_path("."); + } scheme_set_collects_path(collects_path); /* Make list of additional collection paths: */ @@ -1343,7 +1350,7 @@ static int run_from_cmd_line(int argc, char *_argv[], " -z, --text-repl : Use text `read-eval-print-loop' for -i\n" # endif " -I : Set to \n" - " -X , --collects : Main collects at \n" + " -X , --collects : Main collects at (or \"\" disables all)\n" " -S , --search : More collects at (after main collects)\n" " -A , --addon : Addon directory at \n" " -K , --links : User-specific collection links at \n" From 8f6fb875975eac3782b84e984f416257002aec6d Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 1 Sep 2011 10:06:26 -0500 Subject: [PATCH 075/235] adjust keybindings to free up -r for "Run" and -t for "New Tab" --- collects/drracket/private/unit.rkt | 4 +- .../private/standard-menus-items.rkt | 4 +- collects/framework/private/standard-menus.rkt | 4 +- .../framework/standard-menus.scrbl | 298 +++++++++--------- doc/release-notes/drracket/HISTORY.txt | 9 + 5 files changed, 164 insertions(+), 155 deletions(-) diff --git a/collects/drracket/private/unit.rkt b/collects/drracket/private/unit.rkt index a2565c26b4..8af3376dff 100644 --- a/collects/drracket/private/unit.rkt +++ b/collects/drracket/private/unit.rkt @@ -3319,7 +3319,7 @@ module browser threading seems wrong. (set! file-menu:create-new-tab-item (new menu:can-restore-menu-item% (label (string-constant new-tab)) - (shortcut #\=) + (shortcut #\t) (parent file-menu) (callback (λ (x y) @@ -3600,7 +3600,7 @@ module browser threading seems wrong. (string-constant execute-menu-item-label) language-specific-menu (λ (_1 _2) (execute-callback)) - #\t + #\r (string-constant execute-menu-item-help-string))) (make-object menu:can-restore-menu-item% (string-constant ask-quit-menu-item-label) diff --git a/collects/framework/private/standard-menus-items.rkt b/collects/framework/private/standard-menus-items.rkt index 74769ec4de..315ae51e1c 100644 --- a/collects/framework/private/standard-menus-items.rkt +++ b/collects/framework/private/standard-menus-items.rkt @@ -387,8 +387,8 @@ (make-an-item 'edit-menu 'replace '(string-constant replace-info) '(λ (item control) (void)) - #\r - '(get-default-shortcut-prefix) + #\f + '(cons 'shift (get-default-shortcut-prefix)) '(string-constant replace-menu-item) on-demand-do-nothing #f) diff --git a/collects/framework/private/standard-menus.rkt b/collects/framework/private/standard-menus.rkt index ddb0aabebe..ee2829ab60 100644 --- a/collects/framework/private/standard-menus.rkt +++ b/collects/framework/private/standard-menus.rkt @@ -911,8 +911,8 @@ (let ((edit-menu:replace-callback (λ (item evt) (edit-menu:replace-callback item evt)))) edit-menu:replace-callback)) - (shortcut #\r) - (shortcut-prefix (get-default-shortcut-prefix)) + (shortcut #\f) + (shortcut-prefix (cons 'shift (get-default-shortcut-prefix))) (help-string (edit-menu:replace-help-string)) (demand-callback (λ (menu-item) (edit-menu:replace-on-demand menu-item)))))) diff --git a/collects/scribblings/framework/standard-menus.scrbl b/collects/scribblings/framework/standard-menus.scrbl index 112eff7648..498ca26d45 100644 --- a/collects/scribblings/framework/standard-menus.scrbl +++ b/collects/scribblings/framework/standard-menus.scrbl @@ -1,14 +1,14 @@ -;; THIS FILE IS GENERATED. DO NOT EDIT. - -@definterface[frame:standard-menus<%> (frame:basic<%>)]{ - -@(defmethod (on-close) void? "Removes the preferences callbacks for the menu items") +;; THIS FILE IS GENERATED. DO NOT EDIT. + +@definterface[frame:standard-menus<%> (frame:basic<%>)]{ + + @(defmethod (on-close) void? "Removes the preferences callbacks for the menu items") @(defmethod (get-menu%) (is-a?/c menu:can-restore-underscore-menu%) "The result of this method is used as the class" "\n" " " "for creating the result of these methods:" "\n" " " (method frame:standard-menus get-file-menu) "," "\n" " " (method frame:standard-menus get-edit-menu) ", and" "\n" " " (method frame:standard-menus get-help-menu) ".") @(defmethod (get-menu-item%) (is-a?/c menu:can-restore-menu-item%) "The result of this method is used as the class for creating" "\n" "the menu items in this frame." "\n" "\n" "Returns " (racket menu:can-restore-menu-item) " by default.") -@(defmethod (get-checkable-menu-item%) (is-a?/c menu:can-restore-checkable-menu-item%) "The result of this method is used as the class for creating" "\n" "checkable menu items in this class." "\n" "\n" "Returns " (racket menu:can-restore-checkable-menu-item) " by default.") +@(defmethod (get-checkable-menu-item%) (is-a?/c menu:can-restore-checkable-menu-item%) "The result of this method is used as the class for creating" "\n" "checkable menu items in this class." "\n" "\n" "returns " (racket menu:can-restore-checkable-menu-item) " by default.") @(defmethod (get-file-menu) (is-a?/c menu%) "Returns the file menu." "\n" "See also " (method frame:standard-menus<%> get-menu%) ".") @@ -16,338 +16,338 @@ @(defmethod (get-help-menu) (is-a?/c menu%) "Returns the help menu." "\n" "See also " (method frame:standard-menus<%> get-menu%) ".") -@(defmethod (file-menu:get-new-item) (or/c false/c (is-a?/c menu-item<%>)) "This method returns the " (racket menu-item<%>) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> file-menu:create-new?) ").") +@(defmethod (file-menu:get-new-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (racket menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> file-menu:create-new?) ").") @(defmethod (file-menu:create-new?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (racket #t) ".") -@(defmethod (file-menu:new-callback (item (is-a?/c menu-item<%>)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (begin (handler:edit-file #f) #t)) " ") +@(defmethod (file-menu:new-callback (item (is-a?/c menu-item%)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (begin (handler:edit-file #f) #t)) " ") -@(defmethod (file-menu:new-on-demand (menu-item (is-a?/c menu-item<%>))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (void))) +@(defmethod (file-menu:new-on-demand (menu-item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (void))) -@(defmethod (file-menu:new-string) string? "The result of this method is used as the name of the " (racket menu-item<%>) "." "\n" "\n" "Defaults to " (racket (string-constant new-menu-item)) ".") +@(defmethod (file-menu:new-string) string? "The result of this method is used as the name of the " (racket menu-item%) "." "\n" "\n" "Defaults to " (racket (string-constant new-menu-item)) ".") -@(defmethod (file-menu:new-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item<%>) " object is created." "\n" "\n" "Defaults to " (racket (string-constant new-info)) ".") +@(defmethod (file-menu:new-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item%) " object is created." "\n" "\n" "Defaults to " (racket (string-constant new-info)) ".") -@(defmethod (file-menu:between-new-and-open (menu (is-a?/c menu-item<%>))) void? "This method is called between the addition of the" "\n" (tt "new") " and the " (tt "open") " menu-item." "\n" "Override it to add additional menu items at that point. ") +@(defmethod (file-menu:between-new-and-open (menu (is-a?/c menu-item%))) void? "This method is called between the addition of the" "\n" (tt "new") " and the " (tt "open") " menu-item." "\n" "Override it to add additional menu items at that point. ") -@(defmethod (file-menu:get-open-item) (or/c false/c (is-a?/c menu-item<%>)) "This method returns the " (racket menu-item<%>) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> file-menu:create-open?) ").") +@(defmethod (file-menu:get-open-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (racket menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> file-menu:create-open?) ").") @(defmethod (file-menu:create-open?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (racket #t) ".") -@(defmethod (file-menu:open-callback (item (is-a?/c menu-item<%>)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (begin (handler:open-file) #t)) " ") +@(defmethod (file-menu:open-callback (item (is-a?/c menu-item%)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (begin (handler:open-file) #t)) " ") -@(defmethod (file-menu:open-on-demand (menu-item (is-a?/c menu-item<%>))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (void))) +@(defmethod (file-menu:open-on-demand (menu-item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (void))) -@(defmethod (file-menu:open-string) string? "The result of this method is used as the name of the " (racket menu-item<%>) "." "\n" "\n" "Defaults to " (racket (string-constant open-menu-item)) ".") +@(defmethod (file-menu:open-string) string? "The result of this method is used as the name of the " (racket menu-item%) "." "\n" "\n" "Defaults to " (racket (string-constant open-menu-item)) ".") -@(defmethod (file-menu:open-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item<%>) " object is created." "\n" "\n" "Defaults to " (racket (string-constant open-info)) ".") +@(defmethod (file-menu:open-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item%) " object is created." "\n" "\n" "Defaults to " (racket (string-constant open-info)) ".") -@(defmethod (file-menu:get-open-recent-item) (or/c false/c (is-a?/c menu-item<%>)) "This method returns the " (racket menu-item<%>) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> file-menu:create-open-recent?) ").") +@(defmethod (file-menu:get-open-recent-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (racket menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> file-menu:create-open-recent?) ").") @(defmethod (file-menu:create-open-recent?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (racket #t) ".") -@(defmethod (file-menu:open-recent-callback (x (is-a?/c menu-item<%>)) (y (is-a?/c control-event%))) void? "Defaults to " (racketblock (void)) " ") +@(defmethod (file-menu:open-recent-callback (x (is-a?/c menu-item%)) (y (is-a?/c control-event%))) void? "Defaults to " (racketblock (void)) " ") -@(defmethod (file-menu:open-recent-on-demand (menu (is-a?/c menu-item<%>))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (handler:install-recent-items menu))) +@(defmethod (file-menu:open-recent-on-demand (menu (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (handler:install-recent-items menu))) -@(defmethod (file-menu:open-recent-string) string? "The result of this method is used as the name of the " (racket menu-item<%>) "." "\n" "\n" "Defaults to " (racket (string-constant open-recent-menu-item)) ".") +@(defmethod (file-menu:open-recent-string) string? "The result of this method is used as the name of the " (racket menu-item%) "." "\n" "\n" "Defaults to " (racket (string-constant open-recent-menu-item)) ".") -@(defmethod (file-menu:open-recent-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item<%>) " object is created." "\n" "\n" "Defaults to " (racket (string-constant open-recent-info)) ".") +@(defmethod (file-menu:open-recent-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item%) " object is created." "\n" "\n" "Defaults to " (racket (string-constant open-recent-info)) ".") -@(defmethod (file-menu:between-open-and-revert (menu (is-a?/c menu-item<%>))) void? "This method is called between the addition of the" "\n" (tt "open") " and the " (tt "revert") " menu-item." "\n" "Override it to add additional menu items at that point. ") +@(defmethod (file-menu:between-open-and-revert (menu (is-a?/c menu-item%))) void? "This method is called between the addition of the" "\n" (tt "open") " and the " (tt "revert") " menu-item." "\n" "Override it to add additional menu items at that point. ") -@(defmethod (file-menu:get-revert-item) (or/c false/c (is-a?/c menu-item<%>)) "This method returns the " (racket menu-item<%>) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> file-menu:create-revert?) ").") +@(defmethod (file-menu:get-revert-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (racket menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> file-menu:create-revert?) ").") @(defmethod (file-menu:create-revert?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (racket #f) ".") -@(defmethod (file-menu:revert-callback (item (is-a?/c menu-item<%>)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (void)) " ") +@(defmethod (file-menu:revert-callback (item (is-a?/c menu-item%)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (void)) " ") -@(defmethod (file-menu:revert-on-demand (menu-item (is-a?/c menu-item<%>))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (void))) +@(defmethod (file-menu:revert-on-demand (menu-item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (void))) -@(defmethod (file-menu:revert-string) string? "The result of this method is used as the name of the " (racket menu-item<%>) "." "\n" "\n" "Defaults to " (racket (string-constant revert-menu-item)) ".") +@(defmethod (file-menu:revert-string) string? "The result of this method is used as the name of the " (racket menu-item%) "." "\n" "\n" "Defaults to " (racket (string-constant revert-menu-item)) ".") -@(defmethod (file-menu:revert-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item<%>) " object is created." "\n" "\n" "Defaults to " (racket (string-constant revert-info)) ".") +@(defmethod (file-menu:revert-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item%) " object is created." "\n" "\n" "Defaults to " (racket (string-constant revert-info)) ".") -@(defmethod (file-menu:between-revert-and-save (menu (is-a?/c menu-item<%>))) void? "This method is called between the addition of the" "\n" (tt "revert") " and the " (tt "save") " menu-item." "\n" "Override it to add additional menu items at that point. ") +@(defmethod (file-menu:between-revert-and-save (menu (is-a?/c menu-item%))) void? "This method is called between the addition of the" "\n" (tt "revert") " and the " (tt "save") " menu-item." "\n" "Override it to add additional menu items at that point. ") -@(defmethod (file-menu:get-save-item) (or/c false/c (is-a?/c menu-item<%>)) "This method returns the " (racket menu-item<%>) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> file-menu:create-save?) ").") +@(defmethod (file-menu:get-save-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (racket menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> file-menu:create-save?) ").") @(defmethod (file-menu:create-save?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (racket #f) ".") -@(defmethod (file-menu:save-callback (item (is-a?/c menu-item<%>)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (void)) " ") +@(defmethod (file-menu:save-callback (item (is-a?/c menu-item%)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (void)) " ") -@(defmethod (file-menu:save-on-demand (menu-item (is-a?/c menu-item<%>))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (void))) +@(defmethod (file-menu:save-on-demand (menu-item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (void))) -@(defmethod (file-menu:save-string) string? "The result of this method is used as the name of the " (racket menu-item<%>) "." "\n" "\n" "Defaults to " (racket (string-constant save-menu-item)) ".") +@(defmethod (file-menu:save-string) string? "The result of this method is used as the name of the " (racket menu-item%) "." "\n" "\n" "Defaults to " (racket (string-constant save-menu-item)) ".") -@(defmethod (file-menu:save-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item<%>) " object is created." "\n" "\n" "Defaults to " (racket (string-constant save-info)) ".") +@(defmethod (file-menu:save-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item%) " object is created." "\n" "\n" "Defaults to " (racket (string-constant save-info)) ".") -@(defmethod (file-menu:get-save-as-item) (or/c false/c (is-a?/c menu-item<%>)) "This method returns the " (racket menu-item<%>) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> file-menu:create-save-as?) ").") +@(defmethod (file-menu:get-save-as-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (racket menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> file-menu:create-save-as?) ").") @(defmethod (file-menu:create-save-as?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (racket #f) ".") -@(defmethod (file-menu:save-as-callback (item (is-a?/c menu-item<%>)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (void)) " ") +@(defmethod (file-menu:save-as-callback (item (is-a?/c menu-item%)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (void)) " ") -@(defmethod (file-menu:save-as-on-demand (menu-item (is-a?/c menu-item<%>))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (void))) +@(defmethod (file-menu:save-as-on-demand (menu-item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (void))) -@(defmethod (file-menu:save-as-string) string? "The result of this method is used as the name of the " (racket menu-item<%>) "." "\n" "\n" "Defaults to " (racket (string-constant save-as-menu-item)) ".") +@(defmethod (file-menu:save-as-string) string? "The result of this method is used as the name of the " (racket menu-item%) "." "\n" "\n" "Defaults to " (racket (string-constant save-as-menu-item)) ".") -@(defmethod (file-menu:save-as-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item<%>) " object is created." "\n" "\n" "Defaults to " (racket (string-constant save-as-info)) ".") +@(defmethod (file-menu:save-as-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item%) " object is created." "\n" "\n" "Defaults to " (racket (string-constant save-as-info)) ".") -@(defmethod (file-menu:between-save-as-and-print (menu (is-a?/c menu-item<%>))) void? "This method is called between the addition of the" "\n" (tt "save-as") " and the " (tt "print") " menu-item." "\n" "Override it to add additional menu items at that point. ") +@(defmethod (file-menu:between-save-as-and-print (menu (is-a?/c menu-item%))) void? "This method is called between the addition of the" "\n" (tt "save-as") " and the " (tt "print") " menu-item." "\n" "Override it to add additional menu items at that point. ") -@(defmethod (file-menu:get-print-item) (or/c false/c (is-a?/c menu-item<%>)) "This method returns the " (racket menu-item<%>) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> file-menu:create-print?) ").") +@(defmethod (file-menu:get-print-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (racket menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> file-menu:create-print?) ").") @(defmethod (file-menu:create-print?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (racket #f) ".") -@(defmethod (file-menu:print-callback (item (is-a?/c menu-item<%>)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (void)) " ") +@(defmethod (file-menu:print-callback (item (is-a?/c menu-item%)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (void)) " ") -@(defmethod (file-menu:print-on-demand (menu-item (is-a?/c menu-item<%>))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (void))) +@(defmethod (file-menu:print-on-demand (menu-item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (void))) -@(defmethod (file-menu:print-string) string? "The result of this method is used as the name of the " (racket menu-item<%>) "." "\n" "\n" "Defaults to " (racket (string-constant print-menu-item)) ".") +@(defmethod (file-menu:print-string) string? "The result of this method is used as the name of the " (racket menu-item%) "." "\n" "\n" "Defaults to " (racket (string-constant print-menu-item)) ".") -@(defmethod (file-menu:print-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item<%>) " object is created." "\n" "\n" "Defaults to " (racket (string-constant print-info)) ".") +@(defmethod (file-menu:print-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item%) " object is created." "\n" "\n" "Defaults to " (racket (string-constant print-info)) ".") -@(defmethod (file-menu:between-print-and-close (menu (is-a?/c menu-item<%>))) void? "This method is called between the addition of the" "\n" (tt "print") " and the " (tt "close") " menu-item." "\n" "Override it to add additional menu items at that point. ") +@(defmethod (file-menu:between-print-and-close (menu (is-a?/c menu-item%))) void? "This method is called between the addition of the" "\n" (tt "print") " and the " (tt "close") " menu-item." "\n" "Override it to add additional menu items at that point. ") -@(defmethod (file-menu:get-close-item) (or/c false/c (is-a?/c menu-item<%>)) "This method returns the " (racket menu-item<%>) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> file-menu:create-close?) ").") +@(defmethod (file-menu:get-close-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (racket menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> file-menu:create-close?) ").") @(defmethod (file-menu:create-close?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (racket #t) ".") -@(defmethod (file-menu:close-callback (item (is-a?/c menu-item<%>)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (begin (when (can-close?) (on-close) (show #f)) #t)) " ") +@(defmethod (file-menu:close-callback (item (is-a?/c menu-item%)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (begin (when (can-close?) (on-close) (show #f)) #t)) " ") -@(defmethod (file-menu:close-on-demand (menu-item (is-a?/c menu-item<%>))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (void))) +@(defmethod (file-menu:close-on-demand (menu-item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (void))) -@(defmethod (file-menu:close-string) string? "The result of this method is used as the name of the " (racket menu-item<%>) "." "\n" "\n" "Defaults to " (racket (string-constant close-menu-item)) ".") +@(defmethod (file-menu:close-string) string? "The result of this method is used as the name of the " (racket menu-item%) "." "\n" "\n" "Defaults to " (racket (string-constant close-menu-item)) ".") -@(defmethod (file-menu:close-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item<%>) " object is created." "\n" "\n" "Defaults to " (racket (string-constant close-info)) ".") +@(defmethod (file-menu:close-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item%) " object is created." "\n" "\n" "Defaults to " (racket (string-constant close-info)) ".") -@(defmethod (file-menu:between-close-and-quit (menu (is-a?/c menu-item<%>))) void? "This method is called between the addition of the" "\n" (tt "close") " and the " (tt "quit") " menu-item." "\n" "Override it to add additional menu items at that point. ") +@(defmethod (file-menu:between-close-and-quit (menu (is-a?/c menu-item%))) void? "This method is called between the addition of the" "\n" (tt "close") " and the " (tt "quit") " menu-item." "\n" "Override it to add additional menu items at that point. ") -@(defmethod (file-menu:get-quit-item) (or/c false/c (is-a?/c menu-item<%>)) "This method returns the " (racket menu-item<%>) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> file-menu:create-quit?) ").") +@(defmethod (file-menu:get-quit-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (racket menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> file-menu:create-quit?) ").") @(defmethod (file-menu:create-quit?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (racket (not (eq? (system-type) (quote macosx)))) ".") -@(defmethod (file-menu:quit-callback (item (is-a?/c menu-item<%>)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (when (exit:user-oks-exit) (exit:exit))) " ") +@(defmethod (file-menu:quit-callback (item (is-a?/c menu-item%)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (when (exit:user-oks-exit) (exit:exit))) " ") -@(defmethod (file-menu:quit-on-demand (menu-item (is-a?/c menu-item<%>))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (void))) +@(defmethod (file-menu:quit-on-demand (menu-item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (void))) -@(defmethod (file-menu:quit-string) string? "The result of this method is used as the name of the " (racket menu-item<%>) "." "\n" "\n" "Defaults to " (racket (if (eq? (system-type) (quote windows)) (string-constant quit-menu-item-windows) (string-constant quit-menu-item-others))) ".") +@(defmethod (file-menu:quit-string) string? "The result of this method is used as the name of the " (racket menu-item%) "." "\n" "\n" "Defaults to " (racket (if (eq? (system-type) (quote windows)) (string-constant quit-menu-item-windows) (string-constant quit-menu-item-others))) ".") -@(defmethod (file-menu:quit-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item<%>) " object is created." "\n" "\n" "Defaults to " (racket (string-constant quit-info)) ".") +@(defmethod (file-menu:quit-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item%) " object is created." "\n" "\n" "Defaults to " (racket (string-constant quit-info)) ".") -@(defmethod (file-menu:after-quit (menu (is-a?/c menu-item<%>))) void? "This method is called " "after" " the addition of the" "\n" (tt "quit") " menu-item. Override it to add additional" "\n" "menu items at that point. ") +@(defmethod (file-menu:after-quit (menu (is-a?/c menu-item%))) void? "This method is called " "after" " the addition of the" "\n" (tt "quit") " menu-item. Override it to add additional" "\n" "menu items at that point. ") -@(defmethod (edit-menu:get-undo-item) (or/c false/c (is-a?/c menu-item<%>)) "This method returns the " (racket menu-item<%>) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-undo?) ").") +@(defmethod (edit-menu:get-undo-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (racket menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-undo?) ").") @(defmethod (edit-menu:create-undo?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (racket #t) ".") -@(defmethod (edit-menu:undo-callback (menu (is-a?/c menu-item<%>)) (evt (is-a?/c control-event%))) void? "Defaults to " (racketblock (begin (let ((edit (get-edit-target-object))) (when (and edit (is-a? edit editor<%>)) (send edit do-edit-operation (quote undo)))) #t)) " ") +@(defmethod (edit-menu:undo-callback (menu (is-a?/c menu-item%)) (evt (is-a?/c control-event%))) void? "Defaults to " (racketblock (begin (let ((edit (get-edit-target-object))) (when (and edit (is-a? edit editor<%>)) (send edit do-edit-operation (quote undo)))) #t)) " ") -@(defmethod (edit-menu:undo-on-demand (item (is-a?/c menu-item<%>))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (let* ((editor (get-edit-target-object)) (enable? (and editor (is-a? editor editor<%>) (send editor can-do-edit-operation? (quote undo))))) (send item enable enable?)))) +@(defmethod (edit-menu:undo-on-demand (item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (let* ((editor (get-edit-target-object)) (enable? (and editor (is-a? editor editor<%>) (send editor can-do-edit-operation? (quote undo))))) (send item enable enable?)))) -@(defmethod (edit-menu:undo-string) string? "The result of this method is used as the name of the " (racket menu-item<%>) "." "\n" "\n" "Defaults to " (racket (string-constant undo-menu-item)) ".") +@(defmethod (edit-menu:undo-string) string? "The result of this method is used as the name of the " (racket menu-item%) "." "\n" "\n" "Defaults to " (racket (string-constant undo-menu-item)) ".") -@(defmethod (edit-menu:undo-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item<%>) " object is created." "\n" "\n" "Defaults to " (racket (string-constant undo-info)) ".") +@(defmethod (edit-menu:undo-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item%) " object is created." "\n" "\n" "Defaults to " (racket (string-constant undo-info)) ".") -@(defmethod (edit-menu:get-redo-item) (or/c false/c (is-a?/c menu-item<%>)) "This method returns the " (racket menu-item<%>) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-redo?) ").") +@(defmethod (edit-menu:get-redo-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (racket menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-redo?) ").") @(defmethod (edit-menu:create-redo?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (racket #t) ".") -@(defmethod (edit-menu:redo-callback (menu (is-a?/c menu-item<%>)) (evt (is-a?/c control-event%))) void? "Defaults to " (racketblock (begin (let ((edit (get-edit-target-object))) (when (and edit (is-a? edit editor<%>)) (send edit do-edit-operation (quote redo)))) #t)) " ") +@(defmethod (edit-menu:redo-callback (menu (is-a?/c menu-item%)) (evt (is-a?/c control-event%))) void? "Defaults to " (racketblock (begin (let ((edit (get-edit-target-object))) (when (and edit (is-a? edit editor<%>)) (send edit do-edit-operation (quote redo)))) #t)) " ") -@(defmethod (edit-menu:redo-on-demand (item (is-a?/c menu-item<%>))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (let* ((editor (get-edit-target-object)) (enable? (and editor (is-a? editor editor<%>) (send editor can-do-edit-operation? (quote redo))))) (send item enable enable?)))) +@(defmethod (edit-menu:redo-on-demand (item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (let* ((editor (get-edit-target-object)) (enable? (and editor (is-a? editor editor<%>) (send editor can-do-edit-operation? (quote redo))))) (send item enable enable?)))) -@(defmethod (edit-menu:redo-string) string? "The result of this method is used as the name of the " (racket menu-item<%>) "." "\n" "\n" "Defaults to " (racket (string-constant redo-menu-item)) ".") +@(defmethod (edit-menu:redo-string) string? "The result of this method is used as the name of the " (racket menu-item%) "." "\n" "\n" "Defaults to " (racket (string-constant redo-menu-item)) ".") -@(defmethod (edit-menu:redo-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item<%>) " object is created." "\n" "\n" "Defaults to " (racket (string-constant redo-info)) ".") +@(defmethod (edit-menu:redo-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item%) " object is created." "\n" "\n" "Defaults to " (racket (string-constant redo-info)) ".") -@(defmethod (edit-menu:between-redo-and-cut (menu (is-a?/c menu-item<%>))) void? "This method is called between the addition of the" "\n" (tt "redo") " and the " (tt "cut") " menu-item." "\n" "Override it to add additional menu items at that point. ") +@(defmethod (edit-menu:between-redo-and-cut (menu (is-a?/c menu-item%))) void? "This method is called between the addition of the" "\n" (tt "redo") " and the " (tt "cut") " menu-item." "\n" "Override it to add additional menu items at that point. ") -@(defmethod (edit-menu:get-cut-item) (or/c false/c (is-a?/c menu-item<%>)) "This method returns the " (racket menu-item<%>) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-cut?) ").") +@(defmethod (edit-menu:get-cut-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (racket menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-cut?) ").") @(defmethod (edit-menu:create-cut?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (racket #t) ".") -@(defmethod (edit-menu:cut-callback (menu (is-a?/c menu-item<%>)) (evt (is-a?/c control-event%))) void? "Defaults to " (racketblock (begin (let ((edit (get-edit-target-object))) (when (and edit (is-a? edit editor<%>)) (send edit do-edit-operation (quote cut)))) #t)) " ") +@(defmethod (edit-menu:cut-callback (menu (is-a?/c menu-item%)) (evt (is-a?/c control-event%))) void? "Defaults to " (racketblock (begin (let ((edit (get-edit-target-object))) (when (and edit (is-a? edit editor<%>)) (send edit do-edit-operation (quote cut)))) #t)) " ") -@(defmethod (edit-menu:cut-on-demand (item (is-a?/c menu-item<%>))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (let* ((editor (get-edit-target-object)) (enable? (and editor (is-a? editor editor<%>) (send editor can-do-edit-operation? (quote cut))))) (send item enable enable?)))) +@(defmethod (edit-menu:cut-on-demand (item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (let* ((editor (get-edit-target-object)) (enable? (and editor (is-a? editor editor<%>) (send editor can-do-edit-operation? (quote cut))))) (send item enable enable?)))) -@(defmethod (edit-menu:cut-string) string? "The result of this method is used as the name of the " (racket menu-item<%>) "." "\n" "\n" "Defaults to " (racket (string-constant cut-menu-item)) ".") +@(defmethod (edit-menu:cut-string) string? "The result of this method is used as the name of the " (racket menu-item%) "." "\n" "\n" "Defaults to " (racket (string-constant cut-menu-item)) ".") -@(defmethod (edit-menu:cut-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item<%>) " object is created." "\n" "\n" "Defaults to " (racket (string-constant cut-info)) ".") +@(defmethod (edit-menu:cut-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item%) " object is created." "\n" "\n" "Defaults to " (racket (string-constant cut-info)) ".") -@(defmethod (edit-menu:between-cut-and-copy (menu (is-a?/c menu-item<%>))) void? "This method is called between the addition of the" "\n" (tt "cut") " and the " (tt "copy") " menu-item." "\n" "Override it to add additional menu items at that point. ") +@(defmethod (edit-menu:between-cut-and-copy (menu (is-a?/c menu-item%))) void? "This method is called between the addition of the" "\n" (tt "cut") " and the " (tt "copy") " menu-item." "\n" "Override it to add additional menu items at that point. ") -@(defmethod (edit-menu:get-copy-item) (or/c false/c (is-a?/c menu-item<%>)) "This method returns the " (racket menu-item<%>) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-copy?) ").") +@(defmethod (edit-menu:get-copy-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (racket menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-copy?) ").") @(defmethod (edit-menu:create-copy?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (racket #t) ".") -@(defmethod (edit-menu:copy-callback (menu (is-a?/c menu-item<%>)) (evt (is-a?/c control-event%))) void? "Defaults to " (racketblock (begin (let ((edit (get-edit-target-object))) (when (and edit (is-a? edit editor<%>)) (send edit do-edit-operation (quote copy)))) #t)) " ") +@(defmethod (edit-menu:copy-callback (menu (is-a?/c menu-item%)) (evt (is-a?/c control-event%))) void? "Defaults to " (racketblock (begin (let ((edit (get-edit-target-object))) (when (and edit (is-a? edit editor<%>)) (send edit do-edit-operation (quote copy)))) #t)) " ") -@(defmethod (edit-menu:copy-on-demand (item (is-a?/c menu-item<%>))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (let* ((editor (get-edit-target-object)) (enable? (and editor (is-a? editor editor<%>) (send editor can-do-edit-operation? (quote copy))))) (send item enable enable?)))) +@(defmethod (edit-menu:copy-on-demand (item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (let* ((editor (get-edit-target-object)) (enable? (and editor (is-a? editor editor<%>) (send editor can-do-edit-operation? (quote copy))))) (send item enable enable?)))) -@(defmethod (edit-menu:copy-string) string? "The result of this method is used as the name of the " (racket menu-item<%>) "." "\n" "\n" "Defaults to " (racket (string-constant copy-menu-item)) ".") +@(defmethod (edit-menu:copy-string) string? "The result of this method is used as the name of the " (racket menu-item%) "." "\n" "\n" "Defaults to " (racket (string-constant copy-menu-item)) ".") -@(defmethod (edit-menu:copy-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item<%>) " object is created." "\n" "\n" "Defaults to " (racket (string-constant copy-info)) ".") +@(defmethod (edit-menu:copy-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item%) " object is created." "\n" "\n" "Defaults to " (racket (string-constant copy-info)) ".") -@(defmethod (edit-menu:between-copy-and-paste (menu (is-a?/c menu-item<%>))) void? "This method is called between the addition of the" "\n" (tt "copy") " and the " (tt "paste") " menu-item." "\n" "Override it to add additional menu items at that point. ") +@(defmethod (edit-menu:between-copy-and-paste (menu (is-a?/c menu-item%))) void? "This method is called between the addition of the" "\n" (tt "copy") " and the " (tt "paste") " menu-item." "\n" "Override it to add additional menu items at that point. ") -@(defmethod (edit-menu:get-paste-item) (or/c false/c (is-a?/c menu-item<%>)) "This method returns the " (racket menu-item<%>) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-paste?) ").") +@(defmethod (edit-menu:get-paste-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (racket menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-paste?) ").") @(defmethod (edit-menu:create-paste?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (racket #t) ".") -@(defmethod (edit-menu:paste-callback (menu (is-a?/c menu-item<%>)) (evt (is-a?/c control-event%))) void? "Defaults to " (racketblock (begin (let ((edit (get-edit-target-object))) (when (and edit (is-a? edit editor<%>)) (send edit do-edit-operation (quote paste)))) #t)) " ") +@(defmethod (edit-menu:paste-callback (menu (is-a?/c menu-item%)) (evt (is-a?/c control-event%))) void? "Defaults to " (racketblock (begin (let ((edit (get-edit-target-object))) (when (and edit (is-a? edit editor<%>)) (send edit do-edit-operation (quote paste)))) #t)) " ") -@(defmethod (edit-menu:paste-on-demand (item (is-a?/c menu-item<%>))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (let* ((editor (get-edit-target-object)) (enable? (and editor (is-a? editor editor<%>) (send editor can-do-edit-operation? (quote paste))))) (send item enable enable?)))) +@(defmethod (edit-menu:paste-on-demand (item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (let* ((editor (get-edit-target-object)) (enable? (and editor (is-a? editor editor<%>) (send editor can-do-edit-operation? (quote paste))))) (send item enable enable?)))) -@(defmethod (edit-menu:paste-string) string? "The result of this method is used as the name of the " (racket menu-item<%>) "." "\n" "\n" "Defaults to " (racket (string-constant paste-menu-item)) ".") +@(defmethod (edit-menu:paste-string) string? "The result of this method is used as the name of the " (racket menu-item%) "." "\n" "\n" "Defaults to " (racket (string-constant paste-menu-item)) ".") -@(defmethod (edit-menu:paste-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item<%>) " object is created." "\n" "\n" "Defaults to " (racket (string-constant paste-info)) ".") +@(defmethod (edit-menu:paste-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item%) " object is created." "\n" "\n" "Defaults to " (racket (string-constant paste-info)) ".") -@(defmethod (edit-menu:between-paste-and-clear (menu (is-a?/c menu-item<%>))) void? "This method is called between the addition of the" "\n" (tt "paste") " and the " (tt "clear") " menu-item." "\n" "Override it to add additional menu items at that point. ") +@(defmethod (edit-menu:between-paste-and-clear (menu (is-a?/c menu-item%))) void? "This method is called between the addition of the" "\n" (tt "paste") " and the " (tt "clear") " menu-item." "\n" "Override it to add additional menu items at that point. ") -@(defmethod (edit-menu:get-clear-item) (or/c false/c (is-a?/c menu-item<%>)) "This method returns the " (racket menu-item<%>) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-clear?) ").") +@(defmethod (edit-menu:get-clear-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (racket menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-clear?) ").") @(defmethod (edit-menu:create-clear?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (racket #t) ".") -@(defmethod (edit-menu:clear-callback (menu (is-a?/c menu-item<%>)) (evt (is-a?/c control-event%))) void? "Defaults to " (racketblock (begin (let ((edit (get-edit-target-object))) (when (and edit (is-a? edit editor<%>)) (send edit do-edit-operation (quote clear)))) #t)) " ") +@(defmethod (edit-menu:clear-callback (menu (is-a?/c menu-item%)) (evt (is-a?/c control-event%))) void? "Defaults to " (racketblock (begin (let ((edit (get-edit-target-object))) (when (and edit (is-a? edit editor<%>)) (send edit do-edit-operation (quote clear)))) #t)) " ") -@(defmethod (edit-menu:clear-on-demand (item (is-a?/c menu-item<%>))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (let* ((editor (get-edit-target-object)) (enable? (and editor (is-a? editor editor<%>) (send editor can-do-edit-operation? (quote clear))))) (send item enable enable?)))) +@(defmethod (edit-menu:clear-on-demand (item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (let* ((editor (get-edit-target-object)) (enable? (and editor (is-a? editor editor<%>) (send editor can-do-edit-operation? (quote clear))))) (send item enable enable?)))) -@(defmethod (edit-menu:clear-string) string? "The result of this method is used as the name of the " (racket menu-item<%>) "." "\n" "\n" "Defaults to " (racket (if (eq? (system-type) (quote windows)) (string-constant clear-menu-item-windows) (string-constant clear-menu-item-windows))) ".") +@(defmethod (edit-menu:clear-string) string? "The result of this method is used as the name of the " (racket menu-item%) "." "\n" "\n" "Defaults to " (racket (if (eq? (system-type) (quote windows)) (string-constant clear-menu-item-windows) (string-constant clear-menu-item-windows))) ".") -@(defmethod (edit-menu:clear-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item<%>) " object is created." "\n" "\n" "Defaults to " (racket (string-constant clear-info)) ".") +@(defmethod (edit-menu:clear-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item%) " object is created." "\n" "\n" "Defaults to " (racket (string-constant clear-info)) ".") -@(defmethod (edit-menu:between-clear-and-select-all (menu (is-a?/c menu-item<%>))) void? "This method is called between the addition of the" "\n" (tt "clear") " and the " (tt "select-all") " menu-item." "\n" "Override it to add additional menu items at that point. ") +@(defmethod (edit-menu:between-clear-and-select-all (menu (is-a?/c menu-item%))) void? "This method is called between the addition of the" "\n" (tt "clear") " and the " (tt "select-all") " menu-item." "\n" "Override it to add additional menu items at that point. ") -@(defmethod (edit-menu:get-select-all-item) (or/c false/c (is-a?/c menu-item<%>)) "This method returns the " (racket menu-item<%>) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-select-all?) ").") +@(defmethod (edit-menu:get-select-all-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (racket menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-select-all?) ").") @(defmethod (edit-menu:create-select-all?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (racket #t) ".") -@(defmethod (edit-menu:select-all-callback (menu (is-a?/c menu-item<%>)) (evt (is-a?/c control-event%))) void? "Defaults to " (racketblock (begin (let ((edit (get-edit-target-object))) (when (and edit (is-a? edit editor<%>)) (send edit do-edit-operation (quote select-all)))) #t)) " ") +@(defmethod (edit-menu:select-all-callback (menu (is-a?/c menu-item%)) (evt (is-a?/c control-event%))) void? "Defaults to " (racketblock (begin (let ((edit (get-edit-target-object))) (when (and edit (is-a? edit editor<%>)) (send edit do-edit-operation (quote select-all)))) #t)) " ") -@(defmethod (edit-menu:select-all-on-demand (item (is-a?/c menu-item<%>))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (let* ((editor (get-edit-target-object)) (enable? (and editor (is-a? editor editor<%>) (send editor can-do-edit-operation? (quote select-all))))) (send item enable enable?)))) +@(defmethod (edit-menu:select-all-on-demand (item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (let* ((editor (get-edit-target-object)) (enable? (and editor (is-a? editor editor<%>) (send editor can-do-edit-operation? (quote select-all))))) (send item enable enable?)))) -@(defmethod (edit-menu:select-all-string) string? "The result of this method is used as the name of the " (racket menu-item<%>) "." "\n" "\n" "Defaults to " (racket (string-constant select-all-menu-item)) ".") +@(defmethod (edit-menu:select-all-string) string? "The result of this method is used as the name of the " (racket menu-item%) "." "\n" "\n" "Defaults to " (racket (string-constant select-all-menu-item)) ".") -@(defmethod (edit-menu:select-all-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item<%>) " object is created." "\n" "\n" "Defaults to " (racket (string-constant select-all-info)) ".") +@(defmethod (edit-menu:select-all-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item%) " object is created." "\n" "\n" "Defaults to " (racket (string-constant select-all-info)) ".") -@(defmethod (edit-menu:between-select-all-and-find (menu (is-a?/c menu-item<%>))) void? "This method is called between the addition of the" "\n" (tt "select-all") " and the " (tt "find") " menu-item." "\n" "Override it to add additional menu items at that point. ") +@(defmethod (edit-menu:between-select-all-and-find (menu (is-a?/c menu-item%))) void? "This method is called between the addition of the" "\n" (tt "select-all") " and the " (tt "find") " menu-item." "\n" "Override it to add additional menu items at that point. ") -@(defmethod (edit-menu:get-find-item) (or/c false/c (is-a?/c menu-item<%>)) "This method returns the " (racket menu-item<%>) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-find?) ").") +@(defmethod (edit-menu:get-find-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (racket menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-find?) ").") @(defmethod (edit-menu:create-find?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (racket #f) ".") -@(defmethod (edit-menu:find-callback (item (is-a?/c menu-item<%>)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (void)) " ") +@(defmethod (edit-menu:find-callback (item (is-a?/c menu-item%)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (void)) " ") -@(defmethod (edit-menu:find-on-demand (item (is-a?/c menu-item<%>))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (send item enable (let ((target (get-edit-target-object))) (and target (is-a? target editor<%>)))))) +@(defmethod (edit-menu:find-on-demand (item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (send item enable (let ((target (get-edit-target-object))) (and target (is-a? target editor<%>)))))) -@(defmethod (edit-menu:find-string) string? "The result of this method is used as the name of the " (racket menu-item<%>) "." "\n" "\n" "Defaults to " (racket (string-constant find-menu-item)) ".") +@(defmethod (edit-menu:find-string) string? "The result of this method is used as the name of the " (racket menu-item%) "." "\n" "\n" "Defaults to " (racket (string-constant find-menu-item)) ".") -@(defmethod (edit-menu:find-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item<%>) " object is created." "\n" "\n" "Defaults to " (racket (string-constant find-info)) ".") +@(defmethod (edit-menu:find-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item%) " object is created." "\n" "\n" "Defaults to " (racket (string-constant find-info)) ".") -@(defmethod (edit-menu:get-find-next-item) (or/c false/c (is-a?/c menu-item<%>)) "This method returns the " (racket menu-item<%>) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-find-next?) ").") +@(defmethod (edit-menu:get-find-next-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (racket menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-find-next?) ").") @(defmethod (edit-menu:create-find-next?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (racket #f) ".") -@(defmethod (edit-menu:find-next-callback (item (is-a?/c menu-item<%>)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (void)) " ") +@(defmethod (edit-menu:find-next-callback (item (is-a?/c menu-item%)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (void)) " ") -@(defmethod (edit-menu:find-next-on-demand (item (is-a?/c menu-item<%>))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (send item enable (let ((target (get-edit-target-object))) (and target (is-a? target editor<%>)))))) +@(defmethod (edit-menu:find-next-on-demand (item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (send item enable (let ((target (get-edit-target-object))) (and target (is-a? target editor<%>)))))) -@(defmethod (edit-menu:find-next-string) string? "The result of this method is used as the name of the " (racket menu-item<%>) "." "\n" "\n" "Defaults to " (racket (string-constant find-next-menu-item)) ".") +@(defmethod (edit-menu:find-next-string) string? "The result of this method is used as the name of the " (racket menu-item%) "." "\n" "\n" "Defaults to " (racket (string-constant find-next-menu-item)) ".") -@(defmethod (edit-menu:find-next-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item<%>) " object is created." "\n" "\n" "Defaults to " (racket (string-constant find-next-info)) ".") +@(defmethod (edit-menu:find-next-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item%) " object is created." "\n" "\n" "Defaults to " (racket (string-constant find-next-info)) ".") -@(defmethod (edit-menu:get-find-previous-item) (or/c false/c (is-a?/c menu-item<%>)) "This method returns the " (racket menu-item<%>) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-find-previous?) ").") +@(defmethod (edit-menu:get-find-previous-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (racket menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-find-previous?) ").") @(defmethod (edit-menu:create-find-previous?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (racket #f) ".") -@(defmethod (edit-menu:find-previous-callback (item (is-a?/c menu-item<%>)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (void)) " ") +@(defmethod (edit-menu:find-previous-callback (item (is-a?/c menu-item%)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (void)) " ") -@(defmethod (edit-menu:find-previous-on-demand (item (is-a?/c menu-item<%>))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (send item enable (let ((target (get-edit-target-object))) (and target (is-a? target editor<%>)))))) +@(defmethod (edit-menu:find-previous-on-demand (item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (send item enable (let ((target (get-edit-target-object))) (and target (is-a? target editor<%>)))))) -@(defmethod (edit-menu:find-previous-string) string? "The result of this method is used as the name of the " (racket menu-item<%>) "." "\n" "\n" "Defaults to " (racket (string-constant find-previous-menu-item)) ".") +@(defmethod (edit-menu:find-previous-string) string? "The result of this method is used as the name of the " (racket menu-item%) "." "\n" "\n" "Defaults to " (racket (string-constant find-previous-menu-item)) ".") -@(defmethod (edit-menu:find-previous-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item<%>) " object is created." "\n" "\n" "Defaults to " (racket (string-constant find-previous-info)) ".") +@(defmethod (edit-menu:find-previous-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item%) " object is created." "\n" "\n" "Defaults to " (racket (string-constant find-previous-info)) ".") -@(defmethod (edit-menu:get-show/hide-replace-item) (or/c false/c (is-a?/c menu-item<%>)) "This method returns the " (racket menu-item<%>) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-show/hide-replace?) ").") +@(defmethod (edit-menu:get-show/hide-replace-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (racket menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-show/hide-replace?) ").") @(defmethod (edit-menu:create-show/hide-replace?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (racket #f) ".") -@(defmethod (edit-menu:show/hide-replace-callback (item (is-a?/c menu-item<%>)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (void)) " ") +@(defmethod (edit-menu:show/hide-replace-callback (item (is-a?/c menu-item%)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (void)) " ") -@(defmethod (edit-menu:show/hide-replace-on-demand (menu-item (is-a?/c menu-item<%>))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (void))) +@(defmethod (edit-menu:show/hide-replace-on-demand (menu-item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (void))) -@(defmethod (edit-menu:show/hide-replace-string) string? "The result of this method is used as the name of the " (racket menu-item<%>) "." "\n" "\n" "Defaults to " (racket (string-constant show-replace-menu-item)) ".") +@(defmethod (edit-menu:show/hide-replace-string) string? "The result of this method is used as the name of the " (racket menu-item%) "." "\n" "\n" "Defaults to " (racket (string-constant show-replace-menu-item)) ".") -@(defmethod (edit-menu:show/hide-replace-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item<%>) " object is created." "\n" "\n" "Defaults to " (racket (string-constant show/hide-replace-info)) ".") +@(defmethod (edit-menu:show/hide-replace-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item%) " object is created." "\n" "\n" "Defaults to " (racket (string-constant show/hide-replace-info)) ".") -@(defmethod (edit-menu:get-replace-item) (or/c false/c (is-a?/c menu-item<%>)) "This method returns the " (racket menu-item<%>) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-replace?) ").") +@(defmethod (edit-menu:get-replace-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (racket menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-replace?) ").") @(defmethod (edit-menu:create-replace?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (racket #f) ".") -@(defmethod (edit-menu:replace-callback (item (is-a?/c menu-item<%>)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (void)) " ") +@(defmethod (edit-menu:replace-callback (item (is-a?/c menu-item%)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (void)) " ") -@(defmethod (edit-menu:replace-on-demand (menu-item (is-a?/c menu-item<%>))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (void))) +@(defmethod (edit-menu:replace-on-demand (menu-item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (void))) -@(defmethod (edit-menu:replace-string) string? "The result of this method is used as the name of the " (racket menu-item<%>) "." "\n" "\n" "Defaults to " (racket (string-constant replace-menu-item)) ".") +@(defmethod (edit-menu:replace-string) string? "The result of this method is used as the name of the " (racket menu-item%) "." "\n" "\n" "Defaults to " (racket (string-constant replace-menu-item)) ".") -@(defmethod (edit-menu:replace-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item<%>) " object is created." "\n" "\n" "Defaults to " (racket (string-constant replace-info)) ".") +@(defmethod (edit-menu:replace-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item%) " object is created." "\n" "\n" "Defaults to " (racket (string-constant replace-info)) ".") -@(defmethod (edit-menu:get-replace-all-item) (or/c false/c (is-a?/c menu-item<%>)) "This method returns the " (racket menu-item<%>) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-replace-all?) ").") +@(defmethod (edit-menu:get-replace-all-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (racket menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-replace-all?) ").") @(defmethod (edit-menu:create-replace-all?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (racket #f) ".") -@(defmethod (edit-menu:replace-all-callback (item (is-a?/c menu-item<%>)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (void)) " ") +@(defmethod (edit-menu:replace-all-callback (item (is-a?/c menu-item%)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (void)) " ") -@(defmethod (edit-menu:replace-all-on-demand (menu-item (is-a?/c menu-item<%>))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (void))) +@(defmethod (edit-menu:replace-all-on-demand (menu-item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (void))) -@(defmethod (edit-menu:replace-all-string) string? "The result of this method is used as the name of the " (racket menu-item<%>) "." "\n" "\n" "Defaults to " (racket (string-constant replace-all-menu-item)) ".") +@(defmethod (edit-menu:replace-all-string) string? "The result of this method is used as the name of the " (racket menu-item%) "." "\n" "\n" "Defaults to " (racket (string-constant replace-all-menu-item)) ".") -@(defmethod (edit-menu:replace-all-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item<%>) " object is created." "\n" "\n" "Defaults to " (racket (string-constant replace-all-info)) ".") +@(defmethod (edit-menu:replace-all-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item%) " object is created." "\n" "\n" "Defaults to " (racket (string-constant replace-all-info)) ".") -@(defmethod (edit-menu:get-find-case-sensitive-item) (or/c false/c (is-a?/c menu-item<%>)) "This method returns the " (racket menu-item<%>) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-find-case-sensitive?) ").") +@(defmethod (edit-menu:get-find-case-sensitive-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (racket menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-find-case-sensitive?) ").") @(defmethod (edit-menu:create-find-case-sensitive?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (racket #f) ".") -@(defmethod (edit-menu:find-case-sensitive-callback (item (is-a?/c menu-item<%>)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (void)) " ") +@(defmethod (edit-menu:find-case-sensitive-callback (item (is-a?/c menu-item%)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (void)) " ") -@(defmethod (edit-menu:find-case-sensitive-on-demand (item (is-a?/c menu-item<%>))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (send item enable (let ((target (get-edit-target-object))) (and target (is-a? target editor<%>)))))) +@(defmethod (edit-menu:find-case-sensitive-on-demand (item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (send item enable (let ((target (get-edit-target-object))) (and target (is-a? target editor<%>)))))) -@(defmethod (edit-menu:find-case-sensitive-string) string? "The result of this method is used as the name of the " (racket menu-item<%>) "." "\n" "\n" "Defaults to " (racket (string-constant find-case-sensitive-menu-item)) ".") +@(defmethod (edit-menu:find-case-sensitive-string) string? "The result of this method is used as the name of the " (racket menu-item%) "." "\n" "\n" "Defaults to " (racket (string-constant find-case-sensitive-menu-item)) ".") -@(defmethod (edit-menu:find-case-sensitive-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item<%>) " object is created." "\n" "\n" "Defaults to " (racket (string-constant find-case-sensitive-info)) ".") +@(defmethod (edit-menu:find-case-sensitive-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item%) " object is created." "\n" "\n" "Defaults to " (racket (string-constant find-case-sensitive-info)) ".") -@(defmethod (edit-menu:between-find-and-preferences (menu (is-a?/c menu-item<%>))) void? "This method is called between the addition of the" "\n" (tt "find") " and the " (tt "preferences") " menu-item." "\n" "Override it to add additional menu items at that point. ") +@(defmethod (edit-menu:between-find-and-preferences (menu (is-a?/c menu-item%))) void? "This method is called between the addition of the" "\n" (tt "find") " and the " (tt "preferences") " menu-item." "\n" "Override it to add additional menu items at that point. ") -@(defmethod (edit-menu:get-preferences-item) (or/c false/c (is-a?/c menu-item<%>)) "This method returns the " (racket menu-item<%>) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-preferences?) ").") +@(defmethod (edit-menu:get-preferences-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (racket menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> edit-menu:create-preferences?) ").") @(defmethod (edit-menu:create-preferences?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (racket (not (current-eventspace-has-standard-menus?))) ".") -@(defmethod (edit-menu:preferences-callback (item (is-a?/c menu-item<%>)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (begin (preferences:show-dialog) #t)) " ") +@(defmethod (edit-menu:preferences-callback (item (is-a?/c menu-item%)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (begin (preferences:show-dialog) #t)) " ") -@(defmethod (edit-menu:preferences-on-demand (menu-item (is-a?/c menu-item<%>))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (void))) +@(defmethod (edit-menu:preferences-on-demand (menu-item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (void))) -@(defmethod (edit-menu:preferences-string) string? "The result of this method is used as the name of the " (racket menu-item<%>) "." "\n" "\n" "Defaults to " (racket (string-constant preferences-menu-item)) ".") +@(defmethod (edit-menu:preferences-string) string? "The result of this method is used as the name of the " (racket menu-item%) "." "\n" "\n" "Defaults to " (racket (string-constant preferences-menu-item)) ".") -@(defmethod (edit-menu:preferences-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item<%>) " object is created." "\n" "\n" "Defaults to " (racket (string-constant preferences-info)) ".") +@(defmethod (edit-menu:preferences-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item%) " object is created." "\n" "\n" "Defaults to " (racket (string-constant preferences-info)) ".") -@(defmethod (edit-menu:after-preferences (menu (is-a?/c menu-item<%>))) void? "This method is called " "after" " the addition of the" "\n" (tt "preferences") " menu-item. Override it to add additional" "\n" "menu items at that point. ") +@(defmethod (edit-menu:after-preferences (menu (is-a?/c menu-item%))) void? "This method is called " "after" " the addition of the" "\n" (tt "preferences") " menu-item. Override it to add additional" "\n" "menu items at that point. ") -@(defmethod (help-menu:before-about (menu (is-a?/c menu-item<%>))) void? "This method is called " "before" " the addition of the" "\n" (tt "about") " menu-item. Override it to add additional" "\n" "menu items at that point. ") +@(defmethod (help-menu:before-about (menu (is-a?/c menu-item%))) void? "This method is called " "before" " the addition of the" "\n" (tt "about") " menu-item. Override it to add additional" "\n" "menu items at that point. ") -@(defmethod (help-menu:get-about-item) (or/c false/c (is-a?/c menu-item<%>)) "This method returns the " (racket menu-item<%>) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> help-menu:create-about?) ").") +@(defmethod (help-menu:get-about-item) (or/c false/c (is-a?/c menu-item%)) "This method returns the " (racket menu-item%) " object corresponding" "\n" "to this menu item, if it has been created (as controlled by" "\n" (method frame:standard-menus<%> help-menu:create-about?) ").") @(defmethod (help-menu:create-about?) boolean? "The result of this method determines if the corresponding" "\n" "menu item is created. Override it to control the creation of the menu item." "\n" "\n" "Defaults to " (racket #f) ".") -@(defmethod (help-menu:about-callback (item (is-a?/c menu-item<%>)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (void)) " ") +@(defmethod (help-menu:about-callback (item (is-a?/c menu-item%)) (control (is-a?/c control-event%))) void? "Defaults to " (racketblock (void)) " ") -@(defmethod (help-menu:about-on-demand (menu-item (is-a?/c menu-item<%>))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (void))) +@(defmethod (help-menu:about-on-demand (menu-item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (void))) -@(defmethod (help-menu:about-string) string? "The result of this method is used as the name of the " (racket menu-item<%>) "." "\n" "\n" "Defaults to " (racket (string-constant about-menu-item)) ".") +@(defmethod (help-menu:about-string) string? "The result of this method is used as the name of the " (racket menu-item%) "." "\n" "\n" "Defaults to " (racket (string-constant about-menu-item)) ".") -@(defmethod (help-menu:about-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item<%>) " object is created." "\n" "\n" "Defaults to " (racket (string-constant about-info)) ".") +@(defmethod (help-menu:about-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item%) " object is created." "\n" "\n" "Defaults to " (racket (string-constant about-info)) ".") -@(defmethod (help-menu:after-about (menu (is-a?/c menu-item<%>))) void? "This method is called " "after" " the addition of the" "\n" (tt "about") " menu-item. Override it to add additional" "\n" "menu items at that point. ") +@(defmethod (help-menu:after-about (menu (is-a?/c menu-item%))) void? "This method is called " "after" " the addition of the" "\n" (tt "about") " menu-item. Override it to add additional" "\n" "menu items at that point. ") -} +} \ No newline at end of file diff --git a/doc/release-notes/drracket/HISTORY.txt b/doc/release-notes/drracket/HISTORY.txt index 365603d657..4c5d55e8a3 100644 --- a/doc/release-notes/drracket/HISTORY.txt +++ b/doc/release-notes/drracket/HISTORY.txt @@ -1,3 +1,12 @@ +------------------------------ + Version 5.2 +------------------------------ + + . changed a few menu keybidings: + "New Tab" is now -t + "Run" is now -r + "Replace" is now -shift-f + ------------------------------ Version 5.1.2 ------------------------------ From 49dbb5d963e7b7a21235b0a9ef3935cb08a980e0 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 1 Sep 2011 10:52:17 -0500 Subject: [PATCH 076/235] adjust the close/close window/close tab menu items to be more like other apps on the various platforms --- collects/drracket/private/unit.rkt | 60 +++++++++++-------- .../private/standard-menus-items.rkt | 4 +- collects/framework/private/standard-menus.rkt | 6 +- .../framework/standard-menus.scrbl | 2 +- .../private/english-string-constants.rkt | 4 +- 5 files changed, 48 insertions(+), 28 deletions(-) diff --git a/collects/drracket/private/unit.rkt b/collects/drracket/private/unit.rkt index 8af3376dff..00deb4df29 100644 --- a/collects/drracket/private/unit.rkt +++ b/collects/drracket/private/unit.rkt @@ -2974,22 +2974,33 @@ module browser threading seems wrong. (update-close-menu-item-shortcut (file-menu:get-close-item))) (define/private (update-close-tab-menu-item-shortcut item) - (let ([just-one? (and (pair? tabs) (null? (cdr tabs)))]) - (send item set-label (if just-one? - (string-constant close-tab) - (string-constant close-tab-amp))) - (when (preferences:get 'framework:menu-bindings) - (send item set-shortcut (if just-one? #f #\w))))) + (define just-one? (and (pair? tabs) (null? (cdr tabs)))) + (send item set-label (if just-one? + (string-constant close-tab) + (string-constant close-tab-amp))) + (when (preferences:get 'framework:menu-bindings) + (send item set-shortcut (if just-one? #f #\w)))) (define/private (update-close-menu-item-shortcut item) - (let ([just-one? (and (pair? tabs) (null? (cdr tabs)))]) - (send item set-label (if just-one? - (string-constant close-menu-item) - (string-constant close))) - (when (preferences:get 'framework:menu-bindings) - (send item set-shortcut-prefix (if just-one? - (get-default-shortcut-prefix) - (cons 'shift (get-default-shortcut-prefix))))))) + (cond + [(eq? (system-type) 'linux) + (send item set-label (string-constant close-menu-item))] + [else + (define just-one? (and (pair? tabs) (null? (cdr tabs)))) + (send item set-label (if just-one? + (string-constant close-window-menu-item) + (string-constant close-window))) + (when (preferences:get 'framework:menu-bindings) + (send item set-shortcut-prefix (if just-one? + (get-default-shortcut-prefix) + (cons 'shift (get-default-shortcut-prefix)))))])) + + (define/override (file-menu:close-callback item control) + (define just-one? (and (pair? tabs) (null? (cdr tabs)))) + (if (and (eq? (system-type) 'linux) + (not just-one?)) + (close-current-tab) + (super file-menu:close-callback item control))) ;; offer-to-save-file : path -> void ;; bring the tab that edits the file named by `path' to the front @@ -3330,16 +3341,17 @@ module browser threading seems wrong. (make-object separator-menu-item% file-menu))] (define close-tab-menu-item #f) (define/override (file-menu:between-close-and-quit file-menu) - (set! close-tab-menu-item - (new (get-menu-item%) - (label (string-constant close-tab)) - (demand-callback - (λ (item) - (send item enable (1 . < . (send tabs-panel get-number))))) - (parent file-menu) - (callback - (λ (x y) - (close-current-tab))))) + (unless (eq? (system-type) 'linux) + (set! close-tab-menu-item + (new (get-menu-item%) + (label (string-constant close-tab)) + (demand-callback + (λ (item) + (send item enable (1 . < . (send tabs-panel get-number))))) + (parent file-menu) + (callback + (λ (x y) + (close-current-tab)))))) (super file-menu:between-close-and-quit file-menu)) (define/override (file-menu:save-string) (string-constant save-definitions)) diff --git a/collects/framework/private/standard-menus-items.rkt b/collects/framework/private/standard-menus-items.rkt index 315ae51e1c..fa1abca2a6 100644 --- a/collects/framework/private/standard-menus-items.rkt +++ b/collects/framework/private/standard-menus-items.rkt @@ -265,7 +265,9 @@ '(λ (item control) (when (can-close?) (on-close) (show #f)) #t) #\w '(get-default-shortcut-prefix) - '(string-constant close-menu-item) + '(if (eq? (system-type) 'linux) + (string-constant close-menu-item) + (string-constant close-window-menu-item)) on-demand-do-nothing #t) (make-between 'file-menu 'close 'quit 'nothing) diff --git a/collects/framework/private/standard-menus.rkt b/collects/framework/private/standard-menus.rkt index ee2829ab60..0daadbb1cd 100644 --- a/collects/framework/private/standard-menus.rkt +++ b/collects/framework/private/standard-menus.rkt @@ -272,7 +272,11 @@ file-menu:close-callback (λ (item control) (when (can-close?) (on-close) (show #f)) #t)) (define/public (file-menu:get-close-item) file-menu:close-item) - (define/public (file-menu:close-string) (string-constant close-menu-item)) + (define/public + (file-menu:close-string) + (if (eq? (system-type) 'linux) + (string-constant close-menu-item) + (string-constant close-window-menu-item))) (define/public (file-menu:close-help-string) (string-constant close-info)) (define/public file-menu:close-on-demand (λ (menu-item) (void))) (define/public (file-menu:create-close?) #t) diff --git a/collects/scribblings/framework/standard-menus.scrbl b/collects/scribblings/framework/standard-menus.scrbl index 498ca26d45..e0f22dd621 100644 --- a/collects/scribblings/framework/standard-menus.scrbl +++ b/collects/scribblings/framework/standard-menus.scrbl @@ -118,7 +118,7 @@ @(defmethod (file-menu:close-on-demand (menu-item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (void))) -@(defmethod (file-menu:close-string) string? "The result of this method is used as the name of the " (racket menu-item%) "." "\n" "\n" "Defaults to " (racket (string-constant close-menu-item)) ".") +@(defmethod (file-menu:close-string) string? "The result of this method is used as the name of the " (racket menu-item%) "." "\n" "\n" "Defaults to " (racket (if (eq? (system-type) (quote linux)) (string-constant close-menu-item) (string-constant close-window-menu-item))) ".") @(defmethod (file-menu:close-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item%) " object is created." "\n" "\n" "Defaults to " (racket (string-constant close-info)) ".") diff --git a/collects/string-constants/private/english-string-constants.rkt b/collects/string-constants/private/english-string-constants.rkt index bb287fff8e..6441bc4086 100644 --- a/collects/string-constants/private/english-string-constants.rkt +++ b/collects/string-constants/private/english-string-constants.rkt @@ -113,9 +113,10 @@ please adhere to these guidelines: (untitled-n "Untitled ~a") (warning "Warning") (error "Error") - (close "Close") ;; as in, close an open window. must match close-menu-item + (close "Close") ;; as in, close an open window or tab. must match close-menu-item ;; in the sense that, when the &s have been stripped from ;; close-menu-item, it must be the same string as this. + (close-window "Close Window") (stop "Stop") (&stop "&Stop") ;; for use in button and menu item labels, with short cut. (are-you-sure-delete? "Are you sure you want to delete ~a?") ;; ~a is a filename or directory name @@ -674,6 +675,7 @@ please adhere to these guidelines: (close-info "Close this file") (close-menu-item "&Close") + (close-window-menu-item "&Close Window") (quit-info "Close all windows") (quit-menu-item-windows "E&xit") From 6e2487bffaf40fa2c4ff9dc42a0462011304866a Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Wed, 31 Aug 2011 12:11:33 -0600 Subject: [PATCH 077/235] Guide text for places --- collects/scribblings/guide/performance.scrbl | 1 + collects/scribblings/guide/places.scrbl | 93 ++++++++++++++++++++ 2 files changed, 94 insertions(+) create mode 100644 collects/scribblings/guide/places.scrbl diff --git a/collects/scribblings/guide/performance.scrbl b/collects/scribblings/guide/performance.scrbl index c52339611d..a1ff2a9a79 100644 --- a/collects/scribblings/guide/performance.scrbl +++ b/collects/scribblings/guide/performance.scrbl @@ -394,3 +394,4 @@ argument instead. @; ---------------------------------------------------------------------- @include-section["futures.scrbl"] +@include-section["places.scrbl"] diff --git a/collects/scribblings/guide/places.scrbl b/collects/scribblings/guide/places.scrbl new file mode 100644 index 0000000000..5d6dbce21e --- /dev/null +++ b/collects/scribblings/guide/places.scrbl @@ -0,0 +1,93 @@ +#lang scribble/doc +@(require scribble/manual "guide-utils.rkt" + (for-label racket/flonum racket/place)) + +@title[#:tag "effective-places"]{Parallelism with Places} + +The @racketmodname[racket/place] library provides support for +performance improvement through parallelism with the @racket[place] +form. Two places communicate using @racket[place-channel-put] and +@racket[place-channel-get] functions. Places contains the full +expressive power of the Racket language. However, the places design +restricts both the methods of inter-place communication and the type +of values permitted inside communication messages. + +The @racket[place] form spawns a new pristine racket execution +context, which the OS can schedule on any available processor. As a +starting example, the racket program below uses a place to determine +whether any number in the list has a double that is also in the list: + +@codeblock{ +#lang racket + +(provide main) + +(define (any-double? l) + (for/or ([i (in-list l)]) + (for/or ([i2 (in-list l)]) + (= i2 (* 2 i))))) + +(define (main) + (define p (place ch + (define l (place-channel-get ch)) + (define l-double? (any-double? l)) + (place-channel-put ch l-double?))) + + (place-channel-put p (list 1 2 4 8)) + (printf "Has double? ~a\n" (place-channel-get p)) + (place-wait p)) +} + +The first argument to the place form is an identifier, which the +@racket[place] form binds to an initial place-channel. The remaining +argument expressions form the body of the @racket[place] form. The +body expressions use the initial place-channel to communicate with the +place which spawned the new place. + +In the example above, the place form has a body of three expressions. +The first receives a list of numbers over the initial place-channel +(@racket[ch]) and binds the list to @racket[l]. The second body +expression calls any-double? on the list and binds the result to +@racket[l-double?]. The last body expression sends the +@racket[l-double?] result back to the invoking place over the +@racket[ch] place-channel. + +The macro that implements the @racket[place] form performs two actions with +subtle consequences. First, it lifts the place body to an anonymous +module-scope function. This has the consequence that any function +referred to by the place body must be defined at module-scope. Second, +the place form expands into a @racket[dynamic-place] call, which +@racket[dynamic-require]s the current module in a newly created place. +@margin-note{When using places inside DrRacket, the module containg +place code must be saved to a file before it will execute.} +As part of the @racket[dynamic-require] the current module body is +evaluated in the new place. The consequence of this second action is +that places forms must not be called at module-scope or indirectly by +functions which are invoked at module scope. Both of these errors are +demonstrated in the code bellow. Failing to follow this precaution +will result in an infinite spawning of places as each spawned place +evaluates the module body and spawns an additional place. + +@codeblock{ +#lang racket + +(provide main) + +; do not do this +(define p (place ch + (place-channel-get ch))) + +(define (indirect-place-invocation) + (define p2 (place ch + (place-channel-get ch)))) + + +; do not do this either +(indirect-place-invocation) +} + +The example above is executed by running @exec{racket -tm double.rkt} +from the command line. The @Flag{t} tells racket to load the +@tt{double.rkt} module. The @Flag{m} instructs racket to run the +@racket[main] module. + From 261f002ce275780bde3f8d2cfcbf80c28a859234 Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Wed, 31 Aug 2011 12:14:16 -0600 Subject: [PATCH 078/235] Error messages for using places with symbol module paths --- collects/racket/place.rkt | 8 ++++---- collects/tests/racket/place.rktl | 2 ++ src/racket/src/place.c | 3 +++ 3 files changed, 9 insertions(+), 4 deletions(-) diff --git a/collects/racket/place.rkt b/collects/racket/place.rkt index ff450f8bf4..a8bd6f8604 100644 --- a/collects/racket/place.rkt +++ b/collects/racket/place.rkt @@ -147,8 +147,7 @@ (syntax-case stx () [(_ ch body1 body ...) (begin - ;breaks valid uses of place - #;(unless (eq? 'module (syntax-local-context)) + #;(when (in-module-expansion?) (raise-syntax-error #f "can only be used in a module" stx)) (unless (identifier? #'ch) (raise-syntax-error #f "expected an indentifier" stx #'ch)) @@ -165,6 +164,7 @@ (resolved-module-path-name (variable-reference->resolved-module-path vr))) - (dynamic-place (if (symbol? name) `',name name) - func-name)) + (when (symbol? name) + (error 'place "the current module-path-name should be a path and not a symbol (if you are in DrRacket, save the file)")) + (dynamic-place name func-name)) diff --git a/collects/tests/racket/place.rktl b/collects/tests/racket/place.rktl index 87fbfbbdd3..4a15ac4427 100644 --- a/collects/tests/racket/place.rktl +++ b/collects/tests/racket/place.rktl @@ -5,6 +5,8 @@ (place-wait (place/base (p1 ch) (printf "Hello from place\n"))) +(err/rt-test (dynamic-place 'tmodule 'tfunc)) + (let ([p (place/base (p1 ch) (printf "Hello form place 2\n") (exit 99))]) diff --git a/src/racket/src/place.c b/src/racket/src/place.c index 97586d357d..ab403b0439 100644 --- a/src/racket/src/place.c +++ b/src/racket/src/place.c @@ -227,6 +227,9 @@ Scheme_Object *scheme_place(int argc, Scheme_Object *args[]) { if (!scheme_is_module_path(args[0]) && !SCHEME_PATHP(args[0])) { scheme_wrong_type("dynamic-place", "module-path or path", 0, argc, args); } + if (SCHEME_SYMBOLP(args[0])) { + scheme_wrong_type("dynamic-place", "non-symbol module-path", 0, argc, args); + } if (!SCHEME_SYMBOLP(args[1])) { scheme_wrong_type("dynamic-place", "symbol", 1, argc, args); } From 81f9bf4e1d3fc883f4eed0ce4d381f9de129cfea Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Thu, 1 Sep 2011 11:45:35 -0600 Subject: [PATCH 079/235] Fix dup errors, bignum deserialization, and port names across place channels Fix bignum deserialization Error reporting for failed dups during place channel communications communicate socket port names across place channels --- collects/tests/racket/place-channel-fd.rkt | 27 +++++++ collects/tests/racket/place-channel.rkt | 25 +----- src/racket/src/error.c | 13 +++ src/racket/src/mzmark_place.inc | 25 ++++++ src/racket/src/mzmarksrc.c | 9 +++ src/racket/src/network.c | 61 ++++++++++++-- src/racket/src/place.c | 94 ++++++++++++++-------- src/racket/src/port.c | 9 ++- src/racket/src/schpriv.h | 13 ++- 9 files changed, 213 insertions(+), 63 deletions(-) diff --git a/collects/tests/racket/place-channel-fd.rkt b/collects/tests/racket/place-channel-fd.rkt index 1218437138..d8a6fa3db4 100644 --- a/collects/tests/racket/place-channel-fd.rkt +++ b/collects/tests/racket/place-channel-fd.rkt @@ -4,6 +4,8 @@ racket/port racket/runtime-path racket/list + racket/tcp + racket/match rackunit (for-syntax racket/base)) @@ -84,4 +86,29 @@ (define i3 (open-input-file "test2")) (check-equal? #t #t "cleanup of unreceived port message") (place-channel-put p i3) + + + (define port-ch (make-channel)) + + (thread + (lambda () + (define p (place ch + (match (place-channel-get ch) + [(list in out) + (define x (read in)) + (printf "IN PLACE ~a\n" x) + (write (string-append "From Place " x) out) + (flush-output out)]))) + (define s (tcp-listen 0)) + (define-values (h1 p1 h2 p2) (tcp-addresses s #t)) + (printf "~a ~a ~a ~a\n" h1 p1 h2 p2) + (channel-put port-ch p1) + (define-values (in out) (tcp-accept s)) + (place-channel-put p (list in out)) + (place-wait p))) + + (define-values (in out) (tcp-connect "localhost" (channel-get port-ch))) + (write "Hello There" out) + (flush-output out) + (displayln (read in)) ) diff --git a/collects/tests/racket/place-channel.rkt b/collects/tests/racket/place-channel.rkt index 14acc72cbc..45844d4751 100644 --- a/collects/tests/racket/place-channel.rkt +++ b/collects/tests/racket/place-channel.rkt @@ -354,29 +354,6 @@ (test-long (lambda (x) (intern-num-sym (modulo x 1000))) "Listof symbols") (test-long (lambda (x) #s(clown "Binky" "pie")) "Listof prefabs") (test-long (lambda (x) (read (open-input-string "#0=(#0# . #0#)"))) "Listof cycles") - - (define port-ch (make-channel)) - - (thread - (lambda () - (define p (place ch - (match (place-channel-get ch) - [(list in out) - (define x (read in)) - (printf "IN PLACE ~a\n" x) - (write (string-append "From Place " x) out) - (flush-output out)]))) - (define s (tcp-listen 0)) - (define-values (h1 p1 h2 p2) (tcp-addresses s #t)) - (printf "~a ~a ~a ~a\n" h1 p1 h2 p2) - (channel-put port-ch p1) - (define-values (in out) (tcp-accept s)) - (place-channel-put p (list in out)) - (place-wait p))) - - (define-values (in out) (tcp-connect "localhost" (channel-get port-ch))) - (write "Hello There" out) - (flush-output out) - (displayln (read in))) +) ;(report-errs) diff --git a/src/racket/src/error.c b/src/racket/src/error.c index f13a9492da..087fb3ebb7 100644 --- a/src/racket/src/error.c +++ b/src/racket/src/error.c @@ -28,6 +28,11 @@ #ifdef DOS_FILE_SYSTEM # include #endif +#ifdef NO_ERRNO_GLOBAL +# define errno -1 +#else +# include +#endif #ifdef USE_C_SYSLOG # include # include @@ -157,6 +162,14 @@ static void default_output(char *s, intptr_t len) fflush(stderr); } +intptr_t scheme_errno() { +#ifdef WINDOWS_FILE_HANDLES + return GetLastError(); +#else + return errno; +#endif +} + Scheme_Config *scheme_init_error_escape_proc(Scheme_Config *config) { if (!def_error_esc_proc) { diff --git a/src/racket/src/mzmark_place.inc b/src/racket/src/mzmark_place.inc index 6d289c240e..fe45335c73 100644 --- a/src/racket/src/mzmark_place.inc +++ b/src/racket/src/mzmark_place.inc @@ -127,3 +127,28 @@ static int serialized_file_fd_val_FIXUP(void *p, struct NewGC *gc) { #define serialized_file_fd_val_IS_CONST_SIZE 1 +static int serialized_socket_fd_val_SIZE(void *p, struct NewGC *gc) { + return + gcBYTES_TO_WORDS(sizeof(Scheme_Serialized_Socket_FD)); +} + +static int serialized_socket_fd_val_MARK(void *p, struct NewGC *gc) { + Scheme_Serialized_Socket_FD *sfd = (Scheme_Serialized_Socket_FD *) p; + gcMARK2(sfd->name, gc); + + return + gcBYTES_TO_WORDS(sizeof(Scheme_Serialized_Socket_FD)); +} + +static int serialized_socket_fd_val_FIXUP(void *p, struct NewGC *gc) { + Scheme_Serialized_Socket_FD *sfd = (Scheme_Serialized_Socket_FD *) p; + gcFIXUP2(sfd->name, gc); + + return + gcBYTES_TO_WORDS(sizeof(Scheme_Serialized_Socket_FD)); +} + +#define serialized_socket_fd_val_IS_ATOMIC 0 +#define serialized_socket_fd_val_IS_CONST_SIZE 1 + + diff --git a/src/racket/src/mzmarksrc.c b/src/racket/src/mzmarksrc.c index 521dc4d6b2..250c6818ed 100644 --- a/src/racket/src/mzmarksrc.c +++ b/src/racket/src/mzmarksrc.c @@ -1478,6 +1478,15 @@ serialized_file_fd_val { gcBYTES_TO_WORDS(sizeof(Scheme_Serialized_File_FD)); } +serialized_socket_fd_val { + mark: + Scheme_Serialized_Socket_FD *sfd = (Scheme_Serialized_Socket_FD *) p; + gcMARK2(sfd->name, gc); + + size: + gcBYTES_TO_WORDS(sizeof(Scheme_Serialized_Socket_FD)); +} + END place; /**********************************************************************/ diff --git a/src/racket/src/network.c b/src/racket/src/network.c index a5233b3e7d..37e7b09c38 100644 --- a/src/racket/src/network.c +++ b/src/racket/src/network.c @@ -92,6 +92,10 @@ struct SOCKADDR_IN { extern int scheme_stupid_windows_machine; #endif +intptr_t scheme_socket_errno() { + return SOCK_ERRNO(); +} + #include "schfd.h" #define TCP_BUFFER_SIZE 4096 @@ -1435,7 +1439,7 @@ tcp_out_buffer_mode(Scheme_Port *p, int mode) } static Scheme_Object * -make_tcp_input_port(void *data, const char *name, Scheme_Object *cust) +make_tcp_input_port_symbol_name(void *data, Scheme_Object *name, Scheme_Object *cust) { Scheme_Input_Port *ip; @@ -1444,7 +1448,7 @@ make_tcp_input_port(void *data, const char *name, Scheme_Object *cust) ip = scheme_make_input_port(scheme_tcp_input_port_type, data, - scheme_intern_symbol(name), + name, tcp_get_string, NULL, scheme_progress_evt_via_get, @@ -1460,7 +1464,13 @@ make_tcp_input_port(void *data, const char *name, Scheme_Object *cust) } static Scheme_Object * -make_tcp_output_port(void *data, const char *name, Scheme_Object *cust) +make_tcp_input_port(void *data, const char *name, Scheme_Object *cust) +{ + return make_tcp_input_port_symbol_name(data, scheme_intern_symbol(name), cust); +} + +static Scheme_Object * +make_tcp_output_port_symbol_name(void *data, Scheme_Object *name, Scheme_Object *cust) { Scheme_Output_Port *op; @@ -1469,7 +1479,7 @@ make_tcp_output_port(void *data, const char *name, Scheme_Object *cust) op = scheme_make_output_port(scheme_tcp_output_port_type, data, - scheme_intern_symbol(name), + name, scheme_write_evt_via_write, tcp_write_string, (Scheme_Out_Ready_Fun)tcp_check_write, @@ -1484,6 +1494,12 @@ make_tcp_output_port(void *data, const char *name, Scheme_Object *cust) return (Scheme_Object *)op; } +static Scheme_Object * +make_tcp_output_port(void *data, const char *name, Scheme_Object *cust) +{ + return make_tcp_output_port_symbol_name(data, scheme_intern_symbol(name), cust); +} + #endif /* USE_TCP */ /*========================================================================*/ @@ -2513,12 +2529,47 @@ void scheme_socket_to_ports(intptr_t s, const char *name, int takeover, } } +void scheme_socket_to_input_port(intptr_t s, Scheme_Object *name, int takeover, + Scheme_Object **_inp) +{ + Scheme_Tcp *tcp; + Scheme_Object *v; + + tcp = make_tcp_port_data(s, takeover ? 1 : 2); + + v = make_tcp_input_port_symbol_name(tcp, name, NULL); + *_inp = v; + + if (takeover) { + REGISTER_SOCKET(s); + } +} + +void scheme_socket_to_output_port(intptr_t s, Scheme_Object *name, int takeover, + Scheme_Object **_outp) +{ + Scheme_Tcp *tcp; + Scheme_Object *v; + + tcp = make_tcp_port_data(s, takeover ? 1 : 2); + + v = make_tcp_output_port_symbol_name(tcp, name, NULL); + *_outp = v; + + if (takeover) { + REGISTER_SOCKET(s); + } +} + intptr_t scheme_dup_socket(intptr_t fd) { #ifdef USE_SOCKETS_TCP # ifdef USE_WINSOCK_TCP intptr_t nsocket; + intptr_t rc; WSAPROTOCOL_INFO protocolInfo; - WSADuplicateSocket(fd, GetCurrentProcessId(), &protocolInfo); + rc = WSADuplicateSocket(fd, GetCurrentProcessId(), &protocolInfo); + if (rc) + return rc; nsocket = WSASocket(FROM_PROTOCOL_INFO, FROM_PROTOCOL_INFO, FROM_PROTOCOL_INFO, &protocolInfo, 0, WSA_FLAG_OVERLAPPED); REGISTER_SOCKET(nsocket); return nsocket; diff --git a/src/racket/src/place.c b/src/racket/src/place.c index ab403b0439..8919bed514 100644 --- a/src/racket/src/place.c +++ b/src/racket/src/place.c @@ -898,18 +898,6 @@ static void push_duped_fd(Scheme_Object **fd_accumulators, intptr_t slot, intptr } } -static Scheme_Object *make_serialized_tcp_fd(intptr_t fd, intptr_t type, Scheme_Object **fd_accumulators) { - Scheme_Simple_Object *so; - int dupfd; - dupfd = scheme_dup_socket(fd); - push_duped_fd(fd_accumulators, 1, dupfd); - so = scheme_malloc_small_atomic_tagged(sizeof(Scheme_Simple_Object)); - so->iso.so.type = scheme_serialized_tcp_fd_type; - so->u.two_int_val.int1 = type; - so->u.two_int_val.int2 = dupfd; - return (Scheme_Object *)so; -} - static Scheme_Object *trivial_copy(Scheme_Object *so) { switch (SCHEME_TYPE(so)) { @@ -938,7 +926,8 @@ static Scheme_Object *trivial_copy(Scheme_Object *so) return NULL; } -static Scheme_Object *shallow_types_copy(Scheme_Object *so, Scheme_Hash_Table *ht, Scheme_Object **fd_accumulators,int copy, int can_raise_exn) { +static Scheme_Object *shallow_types_copy(Scheme_Object *so, Scheme_Hash_Table *ht, + Scheme_Object **fd_accumulators, intptr_t *delayed_errno, int copy, int can_raise_exn) { Scheme_Object *new_so; new_so = trivial_copy(so); @@ -961,8 +950,8 @@ static Scheme_Object *shallow_types_copy(Scheme_Object *so, Scheme_Hash_Table *h Scheme_Object *d; n = scheme_rational_numerator(so); d = scheme_rational_denominator(so); - n = shallow_types_copy(n, NULL, fd_accumulators, copy, can_raise_exn); - d = shallow_types_copy(d, NULL, fd_accumulators, copy, can_raise_exn); + n = shallow_types_copy(n, NULL, fd_accumulators, delayed_errno, copy, can_raise_exn); + d = shallow_types_copy(d, NULL, fd_accumulators, delayed_errno, copy, can_raise_exn); if (copy) new_so = scheme_make_rational(n, d); } @@ -981,8 +970,8 @@ static Scheme_Object *shallow_types_copy(Scheme_Object *so, Scheme_Hash_Table *h Scheme_Object *i; r = scheme_complex_real_part(so); i = scheme_complex_imaginary_part(so); - r = shallow_types_copy(r, NULL, fd_accumulators, copy, can_raise_exn); - i = shallow_types_copy(i, NULL, fd_accumulators, copy, can_raise_exn); + r = shallow_types_copy(r, NULL, fd_accumulators, delayed_errno, copy, can_raise_exn); + i = shallow_types_copy(i, NULL, fd_accumulators, delayed_errno, copy, can_raise_exn); if (copy) new_so = scheme_make_complex(r, i); } @@ -1065,7 +1054,7 @@ static Scheme_Object *shallow_types_copy(Scheme_Object *so, Scheme_Hash_Table *h o->type = scheme_cpointer_type; SCHEME_CPTR_FLAGS(o) |= 0x1; SCHEME_CPTR_VAL(o) = SCHEME_CPTR_VAL(so); - o2 = shallow_types_copy(SCHEME_CPTR_TYPE(so), NULL, fd_accumulators, copy, can_raise_exn); + o2 = shallow_types_copy(SCHEME_CPTR_TYPE(so), NULL, fd_accumulators, delayed_errno, copy, can_raise_exn); SCHEME_CPTR_TYPE(o) = o2; new_so = o; @@ -1082,7 +1071,30 @@ static Scheme_Object *shallow_types_copy(Scheme_Object *so, Scheme_Hash_Table *h intptr_t fd; if(scheme_get_port_socket(so, &fd)) { if (copy) { - new_so = make_serialized_tcp_fd(fd, so->type, fd_accumulators); + Scheme_Object *tmp; + Scheme_Object *portname; + Scheme_Serialized_Socket_FD *ssfd; + int dupfd; + dupfd = scheme_dup_socket(fd); + if (dupfd == -1) { + if (can_raise_exn) + scheme_raise_exn(MZEXN_FAIL_NETWORK, "dup: error duplicating socket(%e)", scheme_socket_errno()); + if (delayed_errno) { + intptr_t tmp; + tmp = scheme_socket_errno(); + *delayed_errno = tmp; + } + return NULL; + } + push_duped_fd(fd_accumulators, 1, dupfd); + ssfd = scheme_malloc_tagged(sizeof(Scheme_Serialized_Socket_FD)); + ssfd->so.type = scheme_serialized_tcp_fd_type; + ssfd->type = so->type; + ssfd->fd = dupfd; + portname = scheme_port_name(so); + tmp = shallow_types_copy(portname, ht, fd_accumulators, delayed_errno, copy, can_raise_exn); + ssfd->name = tmp; + return (Scheme_Object *)ssfd; } } else if (SCHEME_TRUEP(scheme_file_stream_port_p(1, &so))) { @@ -1093,11 +1105,19 @@ static Scheme_Object *shallow_types_copy(Scheme_Object *so, Scheme_Hash_Table *h sffd = scheme_malloc_tagged(sizeof(Scheme_Serialized_File_FD)); sffd->so.type = scheme_serialized_file_fd_type; scheme_get_serialized_fd_flags(so, sffd); - if (sffd->name) { - tmp = shallow_types_copy(sffd->name, ht, fd_accumulators, copy, can_raise_exn); - sffd->name = tmp; - } + tmp = shallow_types_copy(sffd->name, ht, fd_accumulators, delayed_errno, copy, can_raise_exn); + sffd->name = tmp; dupfd = scheme_dup_file(fd); + if (dupfd == -1) { + if (can_raise_exn) + scheme_raise_exn(MZEXN_FAIL_FILESYSTEM, "dup: error duplicating file descriptor(%e)", scheme_errno()); + if (delayed_errno) { + intptr_t tmp; + tmp = scheme_errno(); + *delayed_errno = tmp; + } + return NULL; + } push_duped_fd(fd_accumulators, 0, dupfd); sffd->fd = dupfd; sffd->type = so->type; @@ -1118,15 +1138,20 @@ static Scheme_Object *shallow_types_copy(Scheme_Object *so, Scheme_Hash_Table *h { Scheme_Object *in; Scheme_Object *out; - int type = ((Scheme_Simple_Object *) so)->u.two_int_val.int1; - int fd = ((Scheme_Simple_Object *) so)->u.two_int_val.int2; - scheme_socket_to_ports(fd, "", 1, &in, &out); + Scheme_Object *name; + int type = ((Scheme_Serialized_Socket_FD *) so)->type; + int fd = ((Scheme_Serialized_Socket_FD *) so)->fd; + name = ((Scheme_Serialized_Socket_FD *) so)->name; + + //scheme_socket_to_ports(fd, "tcp-accepted", 1, &in, &out); if (type == scheme_input_port_type) { - scheme_tcp_abandon_port(out); + scheme_socket_to_input_port(fd, name, 1, &in); + //scheme_tcp_abandon_port(out); new_so = in; } else { - scheme_tcp_abandon_port(in); + scheme_socket_to_output_port(fd, name, 1, &out); + //scheme_tcp_abandon_port(in); new_so = out; } } @@ -1307,6 +1332,7 @@ static Scheme_Object *places_deep_copy_worker(Scheme_Object *so, Scheme_Hash_Tab uintptr_t inf_stack_depth = 0; Scheme_Object *fd_accumulators = NULL; + intptr_t delayed_errno = 0; /* lifted variables for xform*/ Scheme_Object *pair; @@ -1343,7 +1369,7 @@ static Scheme_Object *places_deep_copy_worker(Scheme_Object *so, Scheme_Hash_Tab int ctr = 0; /* First, check for simple values that don't need to be hashed: */ - new_so = shallow_types_copy(so, *ht, &fd_accumulators, copy, can_raise_exn); + new_so = shallow_types_copy(so, *ht, &fd_accumulators, &delayed_errno, copy, can_raise_exn); if (new_so) return new_so; if (*ht) { @@ -1379,7 +1405,7 @@ DEEP_DO: } } - new_so = shallow_types_copy(so, *ht, &fd_accumulators, copy, can_raise_exn); + new_so = shallow_types_copy(so, *ht, &fd_accumulators, &delayed_errno, copy, can_raise_exn); if (new_so) RETURN; new_so = so; @@ -1606,6 +1632,8 @@ DEEP_SST2_L: } break; default: + if (delayed_errno) + scheme_warning("Error serializing place message: %e", delayed_errno); bad_place_message2(so, fd_accumulators, can_raise_exn); new_so = NULL; ABORT; @@ -1946,6 +1974,7 @@ static void places_deserialize_clean_worker(Scheme_Object **pso, Scheme_Hash_Tab case scheme_integer_type: case scheme_place_bi_channel_type: /* allocated in the master and can be passed along as is */ case scheme_char_type: + case scheme_bignum_type: case scheme_rational_type: case scheme_float_type: case scheme_double_type: @@ -1973,7 +2002,7 @@ static void places_deserialize_clean_worker(Scheme_Object **pso, Scheme_Hash_Tab scheme_close_socket_fd(fd); } else { - tmp = shallow_types_copy(so, NULL, NULL, 1, 1); + tmp = shallow_types_copy(so, NULL, NULL, NULL, 1, 1); *pso = tmp; } break; @@ -1984,7 +2013,7 @@ static void places_deserialize_clean_worker(Scheme_Object **pso, Scheme_Hash_Tab scheme_close_file_fd(sffd->fd); } else { - tmp = shallow_types_copy(so, NULL, NULL, 1, 1); + tmp = shallow_types_copy(so, NULL, NULL, NULL, 1, 1); *pso = tmp; } break; @@ -2552,6 +2581,7 @@ static void register_traversers(void) GC_REG_TRAV(scheme_place_async_channel_type, place_async_channel_val); GC_REG_TRAV(scheme_place_bi_channel_type, place_bi_channel_val); GC_REG_TRAV(scheme_serialized_file_fd_type, serialized_file_fd_val); + GC_REG_TRAV(scheme_serialized_tcp_fd_type, serialized_socket_fd_val); } END_XFORM_SKIP; diff --git a/src/racket/src/port.c b/src/racket/src/port.c index ad4d4c7996..46924d65c1 100644 --- a/src/racket/src/port.c +++ b/src/racket/src/port.c @@ -286,6 +286,13 @@ typedef struct Scheme_FD { # endif } Scheme_FD; +Scheme_Object *scheme_port_name(Scheme_Object *p) { + if (p->type == scheme_input_port_type) + return ((Scheme_Input_Port *)p)->name; + else + return ((Scheme_Output_Port *)p)->name; +} + int scheme_get_serialized_fd_flags(Scheme_Object* p, Scheme_Serialized_File_FD *so) { Scheme_FD *fds; if (p->type == scheme_input_port_type) { @@ -294,7 +301,7 @@ int scheme_get_serialized_fd_flags(Scheme_Object* p, Scheme_Serialized_File_FD * } else { fds = (Scheme_FD *) ((Scheme_Output_Port *)p)->port_data; - so->name = ((Scheme_Input_Port *)p)->name; + so->name = ((Scheme_Output_Port *)p)->name; } so->regfile = fds->regfile; so->textmode = fds->textmode; diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index 593a36af11..0f6cc2429c 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -3482,6 +3482,7 @@ int scheme_byte_ready_or_user_port_ready(Scheme_Object *p, Scheme_Schedule_Info int scheme_pipe_char_count(Scheme_Object *p); void scheme_alloc_global_fdset(); +Scheme_Object *scheme_port_name(Scheme_Object *p); #define CURRENT_INPUT_PORT(config) scheme_get_param(config, MZCONFIG_INPUT_PORT) #define CURRENT_OUTPUT_PORT(config) scheme_get_param(config, MZCONFIG_OUTPUT_PORT) @@ -3692,13 +3693,23 @@ typedef struct Scheme_Serialized_File_FD{ char flush_mode; } Scheme_Serialized_File_FD; +typedef struct Scheme_Serialized_Socket_FD{ + Scheme_Object so; + Scheme_Object *name; + intptr_t fd; + intptr_t type; +} Scheme_Serialized_Socket_FD; + int scheme_get_serialized_fd_flags(Scheme_Object* p, Scheme_Serialized_File_FD *so); intptr_t scheme_dup_socket(intptr_t fd); intptr_t scheme_dup_file(intptr_t fd); void scheme_close_socket_fd(intptr_t fd); void scheme_close_file_fd(intptr_t fd); void scheme_tcp_abandon_port(Scheme_Object *port); - +intptr_t scheme_socket_errno(); +intptr_t scheme_errno(); +void scheme_socket_to_input_port(intptr_t s, Scheme_Object *name, int takeover, Scheme_Object **_inp); +void scheme_socket_to_output_port(intptr_t s, Scheme_Object *name, int takeover, Scheme_Object **_outp); #define SCHEME_PLACE_OBJECTP(o) (SCHEME_TYPE(o) == scheme_place_object_type) From 7b97d096373bf2fa8e92d1b831b56c1003ba5bc7 Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Thu, 1 Sep 2011 12:02:04 -0600 Subject: [PATCH 080/235] Add tests to props file --- collects/meta/props | 3 +++ 1 file changed, 3 insertions(+) diff --git a/collects/meta/props b/collects/meta/props index c3d80495b9..4344a49b8b 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1840,7 +1840,10 @@ 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-chan-rand-help.rkt" responsible (tewk) "collects/tests/racket/place-chan-rand.rkt" responsible (tewk) drdr:random #t +"collects/tests/racket/place-channel-fd.rkt" responsible (tewk) drdr:command-line (racket "-tm" *) +"collects/tests/racket/place-channel-fd2.rkt" responsible (tewk) drdr:command-line (racket "-tm" *) "collects/tests/racket/place-channel-ffi.rkt" responsible (tewk) drdr:command-line (racket "-tm" *) +"collects/tests/racket/place-channel-socket.rkt" responsible (tewk) drdr:command-line (racket "-tm" *) "collects/tests/racket/place-channel.rkt" responsible (tewk) drdr:command-line (racket "-tm" *) drdr:timeout 300 "collects/tests/racket/place.rktl" responsible (tewk) drdr:command-line (racket "-f" *) "collects/tests/racket/port.rktl" drdr:command-line #f From 29205fa91ab40fde3ea8fe7e088107d3ff55b28b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 1 Sep 2011 12:41:26 -0600 Subject: [PATCH 081/235] fix changes to command-line handle that broke the Windows build --- src/racket/cmdline.inc | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/racket/cmdline.inc b/src/racket/cmdline.inc index 3372ca2af3..93385072c0 100644 --- a/src/racket/cmdline.inc +++ b/src/racket/cmdline.inc @@ -862,7 +862,7 @@ static int run_from_cmd_line(int argc, char *_argv[], --argc; if (!*(argv[0])) { /* #f => no collects path */ - collects_path = scheme_false; + collects_path = scheme_make_false(); } else collects_path = check_make_path(prog, real_switch, argv[0]); was_config_flag = 1; @@ -1180,12 +1180,12 @@ static int run_from_cmd_line(int argc, char *_argv[], /* Setup path for "collects" collection directory: */ if (!collects_path) { if (!_coldir[_coldir_offset]) - collects_path = scheme_false; + collects_path = scheme_make_false(); else collects_path = scheme_make_path(_coldir XFORM_OK_PLUS _coldir_offset); - } else if (!SCHEME_FALSEP(collects_path)) + } else if (!SAME_OBJ(collects_path, scheme_make_false())) collects_path = scheme_path_to_complete_path(collects_path, NULL); - if (SCHEME_FALSEP(collects_path)) { + if (SAME_OBJ(collects_path, scheme_make_false())) { /* empty list of directories => don't set collection dirs and don't use collection links files */ skip_coll_dirs = 1; From dbcf70db30a306a5b9be01b931f78356ca14b7da Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Thu, 1 Sep 2011 14:54:25 -0600 Subject: [PATCH 082/235] Fix check for interactively defined module paths. --- collects/tests/racket/place.rktl | 3 ++- src/racket/src/place.c | 7 +++++-- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/collects/tests/racket/place.rktl b/collects/tests/racket/place.rktl index 4a15ac4427..52b4f8bff5 100644 --- a/collects/tests/racket/place.rktl +++ b/collects/tests/racket/place.rktl @@ -5,7 +5,6 @@ (place-wait (place/base (p1 ch) (printf "Hello from place\n"))) -(err/rt-test (dynamic-place 'tmodule 'tfunc)) (let ([p (place/base (p1 ch) (printf "Hello form place 2\n") @@ -32,6 +31,8 @@ (err/rt-test (dynamic-place "foo.rkt")) (err/rt-test (dynamic-place null 10)) (err/rt-test (dynamic-place "foo.rkt" 10)) +(err/rt-test (dynamic-place '(quote some-module) 'tfunc)) + (let ([p (place/base (p1 ch) (printf "Hello form place 2\n") diff --git a/src/racket/src/place.c b/src/racket/src/place.c index 8919bed514..3567402f2d 100644 --- a/src/racket/src/place.c +++ b/src/racket/src/place.c @@ -24,6 +24,7 @@ static Scheme_Object* scheme_place_enabled(int argc, Scheme_Object *args[]); static Scheme_Object* scheme_place_shared(int argc, Scheme_Object *args[]); THREAD_LOCAL_DECL(int scheme_current_place_id); +ROSYM static Scheme_Object *quote_symbol; #ifdef MZ_USE_PLACES @@ -132,6 +133,8 @@ void scheme_init_place(Scheme_Env *env) #endif scheme_finish_primitive_module(plenv); + REGISTER_SO(quote_symbol); + quote_symbol = scheme_intern_symbol("quote"); } static Scheme_Object* scheme_place_enabled(int argc, Scheme_Object *args[]) { @@ -227,8 +230,8 @@ Scheme_Object *scheme_place(int argc, Scheme_Object *args[]) { if (!scheme_is_module_path(args[0]) && !SCHEME_PATHP(args[0])) { scheme_wrong_type("dynamic-place", "module-path or path", 0, argc, args); } - if (SCHEME_SYMBOLP(args[0])) { - scheme_wrong_type("dynamic-place", "non-symbol module-path", 0, argc, args); + if (SCHEME_PAIRP(args[0]) && SAME_OBJ(SCHEME_CAR(args[0]), quote_symbol)) { + scheme_wrong_type("dynamic-place", "non-interactively defined module-path", 0, argc, args); } if (!SCHEME_SYMBOLP(args[1])) { scheme_wrong_type("dynamic-place", "symbol", 1, argc, args); From ec56bffe4a4d41773d746a29e145b48a298e333e Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Tue, 23 Aug 2011 13:46:28 -0400 Subject: [PATCH 083/235] added a warning concerning cross-platform workings of teachpack --- .../teachpack/2htdp/scribblings/batch-io.scrbl | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/collects/teachpack/2htdp/scribblings/batch-io.scrbl b/collects/teachpack/2htdp/scribblings/batch-io.scrbl index 1afb0b4717..c007cc6186 100644 --- a/collects/teachpack/2htdp/scribblings/batch-io.scrbl +++ b/collects/teachpack/2htdp/scribblings/batch-io.scrbl @@ -45,6 +45,9 @@ The batch-io teachpack introduces several functions and a form for reading content from files and one function for writing to a file. +@; ----------------------------------------------------------------------------- +@section{IO Functions} + All functions that read a file consume the name of a file and possibly additional arguments. They assume that the specified file exists in the same folder as the program; if not they signal an error: @@ -148,6 +151,17 @@ There is only one writer function at the moment: (with-handlers ([exn:fail:filesystem? void]) (delete-file "output.txt"))) +@bold{Warning}: The file IO functions in this teachpack are platform + dependent. That is, as long as your programs and your files live on the + same platform, you should not have any problems reading the files that + programs wrote and vice versa. If, however, one of your programs writes a + file on a Windows operating system and if you then copy this output file + to a Mac, reading the copied text file may produce extraneous ``return'' + characters. Note that this describes only one example of possible + malfunction; there are other cases when trans-platform actions may cause + this teachpack to fail. + +@; ----------------------------------------------------------------------------- @section{Testing} @defform[(simulate-file process str ...)]{ From fcf4936592928e7d9987552be5365c0f59a92c56 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Thu, 1 Sep 2011 12:21:08 -0400 Subject: [PATCH 084/235] improved error messages when handlers fail check-with tests --- collects/2htdp/private/checked-cell.rkt | 7 ++++++- .../2htdp/private/clauses-spec-and-process.rkt | 5 ++++- .../2htdp/{tests-failed => tests}/key-error.rkt | 15 +++++++++++++++ collects/2htdp/xtest | 2 ++ 4 files changed, 27 insertions(+), 2 deletions(-) rename collects/2htdp/{tests-failed => tests}/key-error.rkt (59%) diff --git a/collects/2htdp/private/checked-cell.rkt b/collects/2htdp/private/checked-cell.rkt index 0f69390edc..357dfed519 100644 --- a/collects/2htdp/private/checked-cell.rkt +++ b/collects/2htdp/private/checked-cell.rkt @@ -68,9 +68,14 @@ (tp-error 'check-with "the test function ~a is expected to return a boolean, but it returned ~v" (object-name ok?) b)) (unless b + (define check-with-name + (let ([n (symbol->string (object-name ok?))]) + (if (regexp-match "check-with" n) + "handler" + n))) (tp-error 'check-with "~a ~a ~v, which fails to pass check-with's ~a test" tag (if say-evaluated-to "evaluated to" "returned") - nw (object-name ok?))) + nw check-with-name)) nw)) ;; Symbol Any -> Void diff --git a/collects/2htdp/private/clauses-spec-and-process.rkt b/collects/2htdp/private/clauses-spec-and-process.rkt index 6c281fa338..798b7c8d15 100644 --- a/collects/2htdp/private/clauses-spec-and-process.rkt +++ b/collects/2htdp/private/clauses-spec-and-process.rkt @@ -86,7 +86,10 @@ [(null? spec) #false] [(or (free-identifier=? (caar spec) kw) (free-identifier=? (caar spec) kw-alt)) - (syntax->list (cdar spec))] + ; (syntax->list (cdar spec)) + (for/list ([i (syntax->list (cdar spec))]) + (define n (string->symbol (format "~a handler" (syntax-e (caar spec))))) + (syntax-property i 'inferred-name n))] [else (loop (cdr spec))]))) (if r ((third s) r) (fourth s))) Spec)) diff --git a/collects/2htdp/tests-failed/key-error.rkt b/collects/2htdp/tests/key-error.rkt similarity index 59% rename from collects/2htdp/tests-failed/key-error.rkt rename to collects/2htdp/tests/key-error.rkt index 805b6dabcd..eae0051257 100644 --- a/collects/2htdp/tests-failed/key-error.rkt +++ b/collects/2htdp/tests/key-error.rkt @@ -18,3 +18,18 @@ (unless (and hdl (cons? (regexp-match "on-tick" (second hdl)))) (error 'test "expected: \"on-tick\", actual: ~e" (second hdl)))))) (main)) + + +(define (my-fun x) "hi") + +(with-handlers ((exn:fail? + (lambda (x) + (define msg (exn-message x)) + (define hdl (regexp-match "check-with's handler test" msg)) + (unless hdl + (error 'test "expected: \"check-with's handler test, error says: ~e" msg))))) + (big-bang 0 + [to-draw (lambda (x) (circle 1 'solid 'red))] + [on-tick (lambda (x) (my-fun x))] + [check-with (lambda (x) (number? x))]) + (raise `(bad "must fail"))) diff --git a/collects/2htdp/xtest b/collects/2htdp/xtest index 9ba11282ef..52553b9325 100755 --- a/collects/2htdp/xtest +++ b/collects/2htdp/xtest @@ -10,6 +10,7 @@ run() { cd tests +run key-error.rkt run bad-draw.rkt run error-in-tick.rkt run error-in-draw.rkt @@ -34,3 +35,4 @@ run record-stop-when.rkt run stop-when-crash.rkt run on-tick-universe-with-limit.rkt run on-tick-with-limit.rkt + From 645f611ae77cda0a08a49286835e2581bf3de8cf Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 1 Sep 2011 17:36:28 -0400 Subject: [PATCH 085/235] Remove vestigial require. --- collects/typed-scheme/base-env/base-special-env.rkt | 1 - 1 file changed, 1 deletion(-) diff --git a/collects/typed-scheme/base-env/base-special-env.rkt b/collects/typed-scheme/base-env/base-special-env.rkt index feca7b9e6a..cc2e1e30c8 100644 --- a/collects/typed-scheme/base-env/base-special-env.rkt +++ b/collects/typed-scheme/base-env/base-special-env.rkt @@ -13,7 +13,6 @@ (except-in (rep filter-rep object-rep type-rep) make-arr) (types convenience union) (only-in (types convenience) [make-arr* make-arr]) - (for-template ) (for-syntax racket/base syntax/parse (only-in racket/syntax syntax-local-eval))) (define-syntax (define-initial-env stx) From feefa31401e4eccc7fbe2e60fd018e830f019254 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 1 Sep 2011 18:31:17 -0400 Subject: [PATCH 086/235] Change the logging level for the optimizer logs. --- collects/typed-scheme/optimizer/logging.rkt | 4 ++-- collects/typed-scheme/scribblings/guide/optimization.scrbl | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/typed-scheme/optimizer/logging.rkt b/collects/typed-scheme/optimizer/logging.rkt index 06f26eb18b..e8e7b29a02 100644 --- a/collects/typed-scheme/optimizer/logging.rkt +++ b/collects/typed-scheme/optimizer/logging.rkt @@ -214,7 +214,7 @@ (define logger (current-logger)) (add-missed-opts-to-log) (for ([x (sort-log)]) - (log-message logger 'warning + (log-message logger 'debug (format-log-entry x) (cons optimization-log-key x)))) @@ -232,7 +232,7 @@ ;; only intercepts TR log messages (define (with-intercepted-tr-logging interceptor thunk) (with-intercepted-logging - #:level 'warning + #:level 'debug (lambda (l) ;; look only for optimizer messages (when (log-message-from-tr-opt? l) (interceptor l))) diff --git a/collects/typed-scheme/scribblings/guide/optimization.scrbl b/collects/typed-scheme/scribblings/guide/optimization.scrbl index bcf017696b..5a49236347 100644 --- a/collects/typed-scheme/scribblings/guide/optimization.scrbl +++ b/collects/typed-scheme/scribblings/guide/optimization.scrbl @@ -181,8 +181,8 @@ can as a starting point for performance debugging. Similar information (albeit without in-depth explanations or advice) is available from the command line. When compiling a Typed Racket program, setting the racket @seclink[#:doc '(lib "scribblings/reference/reference.scrbl") -"logging"]{logging} facilities to the @racket['warning] level causes Typed +"logging"]{logging} facilities to the @racket['debug] level causes Typed Racket to display performance debugging information. Setting the Racket logging level can be done on the command line with the @racket[-W] flag: -@commandline{racket -W warning my-typed-program.rkt} +@commandline{racket -W debug my-typed-program.rkt} From 8c7846fff42bae93c711a18279b74f3050f915ac Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 1 Sep 2011 18:03:07 -0500 Subject: [PATCH 087/235] fix bug that inhibited certain menus from appearing. Also Rackety closes PR 12155 --- collects/drracket/private/syncheck/gui.rkt | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/collects/drracket/private/syncheck/gui.rkt b/collects/drracket/private/syncheck/gui.rkt index 5bdb6b7db1..e617784dc5 100644 --- a/collects/drracket/private/syncheck/gui.rkt +++ b/collects/drracket/private/syncheck/gui.rkt @@ -538,14 +538,13 @@ If the namespace does not, they are colored the unbound color. [else #f])) (define/public (syncheck:add-require-open-menu text start-pos end-pos file) - (define (make-require-open-menu file) - (λ (menu) - (let-values ([(base name dir?) (split-path file)]) - (instantiate menu-item% () - (label (fw:gui-utils:format-literal-label (string-constant cs-open-file) (path->string name))) - (parent menu) - (callback (λ (x y) (fw:handler:edit-file file)))) - (void)))) + (define ((make-require-open-menu file) menu) + (define-values (base name dir?) (split-path file)) + (new menu-item% + (label (fw:gui-utils:format-literal-label (string-constant cs-open-file) (path->string name))) + (parent menu) + (callback (λ (x y) (fw:handler:edit-file file)))) + (void)) (syncheck:add-menu text start-pos end-pos #f (make-require-open-menu file))) (define/public (syncheck:add-docs-menu text start-pos end-pos id the-label path tag) @@ -666,7 +665,7 @@ If the namespace does not, they are colored the unbound color. (define/private (syncheck:add-menu text start-pos end-pos key make-menu) (when arrow-records - (when (and (<= 0 start-pos end-pos (last-position))) + (when (<= 0 start-pos end-pos (last-position)) (add-to-range/key text start-pos end-pos make-menu key (and key #t))))) (define/public (syncheck:add-background-color text start fin color) @@ -880,7 +879,6 @@ If the namespace does not, they are colored the unbound color. (define last-known-mouse-x #f) (define last-known-mouse-y #f) (define/override (on-event event) - (cond [(send event leaving?) (set! last-known-mouse-x #f) @@ -970,7 +968,8 @@ If the namespace does not, they are colored the unbound color. [arrows (filter arrow? vec-ents)] [def-links (filter def-link? vec-ents)] [var-arrows (filter var-arrow? arrows)] - [add-menus (map cdr (filter pair? vec-ents))]) + [add-menus (append (map cdr (filter pair? vec-ents)) + (filter procedure? vec-ents))]) (unless (null? arrows) (make-object menu-item% (string-constant cs-tack/untack-arrow) From 92ec3b5f0c95eb1b3b84611ad5d269aef4e9b276 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 1 Sep 2011 21:22:35 -0500 Subject: [PATCH 088/235] added back the accidentally deleted port-count-lines! call (this was actually already covered in existing drracket test suites) closes PR 12161 --- collects/drracket/private/unit.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/drracket/private/unit.rkt b/collects/drracket/private/unit.rkt index 00deb4df29..cc1d82c19d 100644 --- a/collects/drracket/private/unit.rkt +++ b/collects/drracket/private/unit.rkt @@ -2650,6 +2650,7 @@ module browser threading seems wrong. (send defs-copy set-style-list (send definitions-text get-style-list)) ;; speeds up the copy (send definitions-text copy-self-to defs-copy) (define text-port (open-input-text-editor defs-copy 0 'end values name #t)) + (port-count-lines! text-port) (send interactions-text evaluate-from-port text-port #t From d857385797f20271612ad01940e96d0f1d6f7578 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 2 Sep 2011 06:27:07 -0600 Subject: [PATCH 089/235] cocoa: fix switch-to-gui-app for 64-bit --- collects/mred/private/wx/cocoa/queue.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 42c848ed6f..7e79f60759 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -82,8 +82,8 @@ ;; explicitly register with the dock so the application can receive ;; keyboard events. (define-cstruct _ProcessSerialNumber - ([highLongOfPSN _ulong] - [lowLongOfPSN _ulong])) + ([highLongOfPSN _uint32] + [lowLongOfPSN _uint32])) (define kCurrentProcess 2) (define kProcessTransformToForegroundApplication 1) (define-appserv TransformProcessType (_fun _ProcessSerialNumber-pointer From 171858add12c3f801b08beba6f32025283d477d7 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 2 Sep 2011 08:57:28 -0500 Subject: [PATCH 090/235] wrong check for the result of system-type --- collects/drracket/private/unit.rkt | 6 +++--- collects/framework/private/standard-menus-items.rkt | 2 +- collects/framework/private/standard-menus.rkt | 2 +- collects/scribblings/framework/standard-menus.scrbl | 2 +- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/collects/drracket/private/unit.rkt b/collects/drracket/private/unit.rkt index cc1d82c19d..4e0c5e5fa0 100644 --- a/collects/drracket/private/unit.rkt +++ b/collects/drracket/private/unit.rkt @@ -2984,7 +2984,7 @@ module browser threading seems wrong. (define/private (update-close-menu-item-shortcut item) (cond - [(eq? (system-type) 'linux) + [(eq? (system-type) 'unix) (send item set-label (string-constant close-menu-item))] [else (define just-one? (and (pair? tabs) (null? (cdr tabs)))) @@ -2998,7 +2998,7 @@ module browser threading seems wrong. (define/override (file-menu:close-callback item control) (define just-one? (and (pair? tabs) (null? (cdr tabs)))) - (if (and (eq? (system-type) 'linux) + (if (and (eq? (system-type) 'unix) (not just-one?)) (close-current-tab) (super file-menu:close-callback item control))) @@ -3342,7 +3342,7 @@ module browser threading seems wrong. (make-object separator-menu-item% file-menu))] (define close-tab-menu-item #f) (define/override (file-menu:between-close-and-quit file-menu) - (unless (eq? (system-type) 'linux) + (unless (eq? (system-type) 'unix) (set! close-tab-menu-item (new (get-menu-item%) (label (string-constant close-tab)) diff --git a/collects/framework/private/standard-menus-items.rkt b/collects/framework/private/standard-menus-items.rkt index fa1abca2a6..10fbca7b56 100644 --- a/collects/framework/private/standard-menus-items.rkt +++ b/collects/framework/private/standard-menus-items.rkt @@ -265,7 +265,7 @@ '(λ (item control) (when (can-close?) (on-close) (show #f)) #t) #\w '(get-default-shortcut-prefix) - '(if (eq? (system-type) 'linux) + '(if (eq? (system-type) 'unix) (string-constant close-menu-item) (string-constant close-window-menu-item)) on-demand-do-nothing diff --git a/collects/framework/private/standard-menus.rkt b/collects/framework/private/standard-menus.rkt index 0daadbb1cd..9e9a48b7c6 100644 --- a/collects/framework/private/standard-menus.rkt +++ b/collects/framework/private/standard-menus.rkt @@ -274,7 +274,7 @@ (define/public (file-menu:get-close-item) file-menu:close-item) (define/public (file-menu:close-string) - (if (eq? (system-type) 'linux) + (if (eq? (system-type) 'unix) (string-constant close-menu-item) (string-constant close-window-menu-item))) (define/public (file-menu:close-help-string) (string-constant close-info)) diff --git a/collects/scribblings/framework/standard-menus.scrbl b/collects/scribblings/framework/standard-menus.scrbl index e0f22dd621..247a4cdb26 100644 --- a/collects/scribblings/framework/standard-menus.scrbl +++ b/collects/scribblings/framework/standard-menus.scrbl @@ -118,7 +118,7 @@ @(defmethod (file-menu:close-on-demand (menu-item (is-a?/c menu-item%))) void? "The menu item's on-demand proc calls this method." "\n" "\n" "Defaults to " (racketblock (void))) -@(defmethod (file-menu:close-string) string? "The result of this method is used as the name of the " (racket menu-item%) "." "\n" "\n" "Defaults to " (racket (if (eq? (system-type) (quote linux)) (string-constant close-menu-item) (string-constant close-window-menu-item))) ".") +@(defmethod (file-menu:close-string) string? "The result of this method is used as the name of the " (racket menu-item%) "." "\n" "\n" "Defaults to " (racket (if (eq? (system-type) (quote unix)) (string-constant close-menu-item) (string-constant close-window-menu-item))) ".") @(defmethod (file-menu:close-help-string) string? "The result of this method is used as the help string" "\n" "when the " (racket menu-item%) " object is created." "\n" "\n" "Defaults to " (racket (string-constant close-info)) ".") From f5e534fd87e1e4e278e835c9237c2efa5ed27bc2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 2 Sep 2011 08:25:53 -0600 Subject: [PATCH 091/235] win32: fix canvas refresh Refresh was wrong in the case that a canvas had been "reset" in certain ways, such as showing and hiding, and the canvas is drawn on before a Win32-level refresh event was processed. In that case `on-paint' wasn't called, and it should have been. Closes PR 12152 --- collects/mred/private/wx/win32/canvas.rkt | 14 +++----------- 1 file changed, 3 insertions(+), 11 deletions(-) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 01f022c2c8..dcbc91b0d1 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -242,7 +242,7 @@ (define/override (on-resized) (reset-dc)) - (define/private (reset-dc) + (define/private (reset-dc [refresh? #t]) (send dc reset-backing-retained) (send dc set-auto-scroll (if (get-virtual-width) @@ -250,16 +250,8 @@ 0) (if (get-virtual-height) (get-virtual-v-pos) - 0))) - - (define/public (tell-me-what) - (let ([r (GetClientRect (get-client-hwnd))] - [rr (GetWindowRect (get-hwnd))]) - (printf "~s\n" - (list hscroll? vscroll? - (list (RECT-left r) (RECT-top r) (RECT-right r) (RECT-bottom r)) - (list (RECT-left rr) (RECT-top rr) (RECT-right rr) (RECT-bottom rr)))))) - + 0)) + (when refresh? (refresh-one))) (define/override (show-children) (when (dc . is-a? . dc<%>) From dee4b7dc19d2d1c6f2d0ed56197bb22ef40433b0 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 3 Sep 2011 07:01:22 -0400 Subject: [PATCH 092/235] Use a `typed-racket' package to include new release notes. --- collects/meta/dist-specs.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/meta/dist-specs.rkt b/collects/meta/dist-specs.rkt index c52fced23a..f2925f5953 100644 --- a/collects/meta/dist-specs.rkt +++ b/collects/meta/dist-specs.rkt @@ -631,6 +631,7 @@ plt-extras :+= (package: "frtime/") ;; -------------------- typed-scheme dr-extras :+= (package: "typed-scheme/" ; used in drracket #:docs "ts-{reference|guide}/") + (package: "typed-racket") (- (collects: "typed/") (cond (not plt) => (collects: "typed/test-engine/") (collects: "typed/rackunit/") From 981d6874de52818508a67f6ef0c7d9f2b83c58e4 Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Sat, 3 Sep 2011 13:04:57 +0200 Subject: [PATCH 093/235] Synch German string constants with latest. --- .../string-constants/private/german-string-constants.rkt | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/collects/string-constants/private/german-string-constants.rkt b/collects/string-constants/private/german-string-constants.rkt index 237dbdadcc..8d1f2761df 100644 --- a/collects/string-constants/private/german-string-constants.rkt +++ b/collects/string-constants/private/german-string-constants.rkt @@ -23,7 +23,10 @@ (untitled-n "Namenlos ~a") (warning "Warnung") (error "Fehler") - (close "Schließen") ;; as in, close an open window + (close "Schließen") ;; as in, close an open window or tab. must match close-menu-item + ;; in the sense that, when the &s have been stripped from + ;; close-menu-item, it must be the same string as this. + (close-window "Fenster schließen") (stop "Stop") (&stop "&Stop") ;; for use in button and menu item labels, with short cut. (are-you-sure-delete? "Sind Sie sicher, dass Sie ~a löschen wollen?") ;; ~a is a filename or directory name @@ -573,6 +576,7 @@ (close-info "Diese Datei schließen") (close-menu-item "&Schließen") + (close-window-menu-item "&Fenster schließen") (quit-info "Alle Fenster schließen") (quit-menu-item-windows "Be&enden") From 20a1440dcfc98e59a64a407230ad49392f1d08b8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 3 Sep 2011 07:45:26 -0600 Subject: [PATCH 094/235] fix `build-struct-generation' to work with `racket/base' and also still works with `mzscheme' --- collects/syntax/scribblings/struct.scrbl | 10 ++++---- collects/syntax/struct.rkt | 13 +++++----- collects/tests/syntax/mzstruct.rkt | 29 +++++++++++++++++++++ collects/tests/syntax/struct.rkt | 32 ++++++++++++++++++++++++ 4 files changed, 72 insertions(+), 12 deletions(-) create mode 100644 collects/tests/syntax/mzstruct.rkt create mode 100644 collects/tests/syntax/struct.rkt diff --git a/collects/syntax/scribblings/struct.scrbl b/collects/syntax/scribblings/struct.scrbl index c31ccd9ebc..9483cc5158 100644 --- a/collects/syntax/scribblings/struct.scrbl +++ b/collects/syntax/scribblings/struct.scrbl @@ -56,8 +56,8 @@ source location to the generated identifiers.} [omit-set? boolean?] [super-type any/c #f] - [prop-value-list list? empty] - [immutable-k-list list? empty]) + [prop-value-list list? '(list)] + [immutable-k-list list? '(list)]) (listof identifier?)]{ Takes the same arguments as @racket[build-struct-names] and generates @@ -65,7 +65,7 @@ an S-expression for code using @racket[make-struct-type] to generate the structure type and return values for the identifiers created by @racket[build-struct-names]. The optional @racket[super-type], @racket[prop-value-list], and @racket[immutable-k-list] parameters take -S-expression values that are used as the corresponding arguments to +S-expressions that are used as the corresponding argument expressions to @racket[make-struct-type].} @@ -76,8 +76,8 @@ S-expression values that are used as the corresponding arguments to [omit-sel? boolean?] [omit-set? boolean?] [super-type any/c #f] - [prop-value-list list? empty] - [immutable-k-list list? empty]) + [prop-value-list list? '(list)] + [immutable-k-list list? '(list)]) (listof identifier?)]{ Like @racket[build-struct-generation], but given the names produced by diff --git a/collects/syntax/struct.rkt b/collects/syntax/struct.rkt index b6778d6d34..2be275a84c 100644 --- a/collects/syntax/struct.rkt +++ b/collects/syntax/struct.rkt @@ -121,17 +121,17 @@ (loop (cdr l)))))))))) (define build-struct-generation - (lambda (name-stx fields omit-sel? omit-set? [super-type #f] [prop-value-list null] - [immutable-positions null] [mk-rec-prop-list (lambda (struct: make- ? acc mut) null)] + (lambda (name-stx fields omit-sel? omit-set? [super-type #f] [prop-value-list '(list)] + [immutable-positions '(list)] #:constructor-name [ctr-name #f]) (let ([names (build-struct-names name-stx fields omit-sel? omit-set? #:constructor-name ctr-name)]) (build-struct-generation* names name-stx fields omit-sel? omit-set? super-type prop-value-list - immutable-positions mk-rec-prop-list)))) + immutable-positions)))) (define build-struct-generation* - (lambda (names name fields omit-sel? omit-set? [super-type #f] [prop-value-list null] - [immutable-positions null] [mk-rec-prop-list (lambda (struct: make- ? acc mut) null)]) + (lambda (names name fields omit-sel? omit-set? [super-type #f] [prop-value-list '(list)] + [immutable-positions '(list)]) (let ([num-fields (length fields)] [acc/mut-makers (let loop ([l fields][n 0]) (if (null? l) @@ -151,8 +151,7 @@ (if omit-set? null (mk-one #f)) - (loop (cdr l) (add1 n))))))] - [extra-props (mk-rec-prop-list 'struct: 'make- '? 'acc 'mut)]) + (loop (cdr l) (add1 n))))))]) `(let-values ([(struct: make- ? acc mut) (make-struct-type ',name ,super-type ,num-fields 0 #f ,prop-value-list (current-inspector) diff --git a/collects/tests/syntax/mzstruct.rkt b/collects/tests/syntax/mzstruct.rkt new file mode 100644 index 0000000000..c66db445cf --- /dev/null +++ b/collects/tests/syntax/mzstruct.rkt @@ -0,0 +1,29 @@ +#lang mzscheme +(require (for-syntax syntax/struct)) + +;; Like the "struct.rkt", but checks that it works in the +;; `mzscheme' language, still + +(define-syntax (exp stx) + (syntax-case stx () + [(_ sel? set? (name sup) (field ...)) + (with-syntax ([e (build-struct-generation #'name + (syntax->list #'(field ...)) + (not (syntax-e #'sel?)) + (not (syntax-e #'set?)) + (and (syntax-e #'sup) #'sup))] + [(id ...) + (build-struct-names #'name + (syntax->list #'(field ...)) + (not (syntax-e #'sel?)) + (not (syntax-e #'set?)))]) + #'(define-values (id ...) e))])) + +(define (check a b) + (unless (equal? a b) (error "failed!"))) + +(let ([set-pt-x! 12]) + (exp #t #t (pt #f) (x y)) + (check 10 (pt-x (make-pt 10 20))) + (check 20 (pt-y (make-pt 10 20))) + (check #t (procedure? set-pt-x!))) diff --git a/collects/tests/syntax/struct.rkt b/collects/tests/syntax/struct.rkt new file mode 100644 index 0000000000..c9d15c1a38 --- /dev/null +++ b/collects/tests/syntax/struct.rkt @@ -0,0 +1,32 @@ +#lang racket +(require (for-syntax syntax/struct)) + +(define-syntax (exp stx) + (syntax-case stx () + [(_ sel? set? (name sup) (field ...)) + (with-syntax ([e (build-struct-generation #'name + (syntax->list #'(field ...)) + (not (syntax-e #'sel?)) + (not (syntax-e #'set?)) + (and (syntax-e #'sup) #'sup))] + [(id ...) + (build-struct-names #'name + (syntax->list #'(field ...)) + (not (syntax-e #'sel?)) + (not (syntax-e #'set?)))]) + #'(define-values (id ...) e))])) + +(define (check a b) + (unless (equal? a b) (error "failed!"))) + +(let ([set-pt-x! 12]) + (exp #t #f (pt #f) (x y)) + (check 10 (pt-x (make-pt 10 20))) + (check 20 (pt-y (make-pt 10 20))) + (check 12 set-pt-x!)) + +(let ([set-pt-x! 12]) + (exp #t #t (pt #f) (x y)) + (check 10 (pt-x (make-pt 10 20))) + (check 20 (pt-y (make-pt 10 20))) + (check #t (procedure? set-pt-x!))) From e4da28e1c00027338eda58cc78885255b9285598 Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Sat, 3 Sep 2011 16:22:47 +0200 Subject: [PATCH 095/235] In German string constants, move a & menu accelerator marker ... to a more appropriate place. --- collects/string-constants/private/german-string-constants.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/string-constants/private/german-string-constants.rkt b/collects/string-constants/private/german-string-constants.rkt index 8d1f2761df..b99e6e74cf 100644 --- a/collects/string-constants/private/german-string-constants.rkt +++ b/collects/string-constants/private/german-string-constants.rkt @@ -576,7 +576,7 @@ (close-info "Diese Datei schließen") (close-menu-item "&Schließen") - (close-window-menu-item "&Fenster schließen") + (close-window-menu-item "Fenster &schließen") (quit-info "Alle Fenster schließen") (quit-menu-item-windows "Be&enden") From b4ef9a09a9d9b76e2736941e8724160afdf6b0a6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 3 Sep 2011 10:06:20 -0600 Subject: [PATCH 096/235] cocoa: fix menu when two layers of dialogs are dismissed --- collects/mred/private/wx/cocoa/frame.rkt | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index dc54e9d969..ef26252a88 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -86,6 +86,19 @@ (when wxb (let ([wx (->wx wxb)]) (when wx + ;; Sometimes, a sheet becomes the main window and the parent + ;; still thinks that the parent is the main window. Tell + ;; the parent otherwise. + (let ([p (send wx get-parent)]) + (when p + (let ([s (send p get-sheet)]) + (when (eq? s wx) + (let ([parent (send p get-cocoa)]) + (when (tell #:type _BOOL parent isMainWindow) + ;; The Cocoa docs say never to call this method directly, + ;; but we're trying to fix up a case where Cocoa seems + ;; to be confused: + (tellv parent resignMainWindow))))))) (set! front wx) (send wx install-wait-cursor) (send wx install-mb) @@ -344,7 +357,8 @@ (define/public (force-window-focus) (let ([next (get-app-front-window)]) (cond - [next (tellv next makeKeyWindow)] + [next + (tellv next makeKeyWindow)] [root-fake-frame ;; Make key focus shift to root frame: (let ([root-cocoa (send root-fake-frame get-cocoa)]) From 34eb5ec9832660fdc2960e4aba00f2c407fddf5e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 3 Sep 2011 10:34:36 -0600 Subject: [PATCH 097/235] cocoa: fix application about handler Closes PR 12165 --- collects/mred/private/wx/cocoa/menu-bar.rkt | 2 +- collects/mred/private/wx/cocoa/queue.rkt | 19 +++++++++++++++---- collects/mred/private/wx/common/handlers.rkt | 6 ++++-- collects/mred/private/wx/common/queue.rkt | 5 +++++ 4 files changed, 25 insertions(+), 7 deletions(-) diff --git a/collects/mred/private/wx/cocoa/menu-bar.rkt b/collects/mred/private/wx/cocoa/menu-bar.rkt index c16e81cfea..80350fc89d 100644 --- a/collects/mred/private/wx/cocoa/menu-bar.rkt +++ b/collects/mred/private/wx/cocoa/menu-bar.rkt @@ -108,7 +108,7 @@ app)) (tellv apple addItem: item) (tellv item release)))]) - (std (format "About ~a" app-name) (selector orderFrontStandardAboutPanel:)) + (std (format "About ~a" app-name) (selector openAbout:) "" #f #t) (std "Preferences..." (selector openPreferences:) "," #f #t) (tellv apple addItem: (tell NSMenuItem separatorItem)) (let ([services (tell (tell NSMenu alloc) initWithTitle: #:type _NSString "Services")]) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 7e79f60759..672c4ffc99 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -56,10 +56,21 @@ (queue-prefs-event) #t] [-a _BOOL (validateMenuItem: [_id menuItem]) - (if (ptr-equal? (selector openPreferences:) - (tell #:type _SEL menuItem action)) - (not (eq? (application-pref-handler) nothing-application-pref-handler)) - (super-tell #:type _BOOL validateMenuItem: menuItem))] + (cond + [(ptr-equal? (selector openPreferences:) + (tell #:type _SEL menuItem action)) + (not (eq? (application-pref-handler) nothing-application-pref-handler))] + [(ptr-equal? (selector openAbout:) + (tell #:type _SEL menuItem action)) + #t] + [else + (super-tell #:type _BOOL validateMenuItem: menuItem)])] + [-a _BOOL (openAbout: [_id sender]) + (if (eq? nothing-application-about-handler + (application-about-handler)) + (tellv app orderFrontStandardAboutPanel: sender) + (queue-about-event)) + #t] [-a _BOOL (application: [_id theApplication] openFile: [_NSString filename]) (queue-file-event (string->path filename))] [-a _BOOL (applicationShouldHandleReopen: [_id app] hasVisibleWindows: [_BOOL has-visible?]) diff --git a/collects/mred/private/wx/common/handlers.rkt b/collects/mred/private/wx/common/handlers.rkt index 3776fd014b..b62ea90170 100644 --- a/collects/mred/private/wx/common/handlers.rkt +++ b/collects/mred/private/wx/common/handlers.rkt @@ -6,7 +6,8 @@ application-about-handler application-pref-handler - nothing-application-pref-handler)) + nothing-application-pref-handler + nothing-application-about-handler)) (define saved-files null) (define afh (lambda (f) @@ -26,7 +27,8 @@ [(proc) (set! aqh proc)] [() aqh])) -(define aah void) +(define (nothing-application-about-handler) (void)) +(define aah nothing-application-about-handler) (define application-about-handler (case-lambda [(proc) (set! aah proc)] diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 773e327380..f887785414 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -54,6 +54,7 @@ queue-quit-event queue-prefs-event + queue-about-event queue-file-event begin-busy-cursor @@ -571,6 +572,10 @@ ;; called in event-pump thread (queue-event main-eventspace (application-pref-handler) 'med)) +(define (queue-about-event) + ;; called in event-pump thread + (queue-event main-eventspace (application-about-handler) 'med)) + (define (queue-file-event file) ;; called in event-pump thread (queue-event main-eventspace (lambda () From 594447ae7ef0b0e1a171bd5897482153f0c4a4f4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 3 Sep 2011 10:44:37 -0600 Subject: [PATCH 098/235] gtk: make list-box% min size non-zero for content --- collects/mred/private/wx/gtk/list-box.rkt | 2 +- collects/mred/private/wx/gtk/window.rkt | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/mred/private/wx/gtk/list-box.rkt b/collects/mred/private/wx/gtk/list-box.rkt index c112f034c4..1979099635 100644 --- a/collects/mred/private/wx/gtk/list-box.rkt +++ b/collects/mred/private/wx/gtk/list-box.rkt @@ -211,7 +211,7 @@ [font font] [no-show? (memq 'deleted style)]) - (set-auto-size) + (set-auto-size 32) ; 32 is extra width (connect-changed selection) (connect-activated client-gtk) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index ef2a9b2feb..5055347404 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -510,13 +510,13 @@ (set! client-delta-h (- (GtkRequisition-height req) (GtkRequisition-height creq)))))) - (define/public (set-auto-size) + (define/public (set-auto-size [dw 0] [dh 0]) (let ([req (make-GtkRequisition 0 0)]) (gtk_widget_size_request gtk req) (set-size -11111 -11111 - (GtkRequisition-width req) - (GtkRequisition-height req)))) + (+ (GtkRequisition-width req) dw) + (+ (GtkRequisition-height req) dh)))) (define shown? #f) (define/public (direct-show on?) From 4025206bd7f56579bbc818ba7041297d9e01c5e6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 3 Sep 2011 13:11:33 -0600 Subject: [PATCH 099/235] fix `regexp-match' docs --- collects/scribblings/reference/regexps.scrbl | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/collects/scribblings/reference/regexps.scrbl b/collects/scribblings/reference/regexps.scrbl index f281586c8b..f7b4da0214 100644 --- a/collects/scribblings/reference/regexps.scrbl +++ b/collects/scribblings/reference/regexps.scrbl @@ -241,17 +241,16 @@ string, @racket[start-pos] is a character position; when position; and when @racket[input] is an input port, @racket[start-pos] is the number of bytes to skip before starting to match. The @racket[end-pos] argument can be @racket[#f], which corresponds to the -end of the string or the end-of-file in the stream; otherwise, it is a +end of the string or an end-of-file in the stream; otherwise, it is a character or byte position, like @racket[start-pos]. If @racket[input] -is an input port, and if the end-of-file is reached before +is an input port, and if an end-of-file is reached before @racket[start-pos] bytes are skipped, then the match fails. In @racket[pattern], a start-of-string @litchar{^} refers to the first position of @racket[input] after @racket[start-pos], assuming that @racket[input-prefix] is @racket[#""]. The end-of-input @litchar{$} refers to the @racket[end-pos]th position or (in the case of an input -port) the end of file, whichever comes first, assuming that -@racket[output-prefix] is @racket[#f]. +port) an end-of-file, whichever comes first. The @racket[input-prefix] specifies bytes that effectively precede @racket[input] for the purposes of @litchar{^} and other look-behind From 1c34ce9f1975a44bb8141a87cd540a402319296b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 3 Sep 2011 13:21:38 -0600 Subject: [PATCH 100/235] clarify `define-struct/derived' in docs --- collects/scribblings/reference/define-struct.scrbl | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/collects/scribblings/reference/define-struct.scrbl b/collects/scribblings/reference/define-struct.scrbl index 32619f0c74..e19f32c51f 100644 --- a/collects/scribblings/reference/define-struct.scrbl +++ b/collects/scribblings/reference/define-struct.scrbl @@ -236,11 +236,12 @@ preferred. @defform[(define-struct/derived (id . rest-form) id-maybe-super (field ...) struct-option ...)]{ -Like @racket[define-struct], but intended for use by macros that -expand to @racket[define-struct]. The form immediately after -@racket[define-struct/derived] is used for all syntax-error reporting, -and the only constraint on the form is that it starts with some -@racket[id]. +The same as @racket[define-struct], but with an extra @racket[(id +. rest-form)] sub-form that is treated as the overall form for +syntax-error reporting and otherwise ignored. The only constraint on +the sub-form for error reporting is that it starts with @racket[id]. +The @racket[define-struct/derived] form is intended for use by macros +that expand to @racket[define-struct]. @defexamples[ #:eval posn-eval From 60325da48c3edf813f7a83ceb6d0c02b94454be3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 3 Sep 2011 13:26:20 -0600 Subject: [PATCH 101/235] clarify `unsafe-...*' in docs The clarification mostly repeats information in the contract, and we normally avoid that, but the bindings look undocumented otherwise. Closes PR 12162 --- collects/scribblings/reference/unsafe.scrbl | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/collects/scribblings/reference/unsafe.scrbl b/collects/scribblings/reference/unsafe.scrbl index bb4115cb9c..646e6cf992 100644 --- a/collects/scribblings/reference/unsafe.scrbl +++ b/collects/scribblings/reference/unsafe.scrbl @@ -209,7 +209,9 @@ at least @racket[(add1 pos)] (for @racket[unsafe-list-ref]) or @defproc[(unsafe-set-box*! [v (and/c box? (not/c impersonator?))] [val any/c]) void?] )]{ -Unsafe versions of @racket[unbox] and @racket[set-box!].} +Unsafe versions of @racket[unbox] and @racket[set-box!], where the +@schemeidfont{box*} variants can be faster but do not work on +@tech{impersonators}.} @deftogether[( @@ -222,9 +224,11 @@ Unsafe versions of @racket[unbox] and @racket[set-box!].} )]{ Unsafe versions of @racket[vector-length], @racket[vector-ref], and -@racket[vector-set!]. A vector's size can never be larger than a -@tech{fixnum} (so even @racket[vector-length] always returns a -fixnum).} +@racket[vector-set!], where the @schemeidfont{vector*} variants can be +faster but do not work on @tech{impersonators}. + +A vector's size can never be larger than a @tech{fixnum}, so even +@racket[vector-length] always returns a fixnum.} @deftogether[( @@ -300,7 +304,9 @@ Unsafe versions of @racket[u16vector-ref] and )]{ Unsafe field access and update for an instance of a structure -type. The index @racket[k] must be between @racket[0] (inclusive) and +type, where the @schemeidfont{struct*} variants can be +faster but do not work on @tech{impersonators}. +The index @racket[k] must be between @racket[0] (inclusive) and the number of fields in the struture (exclusive). In the case of @racket[unsafe-struct-set!], the field must be mutable.} From 03991c778c3b7b51629af171a2250b2db2aec258 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 3 Sep 2011 13:31:27 -0600 Subject: [PATCH 102/235] doc contract fix Closes PR 12163 --- collects/scribblings/reference/sequences.scrbl | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/collects/scribblings/reference/sequences.scrbl b/collects/scribblings/reference/sequences.scrbl index 8b90c7e694..18abf2101f 100644 --- a/collects/scribblings/reference/sequences.scrbl +++ b/collects/scribblings/reference/sequences.scrbl @@ -506,17 +506,17 @@ in the sequence. @defproc[(sequence-for-each [f (-> any/c ... any)] [s sequence?]) - (void)]{ + void?]{ Applies @racket[f] to each element of @racket[s]. If @racket[s] is infinite, this function does not terminate.} @defproc[(sequence-fold [f (-> any/c any/c ... any/c)] [i any/c] [s sequence?]) - (void)]{ + any/c]{ Folds @racket[f] over each element of @racket[s] with @racket[i] as the initial accumulator. If @racket[s] is infinite, this function - does not terminate. @racket[f] takes the accumulator as its first argument + does not terminate. The @racket[f] function takes the accumulator as its first argument and the next sequence element as its second.} @defproc[(sequence-count [f procedure?] [s sequence?]) @@ -650,14 +650,14 @@ when it is evaluated, otherwise the @exnraise[exn:fail:contract?].} @defproc[(stream-for-each [f (-> any/c ... any)] [s stream?]) - (void)]{ + void?]{ Applies @racket[f] to each element of @racket[s]. If @racket[s] is infinite, this function does not terminate.} @defproc[(stream-fold [f (-> any/c any/c ... any/c)] [i any/c] [s stream?]) - (void)]{ + any/c]{ Folds @racket[f] over each element of @racket[s] with @racket[i] as the initial accumulator. If @racket[s] is infinite, this function does not terminate.} From 3f09b2ea6491d7641002ea348b1981b12e921488 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 3 Sep 2011 13:31:52 -0600 Subject: [PATCH 103/235] doc fixes Closes PR 12157 --- collects/scribblings/gui/dialog-funcs.scrbl | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/scribblings/gui/dialog-funcs.scrbl b/collects/scribblings/gui/dialog-funcs.scrbl index e3e761aacb..73f6ebe6b0 100644 --- a/collects/scribblings/gui/dialog-funcs.scrbl +++ b/collects/scribblings/gui/dialog-funcs.scrbl @@ -14,7 +14,7 @@ These functions get input from the user and/or display [directory (or/c path-string? #f) #f] [filename (or/c path-string? #f) #f] [extension (or/c string? #f) #f] - [style (listof (or/c 'packages 'enter-packages)) null] + [style (listof (or/c 'packages 'enter-packages 'common)) null] [filters (listof (list/c string? string?)) '(("Any" "*.*"))]) (or/c path? #f)]{ @@ -75,7 +75,7 @@ See also @racket[path-dialog%]. [directory (or/c path-string? #f) #f] [filename (or/c path-string? #f) #f] [extension (or/c string? #f) #f] - [style null? null] + [style (listof (or/c 'packages 'enter-packages 'common)) null] [filters (listof (list/c string? string?)) '(("Any" "*.*"))]) (or/c (listof path?) #f)]{ Like @@ -89,7 +89,7 @@ Like [directory (or/c path-string? #f) #f] [filename (or/c path-string? #f) #f] [extension (or/c string? #f) #f] - [style (listof (or/c 'packages 'enter-packages)) null] + [style (listof (or/c 'packages 'enter-packages 'common)) null] [filters (listof (list/c string? string?)) '(("Any" "*.*"))]) (or/c path? #f)]{ @@ -156,7 +156,7 @@ See also @racket[path-dialog%]. @defproc[(get-directory [message (or/c string? #f) #f] [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f) #f] [directory (or/c path? #f) #f] - [style (listof (or/c 'enter-packages)) null]) + [style (listof (or/c 'enter-packages 'common)) null]) (or/c path #f)]{ Obtains a directory pathname from the user via the platform-specific From 0b2beace40ceccbdeda4f66c3124b725730bc895 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 3 Sep 2011 14:57:57 -0600 Subject: [PATCH 104/235] add `schemecommentfont' --- collects/scribble/private/manual-style.rkt | 4 +++- collects/scribblings/scribble/manual.scrbl | 3 +++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/collects/scribble/private/manual-style.rkt b/collects/scribble/private/manual-style.rkt index 376de95330..39b968606e 100644 --- a/collects/scribble/private/manual-style.rkt +++ b/collects/scribble/private/manual-style.rkt @@ -30,7 +30,7 @@ (provide/contract [id styling-f/c] ...)) (provide-styling racketmodfont racketoutput racketerror racketfont racketvalfont racketresultfont racketidfont racketvarfont - racketparenfont racketkeywordfont racketmetafont + racketcommentfont racketparenfont racketkeywordfont racketmetafont onscreen defterm filepath exec envvar Flag DFlag PFlag DPFlag math procedure indexed-file indexed-envvar idefterm pidefterm) @@ -101,6 +101,8 @@ (make-element paren-color (decode-content str))) (define (racketmetafont . str) (make-element meta-color (decode-content str))) +(define (racketcommentfont . str) + (make-element comment-color (decode-content str))) (define (racketmodfont . str) (make-element module-color (decode-content str))) (define (racketkeywordfont . str) diff --git a/collects/scribblings/scribble/manual.scrbl b/collects/scribblings/scribble/manual.scrbl index 23751755a7..5ae3a8d5e9 100644 --- a/collects/scribblings/scribble/manual.scrbl +++ b/collects/scribblings/scribble/manual.scrbl @@ -462,6 +462,9 @@ sub-form in a procedure being documented).} @racket[racketfont], but colored as meta-syntax, such as backquote or unquote.} +@defproc[(racketcommentfont [pre-content pre-content?] ...) element?]{Like +@racket[racketfont], but colored as a comment.} + @defproc[(racketerror [pre-content pre-content?] ...) element?]{Like @racket[racketfont], but colored as error-message text.} From 82116cc3bdc8e06551c672963e08df22c181786a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 3 Sep 2011 15:01:11 -0600 Subject: [PATCH 105/235] add examples to regexp docs --- collects/scribblings/reference/regexps.scrbl | 65 ++++++++++- collects/scribblings/reference/rx.rkt | 113 ++++++++++--------- 2 files changed, 126 insertions(+), 52 deletions(-) diff --git a/collects/scribblings/reference/regexps.scrbl b/collects/scribblings/reference/regexps.scrbl index f7b4da0214..c810e9858e 100644 --- a/collects/scribblings/reference/regexps.scrbl +++ b/collects/scribblings/reference/regexps.scrbl @@ -1,5 +1,8 @@ #lang scribble/doc -@(require scribble/bnf "mz.rkt" "rx.rkt") +@(require scribble/bnf + "mz.rkt" + "rx.rkt" + (for-syntax racket/base)) @title[#:tag "regexp"]{Regular Expressions} @@ -8,6 +11,27 @@ @section-index["strings" "pattern matching"] @section-index["input ports" "pattern matching"] +@(define-syntax (rx-examples stx) + (syntax-case stx () + [(_ [num rx input] ...) + (with-syntax ([(ex ...) + (map (lambda (num rx input) + `(eval:alts #,(racket + (code:line + (regexp-match ,rx ,input) + (code:comment @#,t["ex" + (let ([s (number->string ,num)]) + (elemtag `(rxex ,s) + (racketcommentfont s))) + ,(if (pregexp? (syntax-e rx)) + `(list ", uses " (racketmetafont "#px")) + "")]))) + (regexp-match ,rx ,input))) + (syntax->list #'(num ...)) + (syntax->list #'(rx ...)) + (syntax->list #'(input ...)))]) + #`(examples ex ...))])) + @guideintro["regexp"]{regular expressions} @deftech{Regular expressions} are specified as strings or byte @@ -66,6 +90,45 @@ The Unicode categories follow. @category-table +@rx-examples[ +[1 #rx"a|b" "cat"] +[2 #rx"[at]" "cat"] +[3 #rx"ca*[at]" "caaat"] +[4 #rx"ca+[at]" "caaat"] +[5 #rx"ca?t?" "ct"] +[6 #rx"ca*?[at]" "caaat"] +[7 #px"ca{2}" "caaat"] +[8 #px"ca{2,}t" "catcaat"] +[9 #px"ca{,2}t" "caaatcat"] +[10 #px"ca{1,2}t" "caaatcat"] +[11 #rx"(c*)(a*)" "caat"] +[12 #rx"[^ca]" "caat"] +[13 #rx".(.)." "cat"] +[14 #rx"^a|^c" "cat"] +[15 #rx"a$|t$" "cat"] +[16 #px"c(.)\\1t" "caat"] +[17 #px".\\b." "cat in hat"] +[18 #px".\\B." "cat in hat"] +[19 #px"\\p{Ll}" "Cat"] +[20 #px"\\P{Ll}" "cat!"] +[21 #rx"\\|" "c|t"] +[22 #rx"[a-f]*" "cat"] +[23 #px"[a-f\\d]*" "1cat"] +[24 #px" [\\w]" "cat hat"] +[25 #px"t[\\s]" "cat\nhat"] +[26 #px"[[:lower:]]+" "Cat"] +[27 #rx"[]]" "c]t"] +[28 #rx"[-]" "c-t"] +[29 #rx"[]a[]+" "c[a]t"] +[30 #rx"[a^]+" "ca^t"] +[31 #rx".a(?=p)" "cat nap"] +[32 #rx".a(?!t)" "cat nap"] +[33 #rx"(?<=n)a." "cat nap"] +[34 #rx"(?Regexp) Match Regexp, only first possible #co | Look Match empty if Look matches #co - | (?TstPces|Pces) Match 1st Pces if Tst, else 2nd Pces #co + | (?TstPces|Pces) Match 1st Pces if Tst, else 2nd Pces #co 36 | (?TstPces) Match Pces if Tst, empty if not Tst #co Atom ::= ... ... #px - | \N Match latest reported match for N##th _(_ #px + | \N Match latest reported match for N##th _(_ #px 16 | Class Match any character in Class #px - | \b Match _\w*_ boundary #px - | \B Match where _\b_ does not #px - | \p{Property} Match (UTF-8 encoded) in Property #px - | \P{Property} Match (UTF-8 encoded) not in Property #px + | \b Match _\w*_ boundary #px 17 + | \B Match where _\b_ does not #px 18 + | \p{Property} Match (UTF-8 encoded) in Property #px 19 + | \P{Property} Match (UTF-8 encoded) not in Property #px 20 Literal :== Any character except _(_, _)_, _*_, _+_, _?_, _[_, _._, _^_, _\_, or _|_ #rx Literal :== Any character except _(_, _)_, _*_, _+_, _?_, _[_, _]_, _{_, _}_, _._, _^_, _\_, or _|_ #px - | \Aliteral Match Aliteral #ot + | \Aliteral Match Aliteral #ot 21 Aliteral :== Any character #rx Aliteral :== Any character except _a_-_z_, _A_-_Z_, _0_-_9_ #px - Rng ::= ] Rng contains _]_ only #co - | - Rng contains _-_ only #co + Rng ::= ] Rng contains _]_ only #co 27 + | - Rng contains _-_ only #co 28 | Mrng Rng contains everything in Mrng #co | Mrng- Rng contains _-_ and everything in Mrng #co - Mrng ::= ]Lrng Mrng contains _]_ and everything in Lrng #co - | -Lrng Mrng contains _-_ and everything in Lrng #co + Mrng ::= ]Lrng Mrng contains _]_ and everything in Lrng #co 29 + | -Lrng Mrng contains _-_ and everything in Lrng #co 29 | Lirng Mrng contains everything in Lirng #co Lirng ::= Riliteral Lirng contains a literal character #co - | Riliteral-Rliteral Lirng contains Unicode range inclusive #co + | Riliteral-Rliteral Lirng contains Unicode range inclusive #co 22 | LirngLrng Lirng contains everything in both #co - Lrng ::= ^ Lrng contains _^_ #co + Lrng ::= ^ Lrng contains _^_ #co 30 | Rliteral-Rliteral Lrng contains Unicode range inclusive #co | ^Lrng Lrng contains _^_ and more #co | Lirng Lrng contains everything in Lirng #co - Look ::= (?=Regexp) Match if Regexp matches #mode - | (?!Regexp) Match if Regexp doesn't match #mode - | (?<=Regexp) Match if Regexp matches preceding #mode - | (?symbol kind) line)] + [(#px"^(.*?) +#(\\w+)(?:| ([0-9]+))$" line kind ex) (list (string->symbol kind) line ex)] [else (error 'grammar-lines "bad line: ~s" line)]))) (define (table-content modes) @@ -201,22 +205,29 @@ x (paragraph plain (list (if (element? x) x (element #f x)))))) (define (row . xs) (map cell xs)) - (define (render-line line) + (define (ex-ref ex) (if ex + (smaller (list 'nbsp (elemref `(rxex ,ex) + (format "ex~a" ex)))) + "")) + (define (render-line line ex) (regexp-case line [(#rx"^([^ ]*) +::= ((?:[^ ]+| [|] )*) +([^ ].*)$" prod val meaning) (row (fixup-ids prod) ::= (lit-ize (fixup-ids val)) - spacer (as-smaller (as-meaning (fixup-ids meaning))))] + spacer (as-smaller (as-meaning (fixup-ids meaning))) + (ex-ref ex))] [(#rx"^([^ ]*) +:== (.*)$" prod meaning) (row (fixup-ids prod) ::= (as-meaning (fixup-ids meaning)) - 'cont 'cont)] + 'cont 'cont + (ex-ref ex))] [(#rx"^ + [|] ((?:[^ ]| [|] )*) +([^ ].*)$" val meaning) (row 'nbsp -or- (lit-ize (fixup-ids val)) - spacer (as-smaller (as-meaning (fixup-ids meaning))))])) + spacer (as-smaller (as-meaning (fixup-ids meaning))) + (ex-ref ex))])) (table (style #f (list (table-columns (map (lambda (s) (style #f (list s))) - '(left left center left left left))))) + '(left left center left left left left))))) (for/list ([line (in-list grammar-lines)] #:when (memq (car line) modes)) - (cons (paragraph plain (list spacer)) (render-line (cdr line)))))) + (cons (paragraph plain (list spacer)) (render-line (cadr line) (caddr line)))))) (provide common-table rx-table px-table category-table) (define common-table (table-content '(co mode))) From a53f51d92d15cdef380490ef102178663b07df60 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 3 Sep 2011 15:15:24 -0600 Subject: [PATCH 106/235] fix HtDP `local' to work better with macros that expand to `begin' In particular, the forms within `begin' need to be partially expanded before checking whether they're allowed. --- collects/lang/private/teach.rkt | 16 ++++++++-------- collects/tests/htdp-lang/intm-adv.rktl | 12 ++++++++++++ 2 files changed, 20 insertions(+), 8 deletions(-) diff --git a/collects/lang/private/teach.rkt b/collects/lang/private/teach.rkt index 8763277f0a..80e565c045 100644 --- a/collects/lang/private/teach.rkt +++ b/collects/lang/private/teach.rkt @@ -1636,13 +1636,13 @@ ;; forms know that it's ok to expand in this internal ;; definition context. [int-def-ctx (build-expand-context (make-expanding-for-intermediate-local))]) - (let* ([partly-expanded-defns - (map (lambda (d) - (local-expand - d - int-def-ctx - (kernel-form-identifier-list))) - defns)] + (let* ([partly-expand (lambda (d) + (local-expand + d + int-def-ctx + (kernel-form-identifier-list)))] + [partly-expanded-defns + (map partly-expand defns)] [flattened-defns (let loop ([l partly-expanded-defns][origs defns]) (apply @@ -1653,7 +1653,7 @@ ;; or `define-syntaxes', because only macros can generate ;; them [(begin defn ...) - (let ([l (syntax->list (syntax (defn ...)))]) + (let ([l (map partly-expand (syntax->list (syntax (defn ...))))]) (loop l l))] [(define-values . _) (list d)] diff --git a/collects/tests/htdp-lang/intm-adv.rktl b/collects/tests/htdp-lang/intm-adv.rktl index c032984b98..6757cb56a3 100644 --- a/collects/tests/htdp-lang/intm-adv.rktl +++ b/collects/tests/htdp-lang/intm-adv.rktl @@ -115,3 +115,15 @@ (htdp-err/rt-test (-) (exn-type-and-msg exn:application:arity? "-: expects at least 1 argument, given 0")) (htdp-err/rt-test (/) (exn-type-and-msg exn:application:arity? "/: expects at least 1 argument, given 0")) ;(htdp-test 1 (/ 1) exn:application:arity?) + +;; Check that `local' works with macros that expand to `begin': +(module my-multi-defn racket/base + (provide multi) + (define-syntax-rule (multi a b) + (begin + (define a 1) + (define b 2)))) +(htdp-teachpack my-multi-defn) + +(htdp-test '(2 1) 'local (local [(multi x y)] + (list y x))) From 4c9c02905d797030fc86749b779271c2e3688278 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 1 Sep 2011 16:32:42 -0400 Subject: [PATCH 107/235] Add tests for non-linearity in `match-let'. --- collects/tests/match/examples.rkt | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/collects/tests/match/examples.rkt b/collects/tests/match/examples.rkt index 5ba01a0993..5df53af8aa 100644 --- a/collects/tests/match/examples.rkt +++ b/collects/tests/match/examples.rkt @@ -692,4 +692,15 @@ (let () (match-define-values (x y 3) (values 1 2 3)) (list x y))) + (comp '(1 2 3) + (match-let ([(list x y) (list 1 2)] [(list y z) '(2 3)]) + (list x y z))) + + (comp 'yes + (with-handlers ([exn:fail? (lambda _ 'yes)] + [values (lambda _ 'no)]) + (match-let ([(list x y) (list 1 22)] [(list y z) '(2 3)]) + (list x y z)))) + + )) From d594e6ee491fd2b987f974c0275df9d40cf74320 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 1 Sep 2011 19:03:52 -0400 Subject: [PATCH 108/235] Fix language info when running 'racket -I typed/racket'. --- collects/typed-scheme/language-info.rkt | 7 +++---- collects/typed-scheme/main.rkt | 3 +-- collects/typed-scheme/minimal/lang/reader.rkt | 13 +++++++++++++ collects/typed/racket.rkt | 2 +- collects/typed/racket/base.rkt | 2 +- collects/typed/scheme.rkt | 2 +- collects/typed/scheme/base.rkt | 2 +- 7 files changed, 21 insertions(+), 10 deletions(-) create mode 100644 collects/typed-scheme/minimal/lang/reader.rkt diff --git a/collects/typed-scheme/language-info.rkt b/collects/typed-scheme/language-info.rkt index 31b2a23952..311186d59c 100644 --- a/collects/typed-scheme/language-info.rkt +++ b/collects/typed-scheme/language-info.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base (require typed-scheme/typed-reader) (provide get-info configure) @@ -9,10 +9,9 @@ ;; options currently always empty (define (configure options) - (namespace-require 'scheme/base) + (namespace-require 'racket/base) (eval '(begin - (require (for-syntax typed-scheme/utils/tc-utils scheme/base)) + (require (for-syntax typed-scheme/utils/tc-utils racket/base)) (begin-for-syntax (set-box! typed-context? #t))) (current-namespace)) (current-readtable (readtable))) - diff --git a/collects/typed-scheme/main.rkt b/collects/typed-scheme/main.rkt index 4e9ea23af1..b10050bb10 100644 --- a/collects/typed-scheme/main.rkt +++ b/collects/typed-scheme/main.rkt @@ -1,5 +1,4 @@ -#lang racket/base +#lang typed-scheme/minimal (require typed/scheme/base) (provide (all-from-out typed/scheme/base)) - diff --git a/collects/typed-scheme/minimal/lang/reader.rkt b/collects/typed-scheme/minimal/lang/reader.rkt new file mode 100644 index 0000000000..5267b951c7 --- /dev/null +++ b/collects/typed-scheme/minimal/lang/reader.rkt @@ -0,0 +1,13 @@ +#lang s-exp syntax/module-reader + +typed-scheme/minimal + +#:language-info make-language-info +#:info make-info + +(define (make-info key default use-default) + (case key + [else (use-default key default)])) + +(define make-language-info + `#(typed-scheme/language-info get-info ())) diff --git a/collects/typed/racket.rkt b/collects/typed/racket.rkt index 99d54c6855..f108282f35 100644 --- a/collects/typed/racket.rkt +++ b/collects/typed/racket.rkt @@ -1,4 +1,4 @@ -#lang racket/base +#lang typed-scheme/minimal (require typed/racket/base racket/require (subtract-in racket typed/racket/base racket/contract) (for-syntax racket/base)) diff --git a/collects/typed/racket/base.rkt b/collects/typed/racket/base.rkt index c3a319cdb0..24926cc601 100644 --- a/collects/typed/racket/base.rkt +++ b/collects/typed/racket/base.rkt @@ -1,4 +1,4 @@ -#lang s-exp typed-scheme/minimal +#lang typed-scheme/minimal (providing (libs (except racket/base #%module-begin #%top-interaction with-handlers lambda #%app define-struct for for*)) (basics #%module-begin #%top-interaction lambda #%app)) diff --git a/collects/typed/scheme.rkt b/collects/typed/scheme.rkt index 39e626df29..aa4c4d9dd9 100644 --- a/collects/typed/scheme.rkt +++ b/collects/typed/scheme.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang typed-scheme/minimal (require typed/scheme/base scheme/require (subtract-in scheme typed/scheme/base scheme/contract) (for-syntax scheme/base)) diff --git a/collects/typed/scheme/base.rkt b/collects/typed/scheme/base.rkt index 6949b79a7d..7fa96debd7 100644 --- a/collects/typed/scheme/base.rkt +++ b/collects/typed/scheme/base.rkt @@ -1,4 +1,4 @@ -#lang s-exp typed-scheme/minimal +#lang typed-scheme/minimal (providing (libs (except scheme/base #%module-begin #%top-interaction with-handlers lambda #%app define-struct for for*)) (basics #%module-begin #%top-interaction lambda #%app)) From 77b619b7c2c4c4ef89f7830949ab90bdda07f5a2 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 3 Sep 2011 18:11:10 -0400 Subject: [PATCH 109/235] Split syntax-classes out into separate file to reduce requires. --- .../typed-scheme/private/parse-classes.rkt | 26 +++++++++++++++++++ collects/typed-scheme/private/parse-type.rkt | 23 +--------------- 2 files changed, 27 insertions(+), 22 deletions(-) create mode 100644 collects/typed-scheme/private/parse-classes.rkt diff --git a/collects/typed-scheme/private/parse-classes.rkt b/collects/typed-scheme/private/parse-classes.rkt new file mode 100644 index 0000000000..6e6b6db15e --- /dev/null +++ b/collects/typed-scheme/private/parse-classes.rkt @@ -0,0 +1,26 @@ +#lang racket/base + +(require syntax/parse) +(provide star ddd ddd/bound) + +(define-syntax-class star + #:description "*" + (pattern star:id + #:fail-unless (eq? '* (syntax-e #'star)) "missing *") + (pattern star:id + #:fail-unless (eq? '...* (syntax-e #'star)) "missing ...*")) + +(define-syntax-class ddd + #:description "..." + (pattern ddd:id + #:fail-unless (eq? '... (syntax-e #'ddd)) "missing ...")) + +(define-splicing-syntax-class ddd/bound + #:description "... followed by variable name" + #:attributes (bound) + (pattern i:id + #:attr s (symbol->string (syntax-e #'i)) + #:fail-unless ((string-length (attribute s)) . > . 3) #f + #:fail-unless (equal? "..." (substring (attribute s) 0 3)) "missing ..." + #:attr bound (datum->syntax #'i (string->symbol (substring (attribute s) 3)) #'i #'i)) + (pattern (~seq _:ddd bound:id))) diff --git a/collects/typed-scheme/private/parse-type.rkt b/collects/typed-scheme/private/parse-type.rkt index 1c07f6b81f..45046205df 100644 --- a/collects/typed-scheme/private/parse-type.rkt +++ b/collects/typed-scheme/private/parse-type.rkt @@ -8,6 +8,7 @@ syntax/parse (env type-env-structs tvar-env type-name-env type-alias-env lexical-env index-env) racket/match + "parse-classes.rkt" (for-template scheme/base "../base-env/colon.rkt") ;; needed at this phase for tests (combine-in (prefix-in t: "../base-env/base-types-extra.rkt") "../base-env/colon.rkt") @@ -30,28 +31,6 @@ (p stx*))) -(define-syntax-class star - #:description "*" - (pattern star:id - #:fail-unless (eq? '* (syntax-e #'star)) "missing *") - (pattern star:id - #:fail-unless (eq? '...* (syntax-e #'star)) "missing ...*")) - -(define-syntax-class ddd - #:description "..." - (pattern ddd:id - #:fail-unless (eq? '... (syntax-e #'ddd)) "missing ...")) - -(define-splicing-syntax-class ddd/bound - #:description "... followed by variable name" - #:attributes (bound) - (pattern i:id - #:attr s (symbol->string (syntax-e #'i)) - #:fail-unless ((string-length (attribute s)) . > . 3) #f - #:fail-unless (equal? "..." (substring (attribute s) 0 3)) "missing ..." - #:attr bound (datum->syntax #'i (string->symbol (substring (attribute s) 3)) #'i #'i)) - (pattern (~seq _:ddd bound:id))) - (define (parse-all-body s) (syntax-parse s [(ty) From 9a15a1febbdf81916a2638146499c872f35a6659 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 31 Aug 2011 12:37:31 -0400 Subject: [PATCH 110/235] Reduce requires. --- .../base-env/annotate-classes.rkt | 5 ++-- .../base-env/base-types-extra.rkt | 11 ++------ collects/typed-scheme/base-env/colon.rkt | 4 +-- .../typed-scheme/base-env/extra-procs.rkt | 2 +- collects/typed-scheme/base-env/prims.rkt | 16 ++++++----- .../typed-scheme/base-env/type-env-lang.rkt | 13 ++++----- collects/typed-scheme/env/init-envs.rkt | 7 ++--- collects/typed-scheme/minimal.rkt | 4 +-- .../typed-scheme/private/typed-renaming.rkt | 4 +-- collects/typed-scheme/rep/rep-utils.rkt | 20 ++++++------- collects/typed-scheme/typed-scheme.rkt | 13 +++++---- .../typed-scheme/types/numeric-predicates.rkt | 4 +-- collects/typed-scheme/types/printer.rkt | 7 ++--- collects/typed-scheme/types/type-table.rkt | 4 ++- collects/typed-scheme/types/union.rkt | 10 ++++--- .../typed-scheme/utils/require-contract.rkt | 6 ++-- collects/typed-scheme/utils/utils.rkt | 28 +++++++++++-------- 17 files changed, 79 insertions(+), 79 deletions(-) diff --git a/collects/typed-scheme/base-env/annotate-classes.rkt b/collects/typed-scheme/base-env/annotate-classes.rkt index 7ef0a8130e..515d23dab0 100644 --- a/collects/typed-scheme/base-env/annotate-classes.rkt +++ b/collects/typed-scheme/base-env/annotate-classes.rkt @@ -1,6 +1,7 @@ -#lang scheme/base +#lang racket/base -(require syntax/parse "colon.rkt" (for-template "colon.rkt") "../private/parse-type.rkt") +(require syntax/parse "../private/parse-classes.rkt" + (for-template "colon.rkt")) (provide (all-defined-out)) (define-splicing-syntax-class annotated-name diff --git a/collects/typed-scheme/base-env/base-types-extra.rkt b/collects/typed-scheme/base-env/base-types-extra.rkt index f3b412e351..f686e74bd6 100644 --- a/collects/typed-scheme/base-env/base-types-extra.rkt +++ b/collects/typed-scheme/base-env/base-types-extra.rkt @@ -1,6 +1,6 @@ -#lang scheme/base +#lang racket/base -(require (for-syntax scheme/base)) +(require (for-syntax racket/base)) (define-syntax (define-other-types stx) (syntax-case stx () @@ -12,15 +12,10 @@ ;; special type names that are not bound to particular types (define-other-types - #;-> case-> U Rec All Opaque Vector + -> case-> U Rec All Opaque Vector Parameterof List List* Class Values Instance Refinement pred) -(define-syntax -> - (lambda (stx) - (raise-syntax-error 'type-check "type name used out of context" stx))) -(provide ->) - (provide (rename-out [All ∀] [U Un] [-> →] diff --git a/collects/typed-scheme/base-env/colon.rkt b/collects/typed-scheme/base-env/colon.rkt index cef4b4ebab..fb8bdaffa1 100644 --- a/collects/typed-scheme/base-env/colon.rkt +++ b/collects/typed-scheme/base-env/colon.rkt @@ -2,9 +2,7 @@ (require (for-syntax scheme/base syntax/parse "internal.rkt") "../typecheck/internal-forms.rkt" - (prefix-in t: "base-types-extra.rkt") - (for-template (prefix-in t: "base-types-extra.rkt")) - (for-syntax (prefix-in t: "base-types-extra.rkt"))) + (prefix-in t: "base-types-extra.rkt")) (provide :) diff --git a/collects/typed-scheme/base-env/extra-procs.rkt b/collects/typed-scheme/base-env/extra-procs.rkt index 0938125243..c04ea1c362 100644 --- a/collects/typed-scheme/base-env/extra-procs.rkt +++ b/collects/typed-scheme/base-env/extra-procs.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base (provide assert defined?) (define-syntax assert diff --git a/collects/typed-scheme/base-env/prims.rkt b/collects/typed-scheme/base-env/prims.rkt index e5762a3830..a1088ef84b 100644 --- a/collects/typed-scheme/base-env/prims.rkt +++ b/collects/typed-scheme/base-env/prims.rkt @@ -31,7 +31,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (require "../utils/require-contract.rkt" "colon.rkt" "../typecheck/internal-forms.rkt" - (rename-in racket/contract [-> c->] [case-> c:case->]) + (rename-in racket/contract/base [-> c->] [case-> c:case->]) "base-types.rkt" "base-types-extra.rkt" racket/flonum ; for for/flvector and for*/flvector @@ -42,20 +42,22 @@ This file defines two sorts of primitives. All of them are provided into any mod racket/base racket/struct-info syntax/struct - "../rep/type-rep.rkt" - "../private/parse-type.rkt" + "../rep/type-rep.rkt" "annotate-classes.rkt" "internal.rkt" "../utils/tc-utils.rkt" - "../env/type-name-env.rkt" - "../private/type-contract.rkt" - "for-clauses.rkt" - "../types/utils.rkt") + "../env/type-name-env.rkt" + "for-clauses.rkt") "../types/numeric-predicates.rkt") (provide index?) ; useful for assert, and racket doesn't have it (define-for-syntax (ignore stx) (syntax-property stx 'typechecker:ignore #t)) +;; dynamically loaded b/c they're only used at the top-level, so we save a lot +;; of loading by not having them when we're in a module +(define-for-syntax (parse-type stx) ((dynamic-require 'typed-scheme/private/parse-type 'parse-type) stx)) +(define-for-syntax (type->contract stx) ((dynamic-require 'typed-scheme/private/type-contract 'type->contract) stx)) + (define-syntaxes (require/typed-legacy require/typed) (let () diff --git a/collects/typed-scheme/base-env/type-env-lang.rkt b/collects/typed-scheme/base-env/type-env-lang.rkt index 074080c111..452738467e 100644 --- a/collects/typed-scheme/base-env/type-env-lang.rkt +++ b/collects/typed-scheme/base-env/type-env-lang.rkt @@ -1,9 +1,8 @@ -#lang scheme/base +#lang racket/base -(require "../utils/utils.rkt") - -(require (for-syntax (env init-envs) - scheme/base syntax/parse +(require "../utils/utils.rkt" + (for-syntax (env init-envs) + racket/base syntax/parse (except-in (rep filter-rep type-rep) make-arr) (rename-in (types union convenience) [make-arr* make-arr]))) @@ -24,8 +23,8 @@ (provide #%module-begin require - (all-from-out scheme/base) + (all-from-out racket/base) (for-syntax (types-out convenience union) (rep-out type-rep) - (all-from-out scheme/base))) + (all-from-out racket/base))) diff --git a/collects/typed-scheme/env/init-envs.rkt b/collects/typed-scheme/env/init-envs.rkt index ab2be0991d..0ccbb511ca 100644 --- a/collects/typed-scheme/env/init-envs.rkt +++ b/collects/typed-scheme/env/init-envs.rkt @@ -1,16 +1,15 @@ -#lang scheme/base +#lang racket/base (provide (all-defined-out)) (require "../utils/utils.rkt" "global-env.rkt" "type-name-env.rkt" "type-alias-env.rkt" - unstable/struct racket/dict (rep type-rep object-rep filter-rep rep-utils) (for-template (rep type-rep object-rep filter-rep) (types union) - mzlib/pconvert mzlib/shared scheme/base) + racket/shared racket/base) (types union convenience) - mzlib/pconvert racket/match mzlib/shared) + mzlib/pconvert racket/match) (define (initialize-type-name-env initial-type-names) (for-each (lambda (nm/ty) (register-resolved-type-alias (car nm/ty) (cadr nm/ty))) initial-type-names)) diff --git a/collects/typed-scheme/minimal.rkt b/collects/typed-scheme/minimal.rkt index b3a9ef68bc..837344a9c0 100644 --- a/collects/typed-scheme/minimal.rkt +++ b/collects/typed-scheme/minimal.rkt @@ -1,9 +1,9 @@ -#lang scheme/base +#lang racket/base (provide #%module-begin provide require rename-in rename-out prefix-in only-in all-from-out except-out except-in providing begin subtract-in) -(require (for-syntax scheme/base) scheme/require) +(require (for-syntax racket/base) racket/require) (define-for-syntax ts-mod 'typed-scheme/typed-scheme) diff --git a/collects/typed-scheme/private/typed-renaming.rkt b/collects/typed-scheme/private/typed-renaming.rkt index 39f6bfaf72..9310827fd7 100644 --- a/collects/typed-scheme/private/typed-renaming.rkt +++ b/collects/typed-scheme/private/typed-renaming.rkt @@ -1,6 +1,6 @@ -#lang scheme/base +#lang racket/base -(require (for-syntax scheme/base)) +(require (for-syntax racket/base)) (provide make-typed-renaming get-alternate) diff --git a/collects/typed-scheme/rep/rep-utils.rkt b/collects/typed-scheme/rep/rep-utils.rkt index c23a3a0757..70ab968df4 100644 --- a/collects/typed-scheme/rep/rep-utils.rkt +++ b/collects/typed-scheme/rep/rep-utils.rkt @@ -1,23 +1,19 @@ -#lang scheme/base -(require "../utils/utils.rkt") - -(require mzlib/pconvert +#lang racket/base +(require "../utils/utils.rkt" + mzlib/pconvert racket/match "free-variance.rkt" "interning.rkt" unstable/match unstable/struct racket/stxparam - scheme/contract (for-syntax - scheme/list - (only-in racket/syntax generate-temporary) racket/match (except-in syntax/parse id identifier keyword) - scheme/base + racket/base syntax/struct - scheme/contract + racket/contract racket/syntax - (rename-in (except-in (utils utils stxclass-util) bytes byte-regexp regexp byte-pregexp pregexp) + (rename-in (except-in (utils stxclass-util) bytes byte-regexp regexp byte-pregexp pregexp) [id* id] [keyword* keyword]))) @@ -155,7 +151,7 @@ (with-syntax ;; makes as many underscores as default fields (+1 for key? if provided) ([(ign-pats ...) (let loop ([fs default-fields]) - (if (empty? fs) + (if (null? fs) (key->list key? #'_) (cons #'_ (loop (cdr fs)))))] ;; has to be down here to refer to #'contract @@ -239,7 +235,7 @@ #,(body-f)))])) (define (no-duplicates? lst) - (cond [(empty? lst) #t] + (cond [(null? lst) #t] [(member (car lst) (cdr lst)) #f] [else (no-duplicates? (cdr lst))])) diff --git a/collects/typed-scheme/typed-scheme.rkt b/collects/typed-scheme/typed-scheme.rkt index a60231ad42..f0e8165d7a 100644 --- a/collects/typed-scheme/typed-scheme.rkt +++ b/collects/typed-scheme/typed-scheme.rkt @@ -1,10 +1,11 @@ #lang racket/base -(require (for-syntax racket/base - "utils/utils.rkt" ;; only for timing/debugging - ;; these requires are needed since their code - ;; appears in the residual program - "typecheck/renamer.rkt" "types/type-table.rkt")) +(require + (for-syntax racket/base "utils/utils.rkt") ;; only for timing/debugging + ;; the below requires are needed since they provide identifiers + ;; that may appear in the residual program + (for-syntax "typecheck/renamer.rkt" "types/type-table.rkt") + "utils/any-wrap.rkt" unstable/contract) (provide (rename-out [module-begin #%module-begin] [top-interaction #%top-interaction] @@ -26,7 +27,7 @@ (do-time "Finshed base-env") ((dynamic-require 'typed-scheme/base-env/base-env-numeric 'init)) (do-time "Finshed base-env-numeric") - ((dynamic-require 'typed-scheme/base-env/base-special-env 'initialize-special)) + ((dynamic-require 'typed-scheme/base-env/base-special-env 'initialize-special)) (do-time "Finished base-special-env") (set! initialized #t))) diff --git a/collects/typed-scheme/types/numeric-predicates.rkt b/collects/typed-scheme/types/numeric-predicates.rkt index 4224f3e30b..5e38bded86 100644 --- a/collects/typed-scheme/types/numeric-predicates.rkt +++ b/collects/typed-scheme/types/numeric-predicates.rkt @@ -1,6 +1,6 @@ #lang racket/base -(require unstable/function racket/unsafe/ops) +(require racket/unsafe/ops) (provide index? exact-rational?) @@ -11,4 +11,4 @@ ;; we're safe from fixnum size issues on different platforms. (define (index? x) (and (fixnum? x) (unsafe-fx>= x 0) (fixnum? (* x 4)))) -(define exact-rational? (conjoin rational? exact?)) +(define (exact-rational? x) (and (rational? x) (exact? x))) diff --git a/collects/typed-scheme/types/printer.rkt b/collects/typed-scheme/types/printer.rkt index 0a525c6e3c..d05033c60b 100644 --- a/collects/typed-scheme/types/printer.rkt +++ b/collects/typed-scheme/types/printer.rkt @@ -1,7 +1,6 @@ -#lang scheme/base +#lang racket/base -(require racket/require racket/match racket/list racket/string - unstable/sequence +(require racket/require racket/match unstable/sequence (prefix-in s: srfi/1) (path-up "rep/type-rep.rkt" "rep/filter-rep.rkt" "rep/object-rep.rkt" "rep/rep-utils.rkt" "types/abbrev.rkt" "types/subtype.rkt" @@ -173,7 +172,7 @@ [(list a b ...) (format "(case-lambda ~a~a)" (format-arr a) - (string-append* (map format-arr b)))]))])) + (apply string-append (map format-arr b)))]))])) ;; print out a type ;; print-type : Type Port Boolean -> Void diff --git a/collects/typed-scheme/types/type-table.rkt b/collects/typed-scheme/types/type-table.rkt index f1bbc576cb..5b19d7f860 100644 --- a/collects/typed-scheme/types/type-table.rkt +++ b/collects/typed-scheme/types/type-table.rkt @@ -1,12 +1,14 @@ #lang racket/base -(require racket/contract syntax/id-table racket/dict racket/match mzlib/pconvert +(require syntax/id-table racket/dict racket/match mzlib/pconvert "../utils/utils.rkt" + (contract-req) (rep type-rep object-rep) (only-in (types utils) tc-results?) (utils tc-utils) (env init-envs)) + (define table (make-hasheq)) (define (reset-type-table) (set! table (make-hasheq))) diff --git a/collects/typed-scheme/types/union.rkt b/collects/typed-scheme/types/union.rkt index e62fef13ed..8a47bf1b4f 100644 --- a/collects/typed-scheme/types/union.rkt +++ b/collects/typed-scheme/types/union.rkt @@ -1,12 +1,14 @@ -#lang scheme/base +#lang racket/base (require "../utils/utils.rkt" (rep type-rep rep-utils) - (utils tc-utils) - (prefix-in c: racket/contract) - (types utils subtype abbrev printer comparison) + (utils tc-utils) + (contract-req) + (types utils subtype abbrev printer comparison) racket/match) + + (provide/cond-contract [Un (() #:rest (c:listof Type/c) . c:->* . Type/c)]) diff --git a/collects/typed-scheme/utils/require-contract.rkt b/collects/typed-scheme/utils/require-contract.rkt index 4b0dec2569..e39a261e1d 100644 --- a/collects/typed-scheme/utils/require-contract.rkt +++ b/collects/typed-scheme/utils/require-contract.rkt @@ -1,8 +1,8 @@ -#lang scheme/base +#lang racket/base -(require scheme/contract +(require racket/contract/region racket/contract/base syntax/location - (for-syntax scheme/base + (for-syntax racket/base syntax/parse (prefix-in tr: "../private/typed-renaming.rkt"))) diff --git a/collects/typed-scheme/utils/utils.rkt b/collects/typed-scheme/utils/utils.rkt index 5c3f2fc64a..d1f078ad80 100644 --- a/collects/typed-scheme/utils/utils.rkt +++ b/collects/typed-scheme/utils/utils.rkt @@ -6,9 +6,9 @@ at least theoretically. |# (require (for-syntax racket/base syntax/parse racket/string) - racket/contract/base racket/require-syntax - racket/provide-syntax racket/unit (prefix-in d: unstable/debug) - racket/struct-info racket/pretty mzlib/pconvert syntax/parse) + racket/require-syntax racket/unit + racket/provide-syntax (prefix-in d: unstable/debug) + racket/struct-info) ;; to move to unstable (provide reverse-begin list-update list-set debugf debugging? dprintf) @@ -27,6 +27,13 @@ at least theoretically. (define optimize? (make-parameter #t)) (define-for-syntax enable-contracts? #f) + +(define-syntax do-contract-req + (if enable-contracts? + (syntax-rules () [(_) (require racket/contract/base)]) + (syntax-rules () [(_) (begin)]))) +(do-contract-req) + (define show-input? (make-parameter #f)) ;; fancy require syntax @@ -152,13 +159,6 @@ at least theoretically. print-type* print-filter* print-latentfilter* print-object* print-latentobject* print-pathelem*) -(define (pseudo-printer s port mode) - (parameterize ([current-output-port port] - [show-sharing #f] - [booleans-as-true/false #f] - [constructor-style-printing #t]) - (pretty-print (print-convert s)))) - (define custom-printer (make-parameter #t)) (define-syntax (define-struct/printer stx) @@ -167,7 +167,13 @@ at least theoretically. #`(define-struct name (flds ...) #:property prop:custom-print-quotable 'never #:property prop:custom-write - (lambda (a b c) (if (custom-printer) (printer a b c) (pseudo-printer a b c))) + (lambda (a b c) (if (custom-printer) + (printer a b c) + ;; ok to make this case slow, it never runs in real code + ((if c + (dynamic-require 'racket/pretty 'pretty-write) + (dynamic-require 'racket/pretty 'pretty-print)) + a b))) #:transparent)])) From 55e5ecfc74acee5061bc5a41f4584d47b08c8292 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 3 Sep 2011 18:32:34 -0400 Subject: [PATCH 111/235] Disable this file in DrDr -- it launches DrRacket. --- collects/meta/props | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/meta/props b/collects/meta/props index 4344a49b8b..ba8a94c103 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1275,7 +1275,7 @@ path/s is either such a string or a list of them. "collects/scribble/text" responsible (eli) "collects/scribble/text.rkt" responsible (eli) "collects/scribble/tools" responsible (robby) -"collects/scribble/tools/drracket-buttons.rkt" drdr:command-line (gracket-text *) +"collects/scribble/tools/drracket-buttons.rkt" drdr:command-line #f "collects/scribble/tools/private/mk-drs-bitmaps.rkt" drdr:command-line (gracket-text * "skip") "collects/scribblings" responsible (mflatt eli robby matthias) "collects/scribblings/framework/standard-menus.scrbl" drdr:command-line #f From d2e1cc02dc587b8ed29548b16a92ee4abcde4875 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 3 Sep 2011 19:16:28 -0400 Subject: [PATCH 112/235] Move typed-scheme to typed-racket collection. Compatibilty typed-scheme collection left. --- collects/scribblings/guide/dialects.scrbl | 2 +- .../benchmarks/common/typed/wrapper.rkt | 2 +- .../benchmarks/shootout/typed/wrapper.rkt | 2 +- collects/tests/run-automated-tests.rkt | 2 +- .../fail/all-bad-syntax.rkt | 0 .../fail/ann-map-funcs.rkt | 0 .../fail/apply-dots.rkt | 0 .../fail/back-and-forth.rkt | 0 .../fail/bad-ann.rkt | 0 .../fail/bad-any.rkt | 0 .../fail/bad-first.rkt | 0 .../fail/bad-hash-ref.rkt | 0 .../fail/bad-map-poly.rkt | 0 .../fail/bad-type-app.rkt | 0 .../fail/box-fail.rkt | 0 .../fail/check-expect-fail.rkt | 0 .../fail/cl-bug.rkt | 0 .../fail/cnt-err1.rkt | 0 .../fail/cnt-struct-err.rkt | 0 .../fail/dead-substruct.rkt | 0 .../fail/dup-ann.rkt | 0 .../fail/duplicate-ann.rkt | 0 .../fail/formal-len-mismatches.rkt | 0 .../fail/gadt.rkt | 0 .../fail/ht-infer.rkt | 0 .../fail/inexact-complex.rkt | 0 .../fail/infer-dots.rkt | 2 +- .../fail/internal-ann.rkt | 0 .../fail/log-not-complex.rkt | 0 .../fail/nested-tvars.rkt | 0 .../fail/nonnegative-float.rkt | 0 .../fail/poly-expect-error.rkt | 0 .../fail/port-to-list.rkt | 0 .../fail/pr10350.rkt | 0 .../fail/pr10594.rkt | 0 .../fail/pr11560.rkt | 0 .../fail/pr11686.rkt | 0 .../fail/pr11772.rkt | 0 .../fail/pr11998.rkt | 0 .../fail/require-typed-missing.rkt | 0 .../fail/require-typed-wrong.rkt | 0 .../fail/reverse-special.rkt | 0 .../fail/rts-prov.rkt | 0 .../fail/safe-letrec.rkt | 0 .../fail/set-struct.rkt | 0 .../fail/set-tests.rkt | 0 .../fail/sort.rkt | 0 .../fail/struct-provide.rkt | 0 .../fail/subtype-int-err.rkt | 0 .../fail/tc-error-format.rkt | 0 .../fail/too-many-errors.rkt | 0 .../fail/unbound-non-reg.rkt | 0 .../fail/unbound-type.rkt | 0 .../fail/undefined.rkt | 0 .../fail/unsafe-struct-parent.rkt | 0 .../fail/unsafe-struct.rkt | 0 .../fail/untyped-srfi1.rkt | 0 .../fail/values-dots.rkt | 2 +- .../fail/with-asserts.rkt | 0 .../fail/with-asserts2.rkt | 0 .../fail/with-asserts3.rkt | 0 .../fail/with-type-bug.rkt | 0 .../fail/with-type1.rkt | 0 .../fail/with-type2.rkt | 0 .../fail/with-type3.rkt | 0 .../{typed-scheme => typed-racket}/info.rkt | 0 .../{typed-scheme => typed-racket}/main.rkt | 0 .../nightly-run.rkt | 0 .../missed-optimizations/all-real.rkt | 0 .../optimizer/missed-optimizations/fixnum.rkt | 0 .../missed-optimizations/multi-file1.rkt | 0 .../missed-optimizations/multi-file2.rkt | 0 .../multiple-irritants.rkt | 0 .../missed-optimizations/nested-same-kind.rkt | 0 .../optimizer/missed-optimizations/pair.rkt | 0 .../missed-optimizations/precision-loss.rkt | 0 .../real-in-float-expr.rkt | 0 .../missed-optimizations/unary-float.rkt | 0 .../unexpected-complex.rkt | 0 .../optimizer/run.rkt | 2 +- .../optimizer/tests/add1.rkt | 0 .../optimizer/tests/apply-plus.rkt | 0 .../optimizer/tests/begin-float.rkt | 0 .../optimizer/tests/binary-fixnum.rkt | 0 .../optimizer/tests/binary-nonzero-fixnum.rkt | 0 .../optimizer/tests/bounds-check.rkt | 0 .../optimizer/tests/box.rkt | 0 .../optimizer/tests/cross-module-struct.rkt | 0 .../optimizer/tests/cross-module-struct2.rkt | 0 .../optimizer/tests/dead-else.rkt | 0 .../optimizer/tests/dead-substructs.rkt | 0 .../optimizer/tests/dead-then.rkt | 0 .../optimizer/tests/define-begin-float.rkt | 0 .../optimizer/tests/define-call-float.rkt | 0 .../optimizer/tests/define-float.rkt | 0 .../optimizer/tests/define-pair.rkt | 0 .../optimizer/tests/derived-pair.rkt | 0 .../optimizer/tests/derived-pair2.rkt | 0 .../optimizer/tests/derived-pair3.rkt | 0 .../optimizer/tests/different-langs.rkt | 0 .../optimizer/tests/double-float.rkt | 0 .../optimizer/tests/exact-inexact.rkt | 0 .../optimizer/tests/false-huh-dead-code.rkt | 0 .../optimizer/tests/fixnum-bounded-expr.rkt | 0 .../optimizer/tests/fixnum-comparison.rkt | 0 .../optimizer/tests/float-comp.rkt | 0 .../tests/float-complex-conjugate-top.rkt | 0 .../tests/float-complex-conjugate.rkt | 0 .../optimizer/tests/float-complex-div.rkt | 0 .../optimizer/tests/float-complex-fixnum.rkt | 0 .../tests/float-complex-float-div.rkt | 0 .../tests/float-complex-float-mul.rkt | 0 .../tests/float-complex-float-small.rkt | 0 .../optimizer/tests/float-complex-float.rkt | 0 .../optimizer/tests/float-complex-i.rkt | 0 .../optimizer/tests/float-complex-integer.rkt | 0 .../optimizer/tests/float-complex-mult.rkt | 0 .../optimizer/tests/float-complex-parts.rkt | 0 .../optimizer/tests/float-complex-parts2.rkt | 0 .../optimizer/tests/float-complex-parts3.rkt | 0 .../optimizer/tests/float-complex-sin.rkt | 0 .../optimizer/tests/float-complex.rkt | 0 .../optimizer/tests/float-fun.rkt | 0 .../optimizer/tests/float-promotion.rkt | 0 .../optimizer/tests/float-real.rkt | 0 .../optimizer/tests/flvector-length.rkt | 0 .../optimizer/tests/fx-fl.rkt | 0 .../optimizer/tests/in-bytes.rkt | 0 .../optimizer/tests/in-list.rkt | 0 .../optimizer/tests/in-string.rkt | 0 .../optimizer/tests/in-vector.rkt | 0 .../tests/invalid-binary-nonzero-fixnum.rkt | 0 .../optimizer/tests/invalid-derived-pair.rkt | 0 .../optimizer/tests/invalid-exact-inexact.rkt | 0 .../optimizer/tests/invalid-float-comp.rkt | 0 .../tests/invalid-float-promotion.rkt | 0 .../tests/invalid-inexact-complex-parts.rkt | 0 .../optimizer/tests/invalid-log-complex.rkt | 0 .../tests/invalid-make-flrectangular.rkt | 0 .../optimizer/tests/invalid-make-polar.rkt | 0 .../optimizer/tests/invalid-mpair.rkt | 0 .../optimizer/tests/invalid-sqrt.rkt | 0 .../optimizer/tests/invalid-unboxed-let.rkt | 0 .../optimizer/tests/invalid-unboxed-let2.rkt | 0 .../optimizer/tests/invalid-vector-ref.rkt | 0 .../optimizer/tests/invalid-vector-set.rkt | 0 .../optimizer/tests/known-length-lists.rkt | 0 .../optimizer/tests/known-vector-length.rkt | 0 .../optimizer/tests/let-float.rkt | 0 .../optimizer/tests/let-rhs.rkt | 0 .../optimizer/tests/literal-int.rkt | 0 .../optimizer/tests/magnitude.rkt | 0 .../optimizer/tests/make-flrectangular.rkt | 0 .../optimizer/tests/make-polar.rkt | 0 .../optimizer/tests/maybe-exact-complex.rkt | 0 .../optimizer/tests/module-path.rkt | 0 .../optimizer/tests/mpair.rkt | 0 .../optimizer/tests/n-ary-float-complex.rkt | 0 .../optimizer/tests/n-ary-float.rkt | 0 .../optimizer/tests/nested-float-complex.rkt | 0 .../optimizer/tests/nested-float.rkt | 0 .../optimizer/tests/nested-float2.rkt | 0 .../optimizer/tests/nested-let-loop.rkt | 0 .../optimizer/tests/nested-pair1.rkt | 0 .../optimizer/tests/nested-pair2.rkt | 0 .../optimizer/tests/nested-unboxed-let.rkt | 0 .../optimizer/tests/one-arg-arith.rkt | 0 .../optimizer/tests/pair-fun.rkt | 0 .../tests/pair-known-length-list.rkt | 0 .../optimizer/tests/quote.rkt | 0 .../optimizer/tests/rational-literal.rkt | 0 .../optimizer/tests/real-part-loop.rkt | 0 .../optimizer/tests/silent-dead-branch.rkt | 0 .../optimizer/tests/simple-float.rkt | 0 .../optimizer/tests/simple-pair.rkt | 0 .../optimizer/tests/sqrt-segfault.rkt | 0 .../optimizer/tests/sqrt.rkt | 0 .../optimizer/tests/string-length.rkt | 0 .../optimizer/tests/structs.rkt | 0 .../optimizer/tests/unary-fixnum-nested.rkt | 0 .../optimizer/tests/unary-fixnum.rkt | 0 .../optimizer/tests/unary-float.rkt | 0 .../optimizer/tests/unboxed-for.rkt | 0 .../tests/unboxed-let-functions1.rkt | 0 .../tests/unboxed-let-functions2.rkt | 0 .../tests/unboxed-let-functions3.rkt | 0 .../tests/unboxed-let-functions4.rkt | 0 .../tests/unboxed-let-functions5.rkt | 0 .../tests/unboxed-let-functions6.rkt | 0 .../tests/unboxed-let-functions7.rkt | 0 .../tests/unboxed-let-functions8.rkt | 0 .../optimizer/tests/unboxed-let.rkt | 0 .../optimizer/tests/unboxed-let2.rkt | 0 .../optimizer/tests/unboxed-let3.rkt | 0 .../tests/unboxed-letrec-syntaxes+values.rkt | 0 .../optimizer/tests/unboxed-letrec.rkt | 0 .../tests/unboxed-make-rectangular.rkt | 0 .../optimizer/tests/vector-length-nested.rkt | 0 .../optimizer/tests/vector-length.rkt | 0 .../optimizer/tests/vector-ref-set-ref.rkt | 0 .../optimizer/tests/vector-ref.rkt | 0 .../optimizer/tests/vector-ref2.rkt | 0 .../optimizer/tests/vector-set-quote.rkt | 0 .../optimizer/tests/vector-set.rkt | 0 .../optimizer/tests/vector-set2.rkt | 0 .../optimizer/tests/vector-sum.rkt | 0 .../optimizer/tests/with-type.rkt | 0 .../optimizer/tests/zero.rkt | 0 .../optimizer/transform.rkt | 0 .../{typed-scheme => typed-racket}/run.rkt | 0 .../succeed/andmap.rkt | 0 .../succeed/annotation-test.rkt | 0 .../succeed/apply-append.rkt | 0 .../succeed/apply-dots-list.rkt | 0 .../succeed/apply-dots.rkt | 0 .../succeed/area.rkt | 0 .../succeed/at-exp.rkt | 0 .../succeed/bad-map-infer.rkt | 0 .../succeed/barland.rkt | 0 .../succeed/basic-tests.rkt | 0 .../succeed/batched-queue.scm | 0 .../succeed/begin0-error.rkt | 0 .../succeed/box-num.rkt | 0 .../succeed/broken-let-syntax.rkt | 0 .../succeed/check-expect.rkt | 0 .../succeed/check-within.rkt | 0 .../succeed/cl-bug.rkt | 0 .../succeed/cl-tests.rkt | 0 .../succeed/cl.rkt | 0 .../succeed/cmdline.rkt | 0 .../succeed/cps.rkt | 0 .../succeed/datum-to-syntax.rkt | 0 .../succeed/def-pred.rkt | 0 .../succeed/do.rkt | 0 .../succeed/dot-intro.rkt | 0 .../succeed/dotted-identity.rkt | 0 .../succeed/dotted-identity2.rkt | 0 .../succeed/empty-or.rkt | 0 .../succeed/ephemerons.rkt | 0 .../succeed/even-odd.rkt | 0 .../succeed/exceptions.rkt | 0 .../succeed/fix.rkt | 0 .../succeed/fixnum.rkt | 0 .../succeed/float-internal-err.rkt | 0 .../succeed/flonum.rkt | 0 .../succeed/flvector.rkt | 0 .../succeed/fold-left-inst.rkt | 0 .../succeed/fold-left.rkt | 0 .../succeed/foldo.rkt | 0 .../succeed/foo.scm | 0 .../succeed/for-ann.rkt | 0 .../succeed/for-in-range.rkt | 0 .../succeed/for-list.rkt | 0 .../succeed/for-lists.rkt | 0 .../succeed/for-no-anns.rkt | 0 .../succeed/for-no-body-anns.rkt | 0 .../succeed/for-over-hash.rkt | 0 .../succeed/for-seq.rkt | 0 .../succeed/for.rkt | 0 .../succeed/force-delay.rkt | 0 .../succeed/function.rkt | 0 .../succeed/fx-filter.rkt | 0 .../succeed/generalize-vectors.rkt | 0 .../succeed/hari-vector-bug.rkt | 0 .../succeed/hash-ref.rkt | 0 .../succeed/het-vec.rkt | 0 .../succeed/het-vec2.rkt | 0 .../succeed/ho-box.rkt | 0 .../succeed/hw01.scm | 0 .../succeed/icfp-examples.rkt | 0 .../succeed/if-splitting-test.rkt | 0 .../succeed/inexact-complex.rkt | 0 .../succeed/infer-dots.rkt | 2 +- .../succeed/infer-funargs.rkt | 0 .../succeed/inst-dots.rkt | 4 ++-- .../succeed/inst-expected.rkt | 0 .../succeed/int-def-colon.rkt | 0 .../succeed/kw.rkt | 0 .../succeed/leftist-heap.rkt | 4 ---- .../succeed/let-no-anns.rkt | 0 .../succeed/let-values-tests.rkt | 0 .../succeed/list-dots.rkt | 0 .../succeed/list-ref-vec.rkt | 0 .../succeed/list-struct-sum.rkt | 0 .../succeed/little-schemer.rkt | 0 .../succeed/logic.rkt | 0 .../succeed/lots-o-bugs.rkt | 0 .../succeed/mandelbrot.rkt | 0 .../succeed/manual-examples.rkt | 0 .../succeed/map-nonempty.rkt | 0 .../succeed/map1.rkt | 0 .../succeed/map2.rkt | 0 .../succeed/match-dots.rkt | 0 .../succeed/match-dots2.rkt | 0 .../succeed/match-expander-problem.rkt | 0 .../succeed/match-tests.rkt | 0 .../succeed/match.rkt | 0 .../succeed/member-pred.rkt | 0 .../succeed/metrics.rkt | 0 .../succeed/module-lang.rkt | 0 .../succeed/mpair.rkt | 0 .../succeed/mu-rec.rkt | 0 .../succeed/multi-arr-parse.rkt | 0 .../succeed/mutable-poly-struct.rkt | 0 .../succeed/mutable-struct-pred.rkt | 0 .../succeed/nested-poly.rkt | 2 +- .../succeed/new-metrics.rkt | 0 .../succeed/no-bound-fl.rkt | 0 .../succeed/nonnegative-float.rkt | 0 .../succeed/null-program.rkt | 0 .../succeed/opt-arg-test.rkt | 0 .../succeed/opt-lambda.rkt | 0 .../succeed/optimize-simple.rkt | 0 .../succeed/or-sym.rkt | 0 .../succeed/overloading.rkt | 0 .../succeed/pair-test.rkt | 0 .../succeed/pair-test2.rkt | 0 .../succeed/pair-test3.rkt | 0 .../succeed/param.rkt | 0 .../succeed/parse-path.rkt | 0 .../succeed/patch.rkt | 0 .../succeed/paths.rkt | 0 .../succeed/pathstrings.rkt | 0 .../succeed/places-helper.rkt | 0 .../succeed/places.rkt | 6 +++--- .../succeed/poly-ret-ann.rkt | 0 .../succeed/poly-struct-union.rkt | 0 .../succeed/poly-struct.rkt | 0 .../succeed/poly-subtype.rkt | 0 .../succeed/poly-tests.rkt | 0 .../succeed/ports.rkt | 0 .../succeed/pr10057.rkt | 0 .../succeed/pr10318.rkt | 0 .../succeed/pr10319.rkt | 0 .../succeed/pr10342.rkt | 0 .../succeed/pr10470.rkt | 0 .../succeed/pr10552.rkt | 0 .../succeed/pr10562.rkt | 0 .../succeed/pr10718+10755.rkt | 0 .../succeed/pr10729.rkt | 0 .../succeed/pr10937.rkt | 0 .../succeed/pr10939.rkt | 0 .../succeed/pr11171.rkt | 0 .../succeed/pr11193.rkt | 0 .../succeed/pr11194.rkt | 0 .../succeed/pr11314.rkt | 0 .../succeed/pr11425.rkt | 0 .../succeed/pr11504.rkt | 0 .../succeed/pr11509.rkt | 0 .../succeed/pr11532.rkt | 0 .../succeed/pr11545+11776.rkt | 0 .../succeed/pr11560.rkt | 0 .../succeed/pr11578.rkt | 0 .../succeed/pr11617.rkt | 0 .../succeed/pr11686.rkt | 0 .../succeed/pr11709.rkt | 0 .../succeed/pr11728.rkt | 0 .../succeed/pr11756.rkt | 0 .../succeed/pr11859.rkt | 0 .../succeed/pr11866.rkt | 0 .../succeed/pr11887.rkt | 0 .../succeed/pr11897.rkt | 0 .../succeed/pr11912.rkt | 0 .../succeed/pr9043.rkt | 0 .../succeed/pr9046.rkt | 0 .../succeed/pr9048.rkt | 0 .../succeed/pr9053-2.rkt | 0 .../succeed/pr9053.rkt | 0 .../succeed/pr9054.rkt | 0 .../succeed/priority-queue.scm | 0 .../succeed/provide-case-rest.rkt | 0 .../succeed/provide-poly-struct.rkt | 0 .../succeed/provide-sexp.rkt | 0 .../succeed/provide-struct-untyped.rkt | 0 .../succeed/provide-struct.rkt | 0 .../succeed/provide-syntax.rkt | 0 .../succeed/racket-struct.rkt | 0 .../succeed/rackunit.rkt | 0 .../succeed/random-bits.rkt | 0 .../succeed/rec-het-vec-infer.rkt | 0 .../succeed/rec-types.rkt | 0 .../succeed/refinement-even.rkt | 0 .../succeed/require-poly.rkt | 0 .../succeed/require-procedure.rkt | 0 .../succeed/require-struct.rkt | 0 .../succeed/require-substruct.rkt | 0 .../succeed/require-tests.rkt | 2 +- .../succeed/require-typed-parse.rkt | 0 .../succeed/require-typed-rename.rkt | 0 .../succeed/richard-bugs.rkt | 0 .../succeed/safe-letrec.rkt | 0 .../succeed/scratch.rkt | 0 .../succeed/seasoned-schemer.rkt | 0 .../succeed/sequence-cnt.rkt | 0 .../succeed/sequences.rkt | 0 .../succeed/set-contract.rkt | 0 .../succeed/set.rkt | 0 .../succeed/simple-fake-or.rkt | 0 .../succeed/simple-implies.rkt | 0 .../succeed/simple-kw-app.rkt | 0 .../succeed/simple-occurr.rkt | 0 .../succeed/simple-or.rkt | 0 .../succeed/simple-poly.rkt | 0 .../succeed/somesystempath.rkt | 0 .../succeed/star-sizes.rkt | 0 .../succeed/stream.rkt | 0 .../succeed/string-const.rkt | 0 .../succeed/struct-cert.rkt | 0 .../succeed/struct-exec.rkt | 0 .../succeed/struct-mutable.rkt | 0 .../succeed/struct-out.rkt | 0 .../succeed/struct-path-update.rkt | 0 .../succeed/test-child-field.rkt | 0 .../succeed/test.rkt | 0 .../succeed/test2.rkt | 0 .../succeed/threads-and-channels.rkt | 0 .../succeed/time.rkt | 0 .../succeed/typeann-letrec.rkt | 0 .../succeed/typed-list.rkt | 0 .../succeed/typed-scheme-no-check-arrow.rkt | 0 .../succeed/unsafe-struct-parent.rkt | 0 .../succeed/unsafe-struct.rkt | 0 .../succeed/values-dots.rkt | 2 +- .../succeed/varargs-tests.rkt | 0 .../succeed/vec-tests.rkt | 0 .../succeed/with-asserts.rkt | 0 .../succeed/with-handlers.rkt | 0 .../succeed/with-syntax.rkt | 0 .../succeed/with-type.rkt | 0 .../unit-tests/all-tests.rkt | 0 .../unit-tests/contract-tests.rkt | 0 .../unit-tests/infer-tests.rkt | 0 .../unit-tests/module-tests.rkt | 0 .../unit-tests/parse-type-tests.rkt | 0 .../unit-tests/planet-requires.rkt | 0 .../unit-tests/remove-intersect-tests.rkt | 0 .../special-env-typecheck-tests.rkt | 8 ++++---- .../unit-tests/subst-tests.rkt | 0 .../unit-tests/subtype-tests.rkt | 0 .../unit-tests/test-utils.rkt | 2 +- .../unit-tests/type-annotation-test.rkt | 10 +++++----- .../unit-tests/type-equal-tests.rkt | 0 .../unit-tests/typecheck-tests.rkt | 6 +++--- .../xfail/ann-map-funcs.rkt | 0 .../xfail/applicative.rkt | 0 .../xfail/apply-map-bug.rkt | 0 .../xfail/cl-expected.rkt | 0 .../xfail/for-inference.rkt | 0 .../xfail/pr10618.rkt | 0 .../xfail/priority-queue.scm | 0 .../xfail/rec-contract.rkt | 0 .../xfail/unholy-terror.rkt | 0 .../xfail/xmodule-mutation.rkt | 0 .../base-env/annotate-classes.rkt | 0 .../base-env/base-env-indexing-abs.rkt | 0 .../base-env/base-env-indexing.rkt | 0 .../base-env/base-env-numeric.rkt | 0 .../base-env/base-env.rkt | 0 .../base-env/base-special-env.rkt | 0 .../base-env/base-structs.rkt | 0 .../base-env/base-types-extra.rkt | 0 .../base-env/base-types.rkt | 0 .../base-env/colon.rkt | 0 .../base-env/env-lang.rkt | 0 .../base-env/extra-procs.rkt | 0 .../base-env/for-clauses.rkt | 0 .../base-env/internal.rkt | 0 .../base-env/prims.rkt | 4 ++-- .../base-env/type-env-lang.rkt | 0 .../{typed-scheme => typed-racket}/core.rkt | 0 .../env/global-env.rkt | 0 .../env/index-env.rkt | 0 .../env/init-envs.rkt | 0 .../env/lexical-env.rkt | 0 .../env/tvar-env.rkt | 0 .../env/type-alias-env.rkt | 0 .../env/type-env-structs.rkt | 0 .../env/type-name-env.rkt | 0 .../infer/constraint-structs.rkt | 0 .../infer/constraints.rkt | 0 .../infer/dmap.rkt | 0 .../infer/infer-dummy.rkt | 0 .../infer/infer-unit.rkt | 0 .../infer/infer.rkt | 0 .../infer/promote-demote.rkt | 0 .../infer/restrict.rkt | 0 .../infer/signatures.rkt | 0 .../{typed-scheme => typed-racket}/info.rkt | 0 .../language-info.rkt | 6 +++--- .../minimal.rkt | 2 +- .../minimal/lang/reader.rkt | 4 ++-- .../optimizer/apply.rkt | 0 .../optimizer/box.rkt | 0 .../optimizer/dead-code.rkt | 0 .../optimizer/fixnum.rkt | 0 .../optimizer/float-complex.rkt | 0 .../optimizer/float.rkt | 0 .../optimizer/list.rkt | 0 .../optimizer/logging.rkt | 0 .../optimizer/number.rkt | 0 .../optimizer/numeric-utils.rkt | 0 .../optimizer/optimizer.rkt | 0 .../optimizer/pair.rkt | 0 .../optimizer/sequence.rkt | 0 .../optimizer/string.rkt | 0 .../optimizer/struct.rkt | 0 .../optimizer/tool/display.rkt | 0 .../optimizer/tool/report.rkt | 4 ++-- .../optimizer/tool/tool.rkt | 0 .../optimizer/unboxed-let.rkt | 0 .../optimizer/utils.rkt | 0 .../optimizer/vector.rkt | 0 .../private/parse-classes.rkt | 0 .../private/parse-type.rkt | 0 .../private/type-annotation.rkt | 0 .../private/type-contract.rkt | 0 .../private/typed-renaming.rkt | 0 .../private/with-types.rkt | 0 .../rep/filter-rep.rkt | 0 .../rep/free-variance.rkt | 0 .../rep/interning.rkt | 0 .../rep/object-rep.rkt | 0 .../rep/rep-utils.rkt | 0 .../rep/type-rep.rkt | 0 .../scribblings/guide/begin.scrbl | 0 .../scribblings/guide/more.scrbl | 0 .../scribblings/guide/optimization.scrbl | 0 .../scribblings/guide/quick.scrbl | 0 .../scribblings/guide/types.scrbl | 0 .../scribblings/guide/varargs.scrbl | 0 .../reference/compatibility-languages.scrbl | 10 +++++----- .../scribblings/reference/experimental.scrbl | 0 .../scribblings/reference/legacy.scrbl | 0 .../scribblings/reference/libraries.scrbl | 0 .../scribblings/reference/no-check.scrbl | 0 .../scribblings/reference/optimization.scrbl | 2 +- .../scribblings/reference/special-forms.scrbl | 0 .../scribblings/reference/typed-regions.scrbl | 0 .../scribblings/reference/types.scrbl | 0 .../scribblings/reference/utilities.scrbl | 0 .../scribblings/ts-guide.scrbl | 0 .../scribblings/ts-reference.scrbl | 10 +++++----- .../scribblings/utils.rkt | 0 .../tc-setup.rkt | 2 +- .../typecheck/check-below.rkt | 0 .../typecheck/check-subforms-unit.rkt | 0 .../typecheck/def-binding.rkt | 0 .../typecheck/def-export.rkt | 0 .../typecheck/find-annotation.rkt | 0 .../typecheck/internal-forms.rkt | 0 .../typecheck/parse-cl.rkt | 0 .../typecheck/provide-handling.rkt | 0 .../typecheck/renamer.rkt | 0 .../typecheck/signatures.rkt | 0 .../typecheck/tc-app-helper.rkt | 0 .../typecheck/tc-app.rkt | 0 .../typecheck/tc-apply.rkt | 0 .../typecheck/tc-envops.rkt | 0 .../typecheck/tc-expr-unit.rkt | 0 .../typecheck/tc-funapp.rkt | 0 .../typecheck/tc-if.rkt | 0 .../typecheck/tc-lambda-unit.rkt | 0 .../typecheck/tc-let-unit.rkt | 0 .../typecheck/tc-metafunctions.rkt | 0 .../typecheck/tc-structs.rkt | 0 .../typecheck/tc-subst.rkt | 0 .../typecheck/tc-toplevel.rkt | 0 .../typecheck/typechecker.rkt | 0 .../typed-racket.rkt} | 12 +++++------ .../typed-reader.rkt | 0 .../types/abbrev.rkt | 0 .../types/comparison.rkt | 0 .../types/convenience.rkt | 0 .../types/filter-ops.rkt | 0 .../types/numeric-predicates.rkt | 0 .../types/numeric-tower.rkt | 0 .../types/printer.rkt | 0 .../types/remove-intersect.rkt | 0 .../types/resolve.rkt | 0 .../types/substitute.rkt | 0 .../types/subtype.rkt | 0 .../types/type-table.rkt | 0 .../types/union.rkt | 0 .../types/utils.rkt | 0 .../utils/any-wrap.rkt | 0 .../utils/arm.rkt | 0 .../utils/disarm.rkt | 0 .../utils/require-contract.rkt | 0 .../utils/stxclass-util.rkt | 0 .../utils/syntax-traversal.rkt | 0 .../utils/tc-utils.rkt | 0 .../utils/utils.rkt | 4 ++-- collects/typed-scheme/lang/reader.rkt | 4 ++-- collects/typed-scheme/main.rkt | 2 +- collects/typed-scheme/no-check.rkt | 7 ++++--- .../typed-scheme/no-check/lang/reader.rkt | 2 +- collects/typed/racket.rkt | 2 +- collects/typed/racket/base.rkt | 20 +++++++++---------- collects/typed/racket/base/lang/reader.rkt | 4 ++-- collects/typed/racket/lang/reader.rkt | 6 +++--- .../typed/racket/no-check/lang/reader.rkt | 2 +- collects/typed/rackunit/type-env-ext.rkt | 2 +- collects/typed/scheme.rkt | 2 +- collects/typed/scheme/base.rkt | 20 +++++++++---------- collects/typed/scheme/base/lang/reader.rkt | 4 ++-- collects/typed/scheme/lang/reader.rkt | 6 +++--- collects/typed/test-engine/type-env-ext.rkt | 6 +++--- 607 files changed, 104 insertions(+), 107 deletions(-) rename collects/tests/{typed-scheme => typed-racket}/fail/all-bad-syntax.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/ann-map-funcs.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/apply-dots.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/back-and-forth.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/bad-ann.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/bad-any.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/bad-first.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/bad-hash-ref.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/bad-map-poly.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/bad-type-app.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/box-fail.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/check-expect-fail.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/cl-bug.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/cnt-err1.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/cnt-struct-err.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/dead-substruct.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/dup-ann.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/duplicate-ann.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/formal-len-mismatches.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/gadt.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/ht-infer.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/inexact-complex.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/infer-dots.rkt (86%) rename collects/tests/{typed-scheme => typed-racket}/fail/internal-ann.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/log-not-complex.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/nested-tvars.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/nonnegative-float.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/poly-expect-error.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/port-to-list.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/pr10350.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/pr10594.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/pr11560.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/pr11686.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/pr11772.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/pr11998.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/require-typed-missing.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/require-typed-wrong.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/reverse-special.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/rts-prov.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/safe-letrec.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/set-struct.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/set-tests.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/sort.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/struct-provide.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/subtype-int-err.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/tc-error-format.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/too-many-errors.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/unbound-non-reg.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/unbound-type.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/undefined.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/unsafe-struct-parent.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/unsafe-struct.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/untyped-srfi1.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/values-dots.rkt (93%) rename collects/tests/{typed-scheme => typed-racket}/fail/with-asserts.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/with-asserts2.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/with-asserts3.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/with-type-bug.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/with-type1.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/with-type2.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/fail/with-type3.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/info.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/main.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/nightly-run.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/missed-optimizations/all-real.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/missed-optimizations/fixnum.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/missed-optimizations/multi-file1.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/missed-optimizations/multi-file2.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/missed-optimizations/multiple-irritants.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/missed-optimizations/nested-same-kind.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/missed-optimizations/pair.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/missed-optimizations/precision-loss.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/missed-optimizations/real-in-float-expr.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/missed-optimizations/unary-float.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/missed-optimizations/unexpected-complex.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/run.rkt (98%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/add1.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/apply-plus.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/begin-float.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/binary-fixnum.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/binary-nonzero-fixnum.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/bounds-check.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/box.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/cross-module-struct.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/cross-module-struct2.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/dead-else.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/dead-substructs.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/dead-then.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/define-begin-float.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/define-call-float.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/define-float.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/define-pair.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/derived-pair.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/derived-pair2.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/derived-pair3.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/different-langs.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/double-float.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/exact-inexact.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/false-huh-dead-code.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/fixnum-bounded-expr.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/fixnum-comparison.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/float-comp.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/float-complex-conjugate-top.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/float-complex-conjugate.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/float-complex-div.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/float-complex-fixnum.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/float-complex-float-div.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/float-complex-float-mul.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/float-complex-float-small.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/float-complex-float.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/float-complex-i.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/float-complex-integer.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/float-complex-mult.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/float-complex-parts.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/float-complex-parts2.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/float-complex-parts3.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/float-complex-sin.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/float-complex.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/float-fun.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/float-promotion.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/float-real.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/flvector-length.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/fx-fl.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/in-bytes.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/in-list.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/in-string.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/in-vector.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/invalid-binary-nonzero-fixnum.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/invalid-derived-pair.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/invalid-exact-inexact.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/invalid-float-comp.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/invalid-float-promotion.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/invalid-inexact-complex-parts.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/invalid-log-complex.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/invalid-make-flrectangular.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/invalid-make-polar.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/invalid-mpair.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/invalid-sqrt.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/invalid-unboxed-let.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/invalid-unboxed-let2.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/invalid-vector-ref.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/invalid-vector-set.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/known-length-lists.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/known-vector-length.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/let-float.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/let-rhs.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/literal-int.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/magnitude.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/make-flrectangular.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/make-polar.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/maybe-exact-complex.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/module-path.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/mpair.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/n-ary-float-complex.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/n-ary-float.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/nested-float-complex.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/nested-float.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/nested-float2.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/nested-let-loop.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/nested-pair1.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/nested-pair2.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/nested-unboxed-let.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/one-arg-arith.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/pair-fun.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/pair-known-length-list.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/quote.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/rational-literal.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/real-part-loop.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/silent-dead-branch.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/simple-float.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/simple-pair.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/sqrt-segfault.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/sqrt.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/string-length.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/structs.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/unary-fixnum-nested.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/unary-fixnum.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/unary-float.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/unboxed-for.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/unboxed-let-functions1.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/unboxed-let-functions2.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/unboxed-let-functions3.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/unboxed-let-functions4.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/unboxed-let-functions5.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/unboxed-let-functions6.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/unboxed-let-functions7.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/unboxed-let-functions8.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/unboxed-let.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/unboxed-let2.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/unboxed-let3.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/unboxed-letrec-syntaxes+values.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/unboxed-letrec.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/unboxed-make-rectangular.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/vector-length-nested.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/vector-length.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/vector-ref-set-ref.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/vector-ref.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/vector-ref2.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/vector-set-quote.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/vector-set.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/vector-set2.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/vector-sum.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/with-type.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/tests/zero.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/optimizer/transform.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/run.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/andmap.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/annotation-test.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/apply-append.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/apply-dots-list.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/apply-dots.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/area.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/at-exp.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/bad-map-infer.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/barland.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/basic-tests.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/batched-queue.scm (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/begin0-error.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/box-num.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/broken-let-syntax.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/check-expect.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/check-within.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/cl-bug.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/cl-tests.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/cl.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/cmdline.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/cps.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/datum-to-syntax.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/def-pred.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/do.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/dot-intro.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/dotted-identity.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/dotted-identity2.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/empty-or.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/ephemerons.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/even-odd.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/exceptions.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/fix.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/fixnum.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/float-internal-err.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/flonum.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/flvector.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/fold-left-inst.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/fold-left.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/foldo.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/foo.scm (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/for-ann.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/for-in-range.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/for-list.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/for-lists.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/for-no-anns.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/for-no-body-anns.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/for-over-hash.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/for-seq.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/for.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/force-delay.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/function.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/fx-filter.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/generalize-vectors.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/hari-vector-bug.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/hash-ref.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/het-vec.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/het-vec2.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/ho-box.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/hw01.scm (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/icfp-examples.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/if-splitting-test.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/inexact-complex.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/infer-dots.rkt (93%) rename collects/tests/{typed-scheme => typed-racket}/succeed/infer-funargs.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/inst-dots.rkt (69%) rename collects/tests/{typed-scheme => typed-racket}/succeed/inst-expected.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/int-def-colon.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/kw.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/leftist-heap.rkt (98%) rename collects/tests/{typed-scheme => typed-racket}/succeed/let-no-anns.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/let-values-tests.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/list-dots.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/list-ref-vec.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/list-struct-sum.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/little-schemer.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/logic.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/lots-o-bugs.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/mandelbrot.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/manual-examples.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/map-nonempty.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/map1.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/map2.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/match-dots.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/match-dots2.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/match-expander-problem.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/match-tests.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/match.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/member-pred.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/metrics.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/module-lang.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/mpair.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/mu-rec.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/multi-arr-parse.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/mutable-poly-struct.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/mutable-struct-pred.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/nested-poly.rkt (91%) rename collects/tests/{typed-scheme => typed-racket}/succeed/new-metrics.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/no-bound-fl.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/nonnegative-float.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/null-program.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/opt-arg-test.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/opt-lambda.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/optimize-simple.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/or-sym.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/overloading.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pair-test.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pair-test2.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pair-test3.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/param.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/parse-path.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/patch.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/paths.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pathstrings.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/places-helper.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/places.rkt (58%) rename collects/tests/{typed-scheme => typed-racket}/succeed/poly-ret-ann.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/poly-struct-union.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/poly-struct.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/poly-subtype.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/poly-tests.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/ports.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr10057.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr10318.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr10319.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr10342.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr10470.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr10552.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr10562.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr10718+10755.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr10729.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr10937.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr10939.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr11171.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr11193.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr11194.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr11314.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr11425.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr11504.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr11509.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr11532.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr11545+11776.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr11560.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr11578.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr11617.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr11686.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr11709.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr11728.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr11756.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr11859.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr11866.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr11887.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr11897.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr11912.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr9043.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr9046.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr9048.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr9053-2.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr9053.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/pr9054.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/priority-queue.scm (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/provide-case-rest.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/provide-poly-struct.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/provide-sexp.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/provide-struct-untyped.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/provide-struct.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/provide-syntax.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/racket-struct.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/rackunit.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/random-bits.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/rec-het-vec-infer.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/rec-types.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/refinement-even.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/require-poly.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/require-procedure.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/require-struct.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/require-substruct.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/require-tests.rkt (84%) rename collects/tests/{typed-scheme => typed-racket}/succeed/require-typed-parse.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/require-typed-rename.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/richard-bugs.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/safe-letrec.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/scratch.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/seasoned-schemer.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/sequence-cnt.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/sequences.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/set-contract.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/set.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/simple-fake-or.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/simple-implies.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/simple-kw-app.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/simple-occurr.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/simple-or.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/simple-poly.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/somesystempath.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/star-sizes.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/stream.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/string-const.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/struct-cert.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/struct-exec.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/struct-mutable.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/struct-out.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/struct-path-update.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/test-child-field.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/test.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/test2.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/threads-and-channels.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/time.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/typeann-letrec.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/typed-list.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/typed-scheme-no-check-arrow.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/unsafe-struct-parent.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/unsafe-struct.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/values-dots.rkt (95%) rename collects/tests/{typed-scheme => typed-racket}/succeed/varargs-tests.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/vec-tests.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/with-asserts.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/with-handlers.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/with-syntax.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/succeed/with-type.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/unit-tests/all-tests.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/unit-tests/contract-tests.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/unit-tests/infer-tests.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/unit-tests/module-tests.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/unit-tests/parse-type-tests.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/unit-tests/planet-requires.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/unit-tests/remove-intersect-tests.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/unit-tests/special-env-typecheck-tests.rkt (95%) rename collects/tests/{typed-scheme => typed-racket}/unit-tests/subst-tests.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/unit-tests/subtype-tests.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/unit-tests/test-utils.rkt (98%) rename collects/tests/{typed-scheme => typed-racket}/unit-tests/type-annotation-test.rkt (85%) rename collects/tests/{typed-scheme => typed-racket}/unit-tests/type-equal-tests.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/unit-tests/typecheck-tests.rkt (99%) rename collects/tests/{typed-scheme => typed-racket}/xfail/ann-map-funcs.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/xfail/applicative.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/xfail/apply-map-bug.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/xfail/cl-expected.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/xfail/for-inference.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/xfail/pr10618.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/xfail/priority-queue.scm (100%) rename collects/tests/{typed-scheme => typed-racket}/xfail/rec-contract.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/xfail/unholy-terror.rkt (100%) rename collects/tests/{typed-scheme => typed-racket}/xfail/xmodule-mutation.rkt (100%) rename collects/{typed-scheme => typed-racket}/base-env/annotate-classes.rkt (100%) rename collects/{typed-scheme => typed-racket}/base-env/base-env-indexing-abs.rkt (100%) rename collects/{typed-scheme => typed-racket}/base-env/base-env-indexing.rkt (100%) rename collects/{typed-scheme => typed-racket}/base-env/base-env-numeric.rkt (100%) rename collects/{typed-scheme => typed-racket}/base-env/base-env.rkt (100%) rename collects/{typed-scheme => typed-racket}/base-env/base-special-env.rkt (100%) rename collects/{typed-scheme => typed-racket}/base-env/base-structs.rkt (100%) rename collects/{typed-scheme => typed-racket}/base-env/base-types-extra.rkt (100%) rename collects/{typed-scheme => typed-racket}/base-env/base-types.rkt (100%) rename collects/{typed-scheme => typed-racket}/base-env/colon.rkt (100%) rename collects/{typed-scheme => typed-racket}/base-env/env-lang.rkt (100%) rename collects/{typed-scheme => typed-racket}/base-env/extra-procs.rkt (100%) rename collects/{typed-scheme => typed-racket}/base-env/for-clauses.rkt (100%) rename collects/{typed-scheme => typed-racket}/base-env/internal.rkt (100%) rename collects/{typed-scheme => typed-racket}/base-env/prims.rkt (99%) rename collects/{typed-scheme => typed-racket}/base-env/type-env-lang.rkt (100%) rename collects/{typed-scheme => typed-racket}/core.rkt (100%) rename collects/{typed-scheme => typed-racket}/env/global-env.rkt (100%) rename collects/{typed-scheme => typed-racket}/env/index-env.rkt (100%) rename collects/{typed-scheme => typed-racket}/env/init-envs.rkt (100%) rename collects/{typed-scheme => typed-racket}/env/lexical-env.rkt (100%) rename collects/{typed-scheme => typed-racket}/env/tvar-env.rkt (100%) rename collects/{typed-scheme => typed-racket}/env/type-alias-env.rkt (100%) rename collects/{typed-scheme => typed-racket}/env/type-env-structs.rkt (100%) rename collects/{typed-scheme => typed-racket}/env/type-name-env.rkt (100%) rename collects/{typed-scheme => typed-racket}/infer/constraint-structs.rkt (100%) rename collects/{typed-scheme => typed-racket}/infer/constraints.rkt (100%) rename collects/{typed-scheme => typed-racket}/infer/dmap.rkt (100%) rename collects/{typed-scheme => typed-racket}/infer/infer-dummy.rkt (100%) rename collects/{typed-scheme => typed-racket}/infer/infer-unit.rkt (100%) rename collects/{typed-scheme => typed-racket}/infer/infer.rkt (100%) rename collects/{typed-scheme => typed-racket}/infer/promote-demote.rkt (100%) rename collects/{typed-scheme => typed-racket}/infer/restrict.rkt (100%) rename collects/{typed-scheme => typed-racket}/infer/signatures.rkt (100%) rename collects/{typed-scheme => typed-racket}/info.rkt (100%) rename collects/{typed-scheme => typed-racket}/language-info.rkt (69%) rename collects/{typed-scheme => typed-racket}/minimal.rkt (94%) rename collects/{typed-scheme => typed-racket}/minimal/lang/reader.rkt (75%) rename collects/{typed-scheme => typed-racket}/optimizer/apply.rkt (100%) rename collects/{typed-scheme => typed-racket}/optimizer/box.rkt (100%) rename collects/{typed-scheme => typed-racket}/optimizer/dead-code.rkt (100%) rename collects/{typed-scheme => typed-racket}/optimizer/fixnum.rkt (100%) rename collects/{typed-scheme => typed-racket}/optimizer/float-complex.rkt (100%) rename collects/{typed-scheme => typed-racket}/optimizer/float.rkt (100%) rename collects/{typed-scheme => typed-racket}/optimizer/list.rkt (100%) rename collects/{typed-scheme => typed-racket}/optimizer/logging.rkt (100%) rename collects/{typed-scheme => typed-racket}/optimizer/number.rkt (100%) rename collects/{typed-scheme => typed-racket}/optimizer/numeric-utils.rkt (100%) rename collects/{typed-scheme => typed-racket}/optimizer/optimizer.rkt (100%) rename collects/{typed-scheme => typed-racket}/optimizer/pair.rkt (100%) rename collects/{typed-scheme => typed-racket}/optimizer/sequence.rkt (100%) rename collects/{typed-scheme => typed-racket}/optimizer/string.rkt (100%) rename collects/{typed-scheme => typed-racket}/optimizer/struct.rkt (100%) rename collects/{typed-scheme => typed-racket}/optimizer/tool/display.rkt (100%) rename collects/{typed-scheme => typed-racket}/optimizer/tool/report.rkt (98%) rename collects/{typed-scheme => typed-racket}/optimizer/tool/tool.rkt (100%) rename collects/{typed-scheme => typed-racket}/optimizer/unboxed-let.rkt (100%) rename collects/{typed-scheme => typed-racket}/optimizer/utils.rkt (100%) rename collects/{typed-scheme => typed-racket}/optimizer/vector.rkt (100%) rename collects/{typed-scheme => typed-racket}/private/parse-classes.rkt (100%) rename collects/{typed-scheme => typed-racket}/private/parse-type.rkt (100%) rename collects/{typed-scheme => typed-racket}/private/type-annotation.rkt (100%) rename collects/{typed-scheme => typed-racket}/private/type-contract.rkt (100%) rename collects/{typed-scheme => typed-racket}/private/typed-renaming.rkt (100%) rename collects/{typed-scheme => typed-racket}/private/with-types.rkt (100%) rename collects/{typed-scheme => typed-racket}/rep/filter-rep.rkt (100%) rename collects/{typed-scheme => typed-racket}/rep/free-variance.rkt (100%) rename collects/{typed-scheme => typed-racket}/rep/interning.rkt (100%) rename collects/{typed-scheme => typed-racket}/rep/object-rep.rkt (100%) rename collects/{typed-scheme => typed-racket}/rep/rep-utils.rkt (100%) rename collects/{typed-scheme => typed-racket}/rep/type-rep.rkt (100%) rename collects/{typed-scheme => typed-racket}/scribblings/guide/begin.scrbl (100%) rename collects/{typed-scheme => typed-racket}/scribblings/guide/more.scrbl (100%) rename collects/{typed-scheme => typed-racket}/scribblings/guide/optimization.scrbl (100%) rename collects/{typed-scheme => typed-racket}/scribblings/guide/quick.scrbl (100%) rename collects/{typed-scheme => typed-racket}/scribblings/guide/types.scrbl (100%) rename collects/{typed-scheme => typed-racket}/scribblings/guide/varargs.scrbl (100%) rename collects/{typed-scheme => typed-racket}/scribblings/reference/compatibility-languages.scrbl (83%) rename collects/{typed-scheme => typed-racket}/scribblings/reference/experimental.scrbl (100%) rename collects/{typed-scheme => typed-racket}/scribblings/reference/legacy.scrbl (100%) rename collects/{typed-scheme => typed-racket}/scribblings/reference/libraries.scrbl (100%) rename collects/{typed-scheme => typed-racket}/scribblings/reference/no-check.scrbl (100%) rename collects/{typed-scheme => typed-racket}/scribblings/reference/optimization.scrbl (91%) rename collects/{typed-scheme => typed-racket}/scribblings/reference/special-forms.scrbl (100%) rename collects/{typed-scheme => typed-racket}/scribblings/reference/typed-regions.scrbl (100%) rename collects/{typed-scheme => typed-racket}/scribblings/reference/types.scrbl (100%) rename collects/{typed-scheme => typed-racket}/scribblings/reference/utilities.scrbl (100%) rename collects/{typed-scheme => typed-racket}/scribblings/ts-guide.scrbl (100%) rename collects/{typed-scheme => typed-racket}/scribblings/ts-reference.scrbl (75%) rename collects/{typed-scheme => typed-racket}/scribblings/utils.rkt (100%) rename collects/{typed-scheme => typed-racket}/tc-setup.rkt (98%) rename collects/{typed-scheme => typed-racket}/typecheck/check-below.rkt (100%) rename collects/{typed-scheme => typed-racket}/typecheck/check-subforms-unit.rkt (100%) rename collects/{typed-scheme => typed-racket}/typecheck/def-binding.rkt (100%) rename collects/{typed-scheme => typed-racket}/typecheck/def-export.rkt (100%) rename collects/{typed-scheme => typed-racket}/typecheck/find-annotation.rkt (100%) rename collects/{typed-scheme => typed-racket}/typecheck/internal-forms.rkt (100%) rename collects/{typed-scheme => typed-racket}/typecheck/parse-cl.rkt (100%) rename collects/{typed-scheme => typed-racket}/typecheck/provide-handling.rkt (100%) rename collects/{typed-scheme => typed-racket}/typecheck/renamer.rkt (100%) rename collects/{typed-scheme => typed-racket}/typecheck/signatures.rkt (100%) rename collects/{typed-scheme => typed-racket}/typecheck/tc-app-helper.rkt (100%) rename collects/{typed-scheme => typed-racket}/typecheck/tc-app.rkt (100%) rename collects/{typed-scheme => typed-racket}/typecheck/tc-apply.rkt (100%) rename collects/{typed-scheme => typed-racket}/typecheck/tc-envops.rkt (100%) rename collects/{typed-scheme => typed-racket}/typecheck/tc-expr-unit.rkt (100%) rename collects/{typed-scheme => typed-racket}/typecheck/tc-funapp.rkt (100%) rename collects/{typed-scheme => typed-racket}/typecheck/tc-if.rkt (100%) rename collects/{typed-scheme => typed-racket}/typecheck/tc-lambda-unit.rkt (100%) rename collects/{typed-scheme => typed-racket}/typecheck/tc-let-unit.rkt (100%) rename collects/{typed-scheme => typed-racket}/typecheck/tc-metafunctions.rkt (100%) rename collects/{typed-scheme => typed-racket}/typecheck/tc-structs.rkt (100%) rename collects/{typed-scheme => typed-racket}/typecheck/tc-subst.rkt (100%) rename collects/{typed-scheme => typed-racket}/typecheck/tc-toplevel.rkt (100%) rename collects/{typed-scheme => typed-racket}/typecheck/typechecker.rkt (100%) rename collects/{typed-scheme/typed-scheme.rkt => typed-racket/typed-racket.rkt} (78%) rename collects/{typed-scheme => typed-racket}/typed-reader.rkt (100%) rename collects/{typed-scheme => typed-racket}/types/abbrev.rkt (100%) rename collects/{typed-scheme => typed-racket}/types/comparison.rkt (100%) rename collects/{typed-scheme => typed-racket}/types/convenience.rkt (100%) rename collects/{typed-scheme => typed-racket}/types/filter-ops.rkt (100%) rename collects/{typed-scheme => typed-racket}/types/numeric-predicates.rkt (100%) rename collects/{typed-scheme => typed-racket}/types/numeric-tower.rkt (100%) rename collects/{typed-scheme => typed-racket}/types/printer.rkt (100%) rename collects/{typed-scheme => typed-racket}/types/remove-intersect.rkt (100%) rename collects/{typed-scheme => typed-racket}/types/resolve.rkt (100%) rename collects/{typed-scheme => typed-racket}/types/substitute.rkt (100%) rename collects/{typed-scheme => typed-racket}/types/subtype.rkt (100%) rename collects/{typed-scheme => typed-racket}/types/type-table.rkt (100%) rename collects/{typed-scheme => typed-racket}/types/union.rkt (100%) rename collects/{typed-scheme => typed-racket}/types/utils.rkt (100%) rename collects/{typed-scheme => typed-racket}/utils/any-wrap.rkt (100%) rename collects/{typed-scheme => typed-racket}/utils/arm.rkt (100%) rename collects/{typed-scheme => typed-racket}/utils/disarm.rkt (100%) rename collects/{typed-scheme => typed-racket}/utils/require-contract.rkt (100%) rename collects/{typed-scheme => typed-racket}/utils/stxclass-util.rkt (100%) rename collects/{typed-scheme => typed-racket}/utils/syntax-traversal.rkt (100%) rename collects/{typed-scheme => typed-racket}/utils/tc-utils.rkt (100%) rename collects/{typed-scheme => typed-racket}/utils/utils.rkt (99%) diff --git a/collects/scribblings/guide/dialects.scrbl b/collects/scribblings/guide/dialects.scrbl index 592426fb78..e9a8b5db2d 100644 --- a/collects/scribblings/guide/dialects.scrbl +++ b/collects/scribblings/guide/dialects.scrbl @@ -42,7 +42,7 @@ including the following: @item{@racketmodname[typed/racket] --- like @racketmodname[racket], but statically typed; see - @other-manual['(lib "typed-scheme/scribblings/ts-guide.scrbl")]} + @other-manual['(lib "typed-racket/scribblings/ts-guide.scrbl")]} @item{@racketmodname[lazy] --- like @racketmodname[racket/base], but avoids evaluating an expression until its value is needed; see diff --git a/collects/tests/racket/benchmarks/common/typed/wrapper.rkt b/collects/tests/racket/benchmarks/common/typed/wrapper.rkt index 5e01b69697..13ab05fafa 100644 --- a/collects/tests/racket/benchmarks/common/typed/wrapper.rkt +++ b/collects/tests/racket/benchmarks/common/typed/wrapper.rkt @@ -1,7 +1,7 @@ #lang racket/base (provide (rename-out (module-begin #%module-begin))) (require (prefix-in ts: typed/racket/base) - (for-syntax racket/base (prefix-in r: typed-scheme/typed-reader)) + (for-syntax racket/base (prefix-in r: typed-racket/typed-reader)) racket/include typed/racket/base racket/file) (define-syntax (module-begin stx) diff --git a/collects/tests/racket/benchmarks/shootout/typed/wrapper.rkt b/collects/tests/racket/benchmarks/shootout/typed/wrapper.rkt index 28347c36c1..10f3fa5b9d 100644 --- a/collects/tests/racket/benchmarks/shootout/typed/wrapper.rkt +++ b/collects/tests/racket/benchmarks/shootout/typed/wrapper.rkt @@ -1,7 +1,7 @@ #lang racket/base (provide (rename-out (module-begin #%module-begin))) (require (prefix-in ts: typed/scheme/base) - (for-syntax racket/base (prefix-in r: typed-scheme/typed-reader)) + (for-syntax racket/base (prefix-in r: typed-racket/typed-reader)) racket/include typed/scheme/base) (define-syntax (module-begin stx) diff --git a/collects/tests/run-automated-tests.rkt b/collects/tests/run-automated-tests.rkt index 3b8abb9419..5615e8eacb 100755 --- a/collects/tests/run-automated-tests.rkt +++ b/collects/tests/run-automated-tests.rkt @@ -33,7 +33,7 @@ ;; that expect to get (lib "racket/init") as a result. #:additional-modules '((lib "racket/init"))) ;; (test "planet/lang.rkt") - (test "typed-scheme/nightly-run.rkt" #:timeout 25) + (test "typed-racket/nightly-run.rkt" #:timeout 25) (test "match/plt-match-tests.rkt") ;; (test "stepper/automatic-tests.rkt" #:additional-modules (scheme/base)) (test "lazy/main.rkt") diff --git a/collects/tests/typed-scheme/fail/all-bad-syntax.rkt b/collects/tests/typed-racket/fail/all-bad-syntax.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/all-bad-syntax.rkt rename to collects/tests/typed-racket/fail/all-bad-syntax.rkt diff --git a/collects/tests/typed-scheme/fail/ann-map-funcs.rkt b/collects/tests/typed-racket/fail/ann-map-funcs.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/ann-map-funcs.rkt rename to collects/tests/typed-racket/fail/ann-map-funcs.rkt diff --git a/collects/tests/typed-scheme/fail/apply-dots.rkt b/collects/tests/typed-racket/fail/apply-dots.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/apply-dots.rkt rename to collects/tests/typed-racket/fail/apply-dots.rkt diff --git a/collects/tests/typed-scheme/fail/back-and-forth.rkt b/collects/tests/typed-racket/fail/back-and-forth.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/back-and-forth.rkt rename to collects/tests/typed-racket/fail/back-and-forth.rkt diff --git a/collects/tests/typed-scheme/fail/bad-ann.rkt b/collects/tests/typed-racket/fail/bad-ann.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/bad-ann.rkt rename to collects/tests/typed-racket/fail/bad-ann.rkt diff --git a/collects/tests/typed-scheme/fail/bad-any.rkt b/collects/tests/typed-racket/fail/bad-any.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/bad-any.rkt rename to collects/tests/typed-racket/fail/bad-any.rkt diff --git a/collects/tests/typed-scheme/fail/bad-first.rkt b/collects/tests/typed-racket/fail/bad-first.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/bad-first.rkt rename to collects/tests/typed-racket/fail/bad-first.rkt diff --git a/collects/tests/typed-scheme/fail/bad-hash-ref.rkt b/collects/tests/typed-racket/fail/bad-hash-ref.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/bad-hash-ref.rkt rename to collects/tests/typed-racket/fail/bad-hash-ref.rkt diff --git a/collects/tests/typed-scheme/fail/bad-map-poly.rkt b/collects/tests/typed-racket/fail/bad-map-poly.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/bad-map-poly.rkt rename to collects/tests/typed-racket/fail/bad-map-poly.rkt diff --git a/collects/tests/typed-scheme/fail/bad-type-app.rkt b/collects/tests/typed-racket/fail/bad-type-app.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/bad-type-app.rkt rename to collects/tests/typed-racket/fail/bad-type-app.rkt diff --git a/collects/tests/typed-scheme/fail/box-fail.rkt b/collects/tests/typed-racket/fail/box-fail.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/box-fail.rkt rename to collects/tests/typed-racket/fail/box-fail.rkt diff --git a/collects/tests/typed-scheme/fail/check-expect-fail.rkt b/collects/tests/typed-racket/fail/check-expect-fail.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/check-expect-fail.rkt rename to collects/tests/typed-racket/fail/check-expect-fail.rkt diff --git a/collects/tests/typed-scheme/fail/cl-bug.rkt b/collects/tests/typed-racket/fail/cl-bug.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/cl-bug.rkt rename to collects/tests/typed-racket/fail/cl-bug.rkt diff --git a/collects/tests/typed-scheme/fail/cnt-err1.rkt b/collects/tests/typed-racket/fail/cnt-err1.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/cnt-err1.rkt rename to collects/tests/typed-racket/fail/cnt-err1.rkt diff --git a/collects/tests/typed-scheme/fail/cnt-struct-err.rkt b/collects/tests/typed-racket/fail/cnt-struct-err.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/cnt-struct-err.rkt rename to collects/tests/typed-racket/fail/cnt-struct-err.rkt diff --git a/collects/tests/typed-scheme/fail/dead-substruct.rkt b/collects/tests/typed-racket/fail/dead-substruct.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/dead-substruct.rkt rename to collects/tests/typed-racket/fail/dead-substruct.rkt diff --git a/collects/tests/typed-scheme/fail/dup-ann.rkt b/collects/tests/typed-racket/fail/dup-ann.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/dup-ann.rkt rename to collects/tests/typed-racket/fail/dup-ann.rkt diff --git a/collects/tests/typed-scheme/fail/duplicate-ann.rkt b/collects/tests/typed-racket/fail/duplicate-ann.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/duplicate-ann.rkt rename to collects/tests/typed-racket/fail/duplicate-ann.rkt diff --git a/collects/tests/typed-scheme/fail/formal-len-mismatches.rkt b/collects/tests/typed-racket/fail/formal-len-mismatches.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/formal-len-mismatches.rkt rename to collects/tests/typed-racket/fail/formal-len-mismatches.rkt diff --git a/collects/tests/typed-scheme/fail/gadt.rkt b/collects/tests/typed-racket/fail/gadt.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/gadt.rkt rename to collects/tests/typed-racket/fail/gadt.rkt diff --git a/collects/tests/typed-scheme/fail/ht-infer.rkt b/collects/tests/typed-racket/fail/ht-infer.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/ht-infer.rkt rename to collects/tests/typed-racket/fail/ht-infer.rkt diff --git a/collects/tests/typed-scheme/fail/inexact-complex.rkt b/collects/tests/typed-racket/fail/inexact-complex.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/inexact-complex.rkt rename to collects/tests/typed-racket/fail/inexact-complex.rkt diff --git a/collects/tests/typed-scheme/fail/infer-dots.rkt b/collects/tests/typed-racket/fail/infer-dots.rkt similarity index 86% rename from collects/tests/typed-scheme/fail/infer-dots.rkt rename to collects/tests/typed-racket/fail/infer-dots.rkt index b7ae503a39..04af012527 100644 --- a/collects/tests/typed-scheme/fail/infer-dots.rkt +++ b/collects/tests/typed-racket/fail/infer-dots.rkt @@ -1,6 +1,6 @@ #lang typed-scheme -(require typed-scheme/base-env/extra-procs) +(require typed-racket/base-env/extra-procs) (map + (list 1 2 3) (list 10 20 30) (list 'a 'b 'c)) diff --git a/collects/tests/typed-scheme/fail/internal-ann.rkt b/collects/tests/typed-racket/fail/internal-ann.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/internal-ann.rkt rename to collects/tests/typed-racket/fail/internal-ann.rkt diff --git a/collects/tests/typed-scheme/fail/log-not-complex.rkt b/collects/tests/typed-racket/fail/log-not-complex.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/log-not-complex.rkt rename to collects/tests/typed-racket/fail/log-not-complex.rkt diff --git a/collects/tests/typed-scheme/fail/nested-tvars.rkt b/collects/tests/typed-racket/fail/nested-tvars.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/nested-tvars.rkt rename to collects/tests/typed-racket/fail/nested-tvars.rkt diff --git a/collects/tests/typed-scheme/fail/nonnegative-float.rkt b/collects/tests/typed-racket/fail/nonnegative-float.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/nonnegative-float.rkt rename to collects/tests/typed-racket/fail/nonnegative-float.rkt diff --git a/collects/tests/typed-scheme/fail/poly-expect-error.rkt b/collects/tests/typed-racket/fail/poly-expect-error.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/poly-expect-error.rkt rename to collects/tests/typed-racket/fail/poly-expect-error.rkt diff --git a/collects/tests/typed-scheme/fail/port-to-list.rkt b/collects/tests/typed-racket/fail/port-to-list.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/port-to-list.rkt rename to collects/tests/typed-racket/fail/port-to-list.rkt diff --git a/collects/tests/typed-scheme/fail/pr10350.rkt b/collects/tests/typed-racket/fail/pr10350.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/pr10350.rkt rename to collects/tests/typed-racket/fail/pr10350.rkt diff --git a/collects/tests/typed-scheme/fail/pr10594.rkt b/collects/tests/typed-racket/fail/pr10594.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/pr10594.rkt rename to collects/tests/typed-racket/fail/pr10594.rkt diff --git a/collects/tests/typed-scheme/fail/pr11560.rkt b/collects/tests/typed-racket/fail/pr11560.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/pr11560.rkt rename to collects/tests/typed-racket/fail/pr11560.rkt diff --git a/collects/tests/typed-scheme/fail/pr11686.rkt b/collects/tests/typed-racket/fail/pr11686.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/pr11686.rkt rename to collects/tests/typed-racket/fail/pr11686.rkt diff --git a/collects/tests/typed-scheme/fail/pr11772.rkt b/collects/tests/typed-racket/fail/pr11772.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/pr11772.rkt rename to collects/tests/typed-racket/fail/pr11772.rkt diff --git a/collects/tests/typed-scheme/fail/pr11998.rkt b/collects/tests/typed-racket/fail/pr11998.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/pr11998.rkt rename to collects/tests/typed-racket/fail/pr11998.rkt diff --git a/collects/tests/typed-scheme/fail/require-typed-missing.rkt b/collects/tests/typed-racket/fail/require-typed-missing.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/require-typed-missing.rkt rename to collects/tests/typed-racket/fail/require-typed-missing.rkt diff --git a/collects/tests/typed-scheme/fail/require-typed-wrong.rkt b/collects/tests/typed-racket/fail/require-typed-wrong.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/require-typed-wrong.rkt rename to collects/tests/typed-racket/fail/require-typed-wrong.rkt diff --git a/collects/tests/typed-scheme/fail/reverse-special.rkt b/collects/tests/typed-racket/fail/reverse-special.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/reverse-special.rkt rename to collects/tests/typed-racket/fail/reverse-special.rkt diff --git a/collects/tests/typed-scheme/fail/rts-prov.rkt b/collects/tests/typed-racket/fail/rts-prov.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/rts-prov.rkt rename to collects/tests/typed-racket/fail/rts-prov.rkt diff --git a/collects/tests/typed-scheme/fail/safe-letrec.rkt b/collects/tests/typed-racket/fail/safe-letrec.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/safe-letrec.rkt rename to collects/tests/typed-racket/fail/safe-letrec.rkt diff --git a/collects/tests/typed-scheme/fail/set-struct.rkt b/collects/tests/typed-racket/fail/set-struct.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/set-struct.rkt rename to collects/tests/typed-racket/fail/set-struct.rkt diff --git a/collects/tests/typed-scheme/fail/set-tests.rkt b/collects/tests/typed-racket/fail/set-tests.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/set-tests.rkt rename to collects/tests/typed-racket/fail/set-tests.rkt diff --git a/collects/tests/typed-scheme/fail/sort.rkt b/collects/tests/typed-racket/fail/sort.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/sort.rkt rename to collects/tests/typed-racket/fail/sort.rkt diff --git a/collects/tests/typed-scheme/fail/struct-provide.rkt b/collects/tests/typed-racket/fail/struct-provide.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/struct-provide.rkt rename to collects/tests/typed-racket/fail/struct-provide.rkt diff --git a/collects/tests/typed-scheme/fail/subtype-int-err.rkt b/collects/tests/typed-racket/fail/subtype-int-err.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/subtype-int-err.rkt rename to collects/tests/typed-racket/fail/subtype-int-err.rkt diff --git a/collects/tests/typed-scheme/fail/tc-error-format.rkt b/collects/tests/typed-racket/fail/tc-error-format.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/tc-error-format.rkt rename to collects/tests/typed-racket/fail/tc-error-format.rkt diff --git a/collects/tests/typed-scheme/fail/too-many-errors.rkt b/collects/tests/typed-racket/fail/too-many-errors.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/too-many-errors.rkt rename to collects/tests/typed-racket/fail/too-many-errors.rkt diff --git a/collects/tests/typed-scheme/fail/unbound-non-reg.rkt b/collects/tests/typed-racket/fail/unbound-non-reg.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/unbound-non-reg.rkt rename to collects/tests/typed-racket/fail/unbound-non-reg.rkt diff --git a/collects/tests/typed-scheme/fail/unbound-type.rkt b/collects/tests/typed-racket/fail/unbound-type.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/unbound-type.rkt rename to collects/tests/typed-racket/fail/unbound-type.rkt diff --git a/collects/tests/typed-scheme/fail/undefined.rkt b/collects/tests/typed-racket/fail/undefined.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/undefined.rkt rename to collects/tests/typed-racket/fail/undefined.rkt diff --git a/collects/tests/typed-scheme/fail/unsafe-struct-parent.rkt b/collects/tests/typed-racket/fail/unsafe-struct-parent.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/unsafe-struct-parent.rkt rename to collects/tests/typed-racket/fail/unsafe-struct-parent.rkt diff --git a/collects/tests/typed-scheme/fail/unsafe-struct.rkt b/collects/tests/typed-racket/fail/unsafe-struct.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/unsafe-struct.rkt rename to collects/tests/typed-racket/fail/unsafe-struct.rkt diff --git a/collects/tests/typed-scheme/fail/untyped-srfi1.rkt b/collects/tests/typed-racket/fail/untyped-srfi1.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/untyped-srfi1.rkt rename to collects/tests/typed-racket/fail/untyped-srfi1.rkt diff --git a/collects/tests/typed-scheme/fail/values-dots.rkt b/collects/tests/typed-racket/fail/values-dots.rkt similarity index 93% rename from collects/tests/typed-scheme/fail/values-dots.rkt rename to collects/tests/typed-racket/fail/values-dots.rkt index f3166c16aa..9ef8a78abf 100644 --- a/collects/tests/typed-scheme/fail/values-dots.rkt +++ b/collects/tests/typed-racket/fail/values-dots.rkt @@ -2,7 +2,7 @@ (exn-pred 10) #lang typed-scheme -(require typed-scheme/base-env/extra-procs) +(require typed-racket/base-env/extra-procs) (: map-with-funcs (All (b ...) ((b ... b -> b) ... b -> (b ... b -> (values b ... b))))) (define (map-with-funcs . fs) diff --git a/collects/tests/typed-scheme/fail/with-asserts.rkt b/collects/tests/typed-racket/fail/with-asserts.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/with-asserts.rkt rename to collects/tests/typed-racket/fail/with-asserts.rkt diff --git a/collects/tests/typed-scheme/fail/with-asserts2.rkt b/collects/tests/typed-racket/fail/with-asserts2.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/with-asserts2.rkt rename to collects/tests/typed-racket/fail/with-asserts2.rkt diff --git a/collects/tests/typed-scheme/fail/with-asserts3.rkt b/collects/tests/typed-racket/fail/with-asserts3.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/with-asserts3.rkt rename to collects/tests/typed-racket/fail/with-asserts3.rkt diff --git a/collects/tests/typed-scheme/fail/with-type-bug.rkt b/collects/tests/typed-racket/fail/with-type-bug.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/with-type-bug.rkt rename to collects/tests/typed-racket/fail/with-type-bug.rkt diff --git a/collects/tests/typed-scheme/fail/with-type1.rkt b/collects/tests/typed-racket/fail/with-type1.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/with-type1.rkt rename to collects/tests/typed-racket/fail/with-type1.rkt diff --git a/collects/tests/typed-scheme/fail/with-type2.rkt b/collects/tests/typed-racket/fail/with-type2.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/with-type2.rkt rename to collects/tests/typed-racket/fail/with-type2.rkt diff --git a/collects/tests/typed-scheme/fail/with-type3.rkt b/collects/tests/typed-racket/fail/with-type3.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/with-type3.rkt rename to collects/tests/typed-racket/fail/with-type3.rkt diff --git a/collects/tests/typed-scheme/info.rkt b/collects/tests/typed-racket/info.rkt similarity index 100% rename from collects/tests/typed-scheme/info.rkt rename to collects/tests/typed-racket/info.rkt diff --git a/collects/tests/typed-scheme/main.rkt b/collects/tests/typed-racket/main.rkt similarity index 100% rename from collects/tests/typed-scheme/main.rkt rename to collects/tests/typed-racket/main.rkt diff --git a/collects/tests/typed-scheme/nightly-run.rkt b/collects/tests/typed-racket/nightly-run.rkt similarity index 100% rename from collects/tests/typed-scheme/nightly-run.rkt rename to collects/tests/typed-racket/nightly-run.rkt diff --git a/collects/tests/typed-scheme/optimizer/missed-optimizations/all-real.rkt b/collects/tests/typed-racket/optimizer/missed-optimizations/all-real.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/missed-optimizations/all-real.rkt rename to collects/tests/typed-racket/optimizer/missed-optimizations/all-real.rkt diff --git a/collects/tests/typed-scheme/optimizer/missed-optimizations/fixnum.rkt b/collects/tests/typed-racket/optimizer/missed-optimizations/fixnum.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/missed-optimizations/fixnum.rkt rename to collects/tests/typed-racket/optimizer/missed-optimizations/fixnum.rkt diff --git a/collects/tests/typed-scheme/optimizer/missed-optimizations/multi-file1.rkt b/collects/tests/typed-racket/optimizer/missed-optimizations/multi-file1.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/missed-optimizations/multi-file1.rkt rename to collects/tests/typed-racket/optimizer/missed-optimizations/multi-file1.rkt diff --git a/collects/tests/typed-scheme/optimizer/missed-optimizations/multi-file2.rkt b/collects/tests/typed-racket/optimizer/missed-optimizations/multi-file2.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/missed-optimizations/multi-file2.rkt rename to collects/tests/typed-racket/optimizer/missed-optimizations/multi-file2.rkt diff --git a/collects/tests/typed-scheme/optimizer/missed-optimizations/multiple-irritants.rkt b/collects/tests/typed-racket/optimizer/missed-optimizations/multiple-irritants.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/missed-optimizations/multiple-irritants.rkt rename to collects/tests/typed-racket/optimizer/missed-optimizations/multiple-irritants.rkt diff --git a/collects/tests/typed-scheme/optimizer/missed-optimizations/nested-same-kind.rkt b/collects/tests/typed-racket/optimizer/missed-optimizations/nested-same-kind.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/missed-optimizations/nested-same-kind.rkt rename to collects/tests/typed-racket/optimizer/missed-optimizations/nested-same-kind.rkt diff --git a/collects/tests/typed-scheme/optimizer/missed-optimizations/pair.rkt b/collects/tests/typed-racket/optimizer/missed-optimizations/pair.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/missed-optimizations/pair.rkt rename to collects/tests/typed-racket/optimizer/missed-optimizations/pair.rkt diff --git a/collects/tests/typed-scheme/optimizer/missed-optimizations/precision-loss.rkt b/collects/tests/typed-racket/optimizer/missed-optimizations/precision-loss.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/missed-optimizations/precision-loss.rkt rename to collects/tests/typed-racket/optimizer/missed-optimizations/precision-loss.rkt diff --git a/collects/tests/typed-scheme/optimizer/missed-optimizations/real-in-float-expr.rkt b/collects/tests/typed-racket/optimizer/missed-optimizations/real-in-float-expr.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/missed-optimizations/real-in-float-expr.rkt rename to collects/tests/typed-racket/optimizer/missed-optimizations/real-in-float-expr.rkt diff --git a/collects/tests/typed-scheme/optimizer/missed-optimizations/unary-float.rkt b/collects/tests/typed-racket/optimizer/missed-optimizations/unary-float.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/missed-optimizations/unary-float.rkt rename to collects/tests/typed-racket/optimizer/missed-optimizations/unary-float.rkt diff --git a/collects/tests/typed-scheme/optimizer/missed-optimizations/unexpected-complex.rkt b/collects/tests/typed-racket/optimizer/missed-optimizations/unexpected-complex.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/missed-optimizations/unexpected-complex.rkt rename to collects/tests/typed-racket/optimizer/missed-optimizations/unexpected-complex.rkt diff --git a/collects/tests/typed-scheme/optimizer/run.rkt b/collects/tests/typed-racket/optimizer/run.rkt similarity index 98% rename from collects/tests/typed-scheme/optimizer/run.rkt rename to collects/tests/typed-racket/optimizer/run.rkt index d9060929b0..208b011392 100644 --- a/collects/tests/typed-scheme/optimizer/run.rkt +++ b/collects/tests/typed-racket/optimizer/run.rkt @@ -1,7 +1,7 @@ #lang racket (require racket/runtime-path rackunit rackunit/text-ui - typed-scheme/optimizer/logging) + typed-racket/optimizer/logging) (provide optimization-tests missed-optimization-tests test-opt test-missed-optimization test-file? diff --git a/collects/tests/typed-scheme/optimizer/tests/add1.rkt b/collects/tests/typed-racket/optimizer/tests/add1.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/add1.rkt rename to collects/tests/typed-racket/optimizer/tests/add1.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/apply-plus.rkt b/collects/tests/typed-racket/optimizer/tests/apply-plus.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/apply-plus.rkt rename to collects/tests/typed-racket/optimizer/tests/apply-plus.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/begin-float.rkt b/collects/tests/typed-racket/optimizer/tests/begin-float.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/begin-float.rkt rename to collects/tests/typed-racket/optimizer/tests/begin-float.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/binary-fixnum.rkt b/collects/tests/typed-racket/optimizer/tests/binary-fixnum.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/binary-fixnum.rkt rename to collects/tests/typed-racket/optimizer/tests/binary-fixnum.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/binary-nonzero-fixnum.rkt b/collects/tests/typed-racket/optimizer/tests/binary-nonzero-fixnum.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/binary-nonzero-fixnum.rkt rename to collects/tests/typed-racket/optimizer/tests/binary-nonzero-fixnum.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/bounds-check.rkt b/collects/tests/typed-racket/optimizer/tests/bounds-check.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/bounds-check.rkt rename to collects/tests/typed-racket/optimizer/tests/bounds-check.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/box.rkt b/collects/tests/typed-racket/optimizer/tests/box.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/box.rkt rename to collects/tests/typed-racket/optimizer/tests/box.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/cross-module-struct.rkt b/collects/tests/typed-racket/optimizer/tests/cross-module-struct.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/cross-module-struct.rkt rename to collects/tests/typed-racket/optimizer/tests/cross-module-struct.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/cross-module-struct2.rkt b/collects/tests/typed-racket/optimizer/tests/cross-module-struct2.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/cross-module-struct2.rkt rename to collects/tests/typed-racket/optimizer/tests/cross-module-struct2.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/dead-else.rkt b/collects/tests/typed-racket/optimizer/tests/dead-else.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/dead-else.rkt rename to collects/tests/typed-racket/optimizer/tests/dead-else.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/dead-substructs.rkt b/collects/tests/typed-racket/optimizer/tests/dead-substructs.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/dead-substructs.rkt rename to collects/tests/typed-racket/optimizer/tests/dead-substructs.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/dead-then.rkt b/collects/tests/typed-racket/optimizer/tests/dead-then.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/dead-then.rkt rename to collects/tests/typed-racket/optimizer/tests/dead-then.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/define-begin-float.rkt b/collects/tests/typed-racket/optimizer/tests/define-begin-float.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/define-begin-float.rkt rename to collects/tests/typed-racket/optimizer/tests/define-begin-float.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/define-call-float.rkt b/collects/tests/typed-racket/optimizer/tests/define-call-float.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/define-call-float.rkt rename to collects/tests/typed-racket/optimizer/tests/define-call-float.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/define-float.rkt b/collects/tests/typed-racket/optimizer/tests/define-float.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/define-float.rkt rename to collects/tests/typed-racket/optimizer/tests/define-float.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/define-pair.rkt b/collects/tests/typed-racket/optimizer/tests/define-pair.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/define-pair.rkt rename to collects/tests/typed-racket/optimizer/tests/define-pair.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/derived-pair.rkt b/collects/tests/typed-racket/optimizer/tests/derived-pair.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/derived-pair.rkt rename to collects/tests/typed-racket/optimizer/tests/derived-pair.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/derived-pair2.rkt b/collects/tests/typed-racket/optimizer/tests/derived-pair2.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/derived-pair2.rkt rename to collects/tests/typed-racket/optimizer/tests/derived-pair2.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/derived-pair3.rkt b/collects/tests/typed-racket/optimizer/tests/derived-pair3.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/derived-pair3.rkt rename to collects/tests/typed-racket/optimizer/tests/derived-pair3.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/different-langs.rkt b/collects/tests/typed-racket/optimizer/tests/different-langs.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/different-langs.rkt rename to collects/tests/typed-racket/optimizer/tests/different-langs.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/double-float.rkt b/collects/tests/typed-racket/optimizer/tests/double-float.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/double-float.rkt rename to collects/tests/typed-racket/optimizer/tests/double-float.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/exact-inexact.rkt b/collects/tests/typed-racket/optimizer/tests/exact-inexact.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/exact-inexact.rkt rename to collects/tests/typed-racket/optimizer/tests/exact-inexact.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/false-huh-dead-code.rkt b/collects/tests/typed-racket/optimizer/tests/false-huh-dead-code.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/false-huh-dead-code.rkt rename to collects/tests/typed-racket/optimizer/tests/false-huh-dead-code.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/fixnum-bounded-expr.rkt b/collects/tests/typed-racket/optimizer/tests/fixnum-bounded-expr.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/fixnum-bounded-expr.rkt rename to collects/tests/typed-racket/optimizer/tests/fixnum-bounded-expr.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/fixnum-comparison.rkt b/collects/tests/typed-racket/optimizer/tests/fixnum-comparison.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/fixnum-comparison.rkt rename to collects/tests/typed-racket/optimizer/tests/fixnum-comparison.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/float-comp.rkt b/collects/tests/typed-racket/optimizer/tests/float-comp.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/float-comp.rkt rename to collects/tests/typed-racket/optimizer/tests/float-comp.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-conjugate-top.rkt b/collects/tests/typed-racket/optimizer/tests/float-complex-conjugate-top.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/float-complex-conjugate-top.rkt rename to collects/tests/typed-racket/optimizer/tests/float-complex-conjugate-top.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-conjugate.rkt b/collects/tests/typed-racket/optimizer/tests/float-complex-conjugate.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/float-complex-conjugate.rkt rename to collects/tests/typed-racket/optimizer/tests/float-complex-conjugate.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-div.rkt b/collects/tests/typed-racket/optimizer/tests/float-complex-div.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/float-complex-div.rkt rename to collects/tests/typed-racket/optimizer/tests/float-complex-div.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-fixnum.rkt b/collects/tests/typed-racket/optimizer/tests/float-complex-fixnum.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/float-complex-fixnum.rkt rename to collects/tests/typed-racket/optimizer/tests/float-complex-fixnum.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-float-div.rkt b/collects/tests/typed-racket/optimizer/tests/float-complex-float-div.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/float-complex-float-div.rkt rename to collects/tests/typed-racket/optimizer/tests/float-complex-float-div.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-float-mul.rkt b/collects/tests/typed-racket/optimizer/tests/float-complex-float-mul.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/float-complex-float-mul.rkt rename to collects/tests/typed-racket/optimizer/tests/float-complex-float-mul.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-float-small.rkt b/collects/tests/typed-racket/optimizer/tests/float-complex-float-small.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/float-complex-float-small.rkt rename to collects/tests/typed-racket/optimizer/tests/float-complex-float-small.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-float.rkt b/collects/tests/typed-racket/optimizer/tests/float-complex-float.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/float-complex-float.rkt rename to collects/tests/typed-racket/optimizer/tests/float-complex-float.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-i.rkt b/collects/tests/typed-racket/optimizer/tests/float-complex-i.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/float-complex-i.rkt rename to collects/tests/typed-racket/optimizer/tests/float-complex-i.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-integer.rkt b/collects/tests/typed-racket/optimizer/tests/float-complex-integer.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/float-complex-integer.rkt rename to collects/tests/typed-racket/optimizer/tests/float-complex-integer.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-mult.rkt b/collects/tests/typed-racket/optimizer/tests/float-complex-mult.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/float-complex-mult.rkt rename to collects/tests/typed-racket/optimizer/tests/float-complex-mult.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-parts.rkt b/collects/tests/typed-racket/optimizer/tests/float-complex-parts.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/float-complex-parts.rkt rename to collects/tests/typed-racket/optimizer/tests/float-complex-parts.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-parts2.rkt b/collects/tests/typed-racket/optimizer/tests/float-complex-parts2.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/float-complex-parts2.rkt rename to collects/tests/typed-racket/optimizer/tests/float-complex-parts2.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-parts3.rkt b/collects/tests/typed-racket/optimizer/tests/float-complex-parts3.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/float-complex-parts3.rkt rename to collects/tests/typed-racket/optimizer/tests/float-complex-parts3.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-sin.rkt b/collects/tests/typed-racket/optimizer/tests/float-complex-sin.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/float-complex-sin.rkt rename to collects/tests/typed-racket/optimizer/tests/float-complex-sin.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex.rkt b/collects/tests/typed-racket/optimizer/tests/float-complex.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/float-complex.rkt rename to collects/tests/typed-racket/optimizer/tests/float-complex.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/float-fun.rkt b/collects/tests/typed-racket/optimizer/tests/float-fun.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/float-fun.rkt rename to collects/tests/typed-racket/optimizer/tests/float-fun.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/float-promotion.rkt b/collects/tests/typed-racket/optimizer/tests/float-promotion.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/float-promotion.rkt rename to collects/tests/typed-racket/optimizer/tests/float-promotion.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/float-real.rkt b/collects/tests/typed-racket/optimizer/tests/float-real.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/float-real.rkt rename to collects/tests/typed-racket/optimizer/tests/float-real.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/flvector-length.rkt b/collects/tests/typed-racket/optimizer/tests/flvector-length.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/flvector-length.rkt rename to collects/tests/typed-racket/optimizer/tests/flvector-length.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/fx-fl.rkt b/collects/tests/typed-racket/optimizer/tests/fx-fl.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/fx-fl.rkt rename to collects/tests/typed-racket/optimizer/tests/fx-fl.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/in-bytes.rkt b/collects/tests/typed-racket/optimizer/tests/in-bytes.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/in-bytes.rkt rename to collects/tests/typed-racket/optimizer/tests/in-bytes.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/in-list.rkt b/collects/tests/typed-racket/optimizer/tests/in-list.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/in-list.rkt rename to collects/tests/typed-racket/optimizer/tests/in-list.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/in-string.rkt b/collects/tests/typed-racket/optimizer/tests/in-string.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/in-string.rkt rename to collects/tests/typed-racket/optimizer/tests/in-string.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/in-vector.rkt b/collects/tests/typed-racket/optimizer/tests/in-vector.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/in-vector.rkt rename to collects/tests/typed-racket/optimizer/tests/in-vector.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/invalid-binary-nonzero-fixnum.rkt b/collects/tests/typed-racket/optimizer/tests/invalid-binary-nonzero-fixnum.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/invalid-binary-nonzero-fixnum.rkt rename to collects/tests/typed-racket/optimizer/tests/invalid-binary-nonzero-fixnum.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/invalid-derived-pair.rkt b/collects/tests/typed-racket/optimizer/tests/invalid-derived-pair.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/invalid-derived-pair.rkt rename to collects/tests/typed-racket/optimizer/tests/invalid-derived-pair.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/invalid-exact-inexact.rkt b/collects/tests/typed-racket/optimizer/tests/invalid-exact-inexact.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/invalid-exact-inexact.rkt rename to collects/tests/typed-racket/optimizer/tests/invalid-exact-inexact.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/invalid-float-comp.rkt b/collects/tests/typed-racket/optimizer/tests/invalid-float-comp.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/invalid-float-comp.rkt rename to collects/tests/typed-racket/optimizer/tests/invalid-float-comp.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/invalid-float-promotion.rkt b/collects/tests/typed-racket/optimizer/tests/invalid-float-promotion.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/invalid-float-promotion.rkt rename to collects/tests/typed-racket/optimizer/tests/invalid-float-promotion.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/invalid-inexact-complex-parts.rkt b/collects/tests/typed-racket/optimizer/tests/invalid-inexact-complex-parts.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/invalid-inexact-complex-parts.rkt rename to collects/tests/typed-racket/optimizer/tests/invalid-inexact-complex-parts.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/invalid-log-complex.rkt b/collects/tests/typed-racket/optimizer/tests/invalid-log-complex.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/invalid-log-complex.rkt rename to collects/tests/typed-racket/optimizer/tests/invalid-log-complex.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/invalid-make-flrectangular.rkt b/collects/tests/typed-racket/optimizer/tests/invalid-make-flrectangular.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/invalid-make-flrectangular.rkt rename to collects/tests/typed-racket/optimizer/tests/invalid-make-flrectangular.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/invalid-make-polar.rkt b/collects/tests/typed-racket/optimizer/tests/invalid-make-polar.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/invalid-make-polar.rkt rename to collects/tests/typed-racket/optimizer/tests/invalid-make-polar.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/invalid-mpair.rkt b/collects/tests/typed-racket/optimizer/tests/invalid-mpair.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/invalid-mpair.rkt rename to collects/tests/typed-racket/optimizer/tests/invalid-mpair.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/invalid-sqrt.rkt b/collects/tests/typed-racket/optimizer/tests/invalid-sqrt.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/invalid-sqrt.rkt rename to collects/tests/typed-racket/optimizer/tests/invalid-sqrt.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/invalid-unboxed-let.rkt b/collects/tests/typed-racket/optimizer/tests/invalid-unboxed-let.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/invalid-unboxed-let.rkt rename to collects/tests/typed-racket/optimizer/tests/invalid-unboxed-let.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/invalid-unboxed-let2.rkt b/collects/tests/typed-racket/optimizer/tests/invalid-unboxed-let2.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/invalid-unboxed-let2.rkt rename to collects/tests/typed-racket/optimizer/tests/invalid-unboxed-let2.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/invalid-vector-ref.rkt b/collects/tests/typed-racket/optimizer/tests/invalid-vector-ref.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/invalid-vector-ref.rkt rename to collects/tests/typed-racket/optimizer/tests/invalid-vector-ref.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/invalid-vector-set.rkt b/collects/tests/typed-racket/optimizer/tests/invalid-vector-set.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/invalid-vector-set.rkt rename to collects/tests/typed-racket/optimizer/tests/invalid-vector-set.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/known-length-lists.rkt b/collects/tests/typed-racket/optimizer/tests/known-length-lists.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/known-length-lists.rkt rename to collects/tests/typed-racket/optimizer/tests/known-length-lists.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/known-vector-length.rkt b/collects/tests/typed-racket/optimizer/tests/known-vector-length.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/known-vector-length.rkt rename to collects/tests/typed-racket/optimizer/tests/known-vector-length.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/let-float.rkt b/collects/tests/typed-racket/optimizer/tests/let-float.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/let-float.rkt rename to collects/tests/typed-racket/optimizer/tests/let-float.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/let-rhs.rkt b/collects/tests/typed-racket/optimizer/tests/let-rhs.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/let-rhs.rkt rename to collects/tests/typed-racket/optimizer/tests/let-rhs.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/literal-int.rkt b/collects/tests/typed-racket/optimizer/tests/literal-int.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/literal-int.rkt rename to collects/tests/typed-racket/optimizer/tests/literal-int.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/magnitude.rkt b/collects/tests/typed-racket/optimizer/tests/magnitude.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/magnitude.rkt rename to collects/tests/typed-racket/optimizer/tests/magnitude.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/make-flrectangular.rkt b/collects/tests/typed-racket/optimizer/tests/make-flrectangular.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/make-flrectangular.rkt rename to collects/tests/typed-racket/optimizer/tests/make-flrectangular.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/make-polar.rkt b/collects/tests/typed-racket/optimizer/tests/make-polar.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/make-polar.rkt rename to collects/tests/typed-racket/optimizer/tests/make-polar.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/maybe-exact-complex.rkt b/collects/tests/typed-racket/optimizer/tests/maybe-exact-complex.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/maybe-exact-complex.rkt rename to collects/tests/typed-racket/optimizer/tests/maybe-exact-complex.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/module-path.rkt b/collects/tests/typed-racket/optimizer/tests/module-path.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/module-path.rkt rename to collects/tests/typed-racket/optimizer/tests/module-path.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/mpair.rkt b/collects/tests/typed-racket/optimizer/tests/mpair.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/mpair.rkt rename to collects/tests/typed-racket/optimizer/tests/mpair.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/n-ary-float-complex.rkt b/collects/tests/typed-racket/optimizer/tests/n-ary-float-complex.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/n-ary-float-complex.rkt rename to collects/tests/typed-racket/optimizer/tests/n-ary-float-complex.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/n-ary-float.rkt b/collects/tests/typed-racket/optimizer/tests/n-ary-float.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/n-ary-float.rkt rename to collects/tests/typed-racket/optimizer/tests/n-ary-float.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/nested-float-complex.rkt b/collects/tests/typed-racket/optimizer/tests/nested-float-complex.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/nested-float-complex.rkt rename to collects/tests/typed-racket/optimizer/tests/nested-float-complex.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/nested-float.rkt b/collects/tests/typed-racket/optimizer/tests/nested-float.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/nested-float.rkt rename to collects/tests/typed-racket/optimizer/tests/nested-float.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/nested-float2.rkt b/collects/tests/typed-racket/optimizer/tests/nested-float2.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/nested-float2.rkt rename to collects/tests/typed-racket/optimizer/tests/nested-float2.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/nested-let-loop.rkt b/collects/tests/typed-racket/optimizer/tests/nested-let-loop.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/nested-let-loop.rkt rename to collects/tests/typed-racket/optimizer/tests/nested-let-loop.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/nested-pair1.rkt b/collects/tests/typed-racket/optimizer/tests/nested-pair1.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/nested-pair1.rkt rename to collects/tests/typed-racket/optimizer/tests/nested-pair1.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/nested-pair2.rkt b/collects/tests/typed-racket/optimizer/tests/nested-pair2.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/nested-pair2.rkt rename to collects/tests/typed-racket/optimizer/tests/nested-pair2.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/nested-unboxed-let.rkt b/collects/tests/typed-racket/optimizer/tests/nested-unboxed-let.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/nested-unboxed-let.rkt rename to collects/tests/typed-racket/optimizer/tests/nested-unboxed-let.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/one-arg-arith.rkt b/collects/tests/typed-racket/optimizer/tests/one-arg-arith.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/one-arg-arith.rkt rename to collects/tests/typed-racket/optimizer/tests/one-arg-arith.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/pair-fun.rkt b/collects/tests/typed-racket/optimizer/tests/pair-fun.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/pair-fun.rkt rename to collects/tests/typed-racket/optimizer/tests/pair-fun.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/pair-known-length-list.rkt b/collects/tests/typed-racket/optimizer/tests/pair-known-length-list.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/pair-known-length-list.rkt rename to collects/tests/typed-racket/optimizer/tests/pair-known-length-list.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/quote.rkt b/collects/tests/typed-racket/optimizer/tests/quote.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/quote.rkt rename to collects/tests/typed-racket/optimizer/tests/quote.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/rational-literal.rkt b/collects/tests/typed-racket/optimizer/tests/rational-literal.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/rational-literal.rkt rename to collects/tests/typed-racket/optimizer/tests/rational-literal.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/real-part-loop.rkt b/collects/tests/typed-racket/optimizer/tests/real-part-loop.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/real-part-loop.rkt rename to collects/tests/typed-racket/optimizer/tests/real-part-loop.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/silent-dead-branch.rkt b/collects/tests/typed-racket/optimizer/tests/silent-dead-branch.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/silent-dead-branch.rkt rename to collects/tests/typed-racket/optimizer/tests/silent-dead-branch.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/simple-float.rkt b/collects/tests/typed-racket/optimizer/tests/simple-float.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/simple-float.rkt rename to collects/tests/typed-racket/optimizer/tests/simple-float.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/simple-pair.rkt b/collects/tests/typed-racket/optimizer/tests/simple-pair.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/simple-pair.rkt rename to collects/tests/typed-racket/optimizer/tests/simple-pair.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/sqrt-segfault.rkt b/collects/tests/typed-racket/optimizer/tests/sqrt-segfault.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/sqrt-segfault.rkt rename to collects/tests/typed-racket/optimizer/tests/sqrt-segfault.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/sqrt.rkt b/collects/tests/typed-racket/optimizer/tests/sqrt.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/sqrt.rkt rename to collects/tests/typed-racket/optimizer/tests/sqrt.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/string-length.rkt b/collects/tests/typed-racket/optimizer/tests/string-length.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/string-length.rkt rename to collects/tests/typed-racket/optimizer/tests/string-length.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/structs.rkt b/collects/tests/typed-racket/optimizer/tests/structs.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/structs.rkt rename to collects/tests/typed-racket/optimizer/tests/structs.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/unary-fixnum-nested.rkt b/collects/tests/typed-racket/optimizer/tests/unary-fixnum-nested.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/unary-fixnum-nested.rkt rename to collects/tests/typed-racket/optimizer/tests/unary-fixnum-nested.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/unary-fixnum.rkt b/collects/tests/typed-racket/optimizer/tests/unary-fixnum.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/unary-fixnum.rkt rename to collects/tests/typed-racket/optimizer/tests/unary-fixnum.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/unary-float.rkt b/collects/tests/typed-racket/optimizer/tests/unary-float.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/unary-float.rkt rename to collects/tests/typed-racket/optimizer/tests/unary-float.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-for.rkt b/collects/tests/typed-racket/optimizer/tests/unboxed-for.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/unboxed-for.rkt rename to collects/tests/typed-racket/optimizer/tests/unboxed-for.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions1.rkt b/collects/tests/typed-racket/optimizer/tests/unboxed-let-functions1.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions1.rkt rename to collects/tests/typed-racket/optimizer/tests/unboxed-let-functions1.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions2.rkt b/collects/tests/typed-racket/optimizer/tests/unboxed-let-functions2.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions2.rkt rename to collects/tests/typed-racket/optimizer/tests/unboxed-let-functions2.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions3.rkt b/collects/tests/typed-racket/optimizer/tests/unboxed-let-functions3.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions3.rkt rename to collects/tests/typed-racket/optimizer/tests/unboxed-let-functions3.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions4.rkt b/collects/tests/typed-racket/optimizer/tests/unboxed-let-functions4.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions4.rkt rename to collects/tests/typed-racket/optimizer/tests/unboxed-let-functions4.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions5.rkt b/collects/tests/typed-racket/optimizer/tests/unboxed-let-functions5.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions5.rkt rename to collects/tests/typed-racket/optimizer/tests/unboxed-let-functions5.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions6.rkt b/collects/tests/typed-racket/optimizer/tests/unboxed-let-functions6.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions6.rkt rename to collects/tests/typed-racket/optimizer/tests/unboxed-let-functions6.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions7.rkt b/collects/tests/typed-racket/optimizer/tests/unboxed-let-functions7.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions7.rkt rename to collects/tests/typed-racket/optimizer/tests/unboxed-let-functions7.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions8.rkt b/collects/tests/typed-racket/optimizer/tests/unboxed-let-functions8.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions8.rkt rename to collects/tests/typed-racket/optimizer/tests/unboxed-let-functions8.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-let.rkt b/collects/tests/typed-racket/optimizer/tests/unboxed-let.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/unboxed-let.rkt rename to collects/tests/typed-racket/optimizer/tests/unboxed-let.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-let2.rkt b/collects/tests/typed-racket/optimizer/tests/unboxed-let2.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/unboxed-let2.rkt rename to collects/tests/typed-racket/optimizer/tests/unboxed-let2.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-let3.rkt b/collects/tests/typed-racket/optimizer/tests/unboxed-let3.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/unboxed-let3.rkt rename to collects/tests/typed-racket/optimizer/tests/unboxed-let3.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-letrec-syntaxes+values.rkt b/collects/tests/typed-racket/optimizer/tests/unboxed-letrec-syntaxes+values.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/unboxed-letrec-syntaxes+values.rkt rename to collects/tests/typed-racket/optimizer/tests/unboxed-letrec-syntaxes+values.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-letrec.rkt b/collects/tests/typed-racket/optimizer/tests/unboxed-letrec.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/unboxed-letrec.rkt rename to collects/tests/typed-racket/optimizer/tests/unboxed-letrec.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-make-rectangular.rkt b/collects/tests/typed-racket/optimizer/tests/unboxed-make-rectangular.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/unboxed-make-rectangular.rkt rename to collects/tests/typed-racket/optimizer/tests/unboxed-make-rectangular.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/vector-length-nested.rkt b/collects/tests/typed-racket/optimizer/tests/vector-length-nested.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/vector-length-nested.rkt rename to collects/tests/typed-racket/optimizer/tests/vector-length-nested.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/vector-length.rkt b/collects/tests/typed-racket/optimizer/tests/vector-length.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/vector-length.rkt rename to collects/tests/typed-racket/optimizer/tests/vector-length.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/vector-ref-set-ref.rkt b/collects/tests/typed-racket/optimizer/tests/vector-ref-set-ref.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/vector-ref-set-ref.rkt rename to collects/tests/typed-racket/optimizer/tests/vector-ref-set-ref.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/vector-ref.rkt b/collects/tests/typed-racket/optimizer/tests/vector-ref.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/vector-ref.rkt rename to collects/tests/typed-racket/optimizer/tests/vector-ref.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/vector-ref2.rkt b/collects/tests/typed-racket/optimizer/tests/vector-ref2.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/vector-ref2.rkt rename to collects/tests/typed-racket/optimizer/tests/vector-ref2.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/vector-set-quote.rkt b/collects/tests/typed-racket/optimizer/tests/vector-set-quote.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/vector-set-quote.rkt rename to collects/tests/typed-racket/optimizer/tests/vector-set-quote.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/vector-set.rkt b/collects/tests/typed-racket/optimizer/tests/vector-set.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/vector-set.rkt rename to collects/tests/typed-racket/optimizer/tests/vector-set.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/vector-set2.rkt b/collects/tests/typed-racket/optimizer/tests/vector-set2.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/vector-set2.rkt rename to collects/tests/typed-racket/optimizer/tests/vector-set2.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/vector-sum.rkt b/collects/tests/typed-racket/optimizer/tests/vector-sum.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/vector-sum.rkt rename to collects/tests/typed-racket/optimizer/tests/vector-sum.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/with-type.rkt b/collects/tests/typed-racket/optimizer/tests/with-type.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/with-type.rkt rename to collects/tests/typed-racket/optimizer/tests/with-type.rkt diff --git a/collects/tests/typed-scheme/optimizer/tests/zero.rkt b/collects/tests/typed-racket/optimizer/tests/zero.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/tests/zero.rkt rename to collects/tests/typed-racket/optimizer/tests/zero.rkt diff --git a/collects/tests/typed-scheme/optimizer/transform.rkt b/collects/tests/typed-racket/optimizer/transform.rkt similarity index 100% rename from collects/tests/typed-scheme/optimizer/transform.rkt rename to collects/tests/typed-racket/optimizer/transform.rkt diff --git a/collects/tests/typed-scheme/run.rkt b/collects/tests/typed-racket/run.rkt similarity index 100% rename from collects/tests/typed-scheme/run.rkt rename to collects/tests/typed-racket/run.rkt diff --git a/collects/tests/typed-scheme/succeed/andmap.rkt b/collects/tests/typed-racket/succeed/andmap.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/andmap.rkt rename to collects/tests/typed-racket/succeed/andmap.rkt diff --git a/collects/tests/typed-scheme/succeed/annotation-test.rkt b/collects/tests/typed-racket/succeed/annotation-test.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/annotation-test.rkt rename to collects/tests/typed-racket/succeed/annotation-test.rkt diff --git a/collects/tests/typed-scheme/succeed/apply-append.rkt b/collects/tests/typed-racket/succeed/apply-append.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/apply-append.rkt rename to collects/tests/typed-racket/succeed/apply-append.rkt diff --git a/collects/tests/typed-scheme/succeed/apply-dots-list.rkt b/collects/tests/typed-racket/succeed/apply-dots-list.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/apply-dots-list.rkt rename to collects/tests/typed-racket/succeed/apply-dots-list.rkt diff --git a/collects/tests/typed-scheme/succeed/apply-dots.rkt b/collects/tests/typed-racket/succeed/apply-dots.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/apply-dots.rkt rename to collects/tests/typed-racket/succeed/apply-dots.rkt diff --git a/collects/tests/typed-scheme/succeed/area.rkt b/collects/tests/typed-racket/succeed/area.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/area.rkt rename to collects/tests/typed-racket/succeed/area.rkt diff --git a/collects/tests/typed-scheme/succeed/at-exp.rkt b/collects/tests/typed-racket/succeed/at-exp.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/at-exp.rkt rename to collects/tests/typed-racket/succeed/at-exp.rkt diff --git a/collects/tests/typed-scheme/succeed/bad-map-infer.rkt b/collects/tests/typed-racket/succeed/bad-map-infer.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/bad-map-infer.rkt rename to collects/tests/typed-racket/succeed/bad-map-infer.rkt diff --git a/collects/tests/typed-scheme/succeed/barland.rkt b/collects/tests/typed-racket/succeed/barland.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/barland.rkt rename to collects/tests/typed-racket/succeed/barland.rkt diff --git a/collects/tests/typed-scheme/succeed/basic-tests.rkt b/collects/tests/typed-racket/succeed/basic-tests.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/basic-tests.rkt rename to collects/tests/typed-racket/succeed/basic-tests.rkt diff --git a/collects/tests/typed-scheme/succeed/batched-queue.scm b/collects/tests/typed-racket/succeed/batched-queue.scm similarity index 100% rename from collects/tests/typed-scheme/succeed/batched-queue.scm rename to collects/tests/typed-racket/succeed/batched-queue.scm diff --git a/collects/tests/typed-scheme/succeed/begin0-error.rkt b/collects/tests/typed-racket/succeed/begin0-error.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/begin0-error.rkt rename to collects/tests/typed-racket/succeed/begin0-error.rkt diff --git a/collects/tests/typed-scheme/succeed/box-num.rkt b/collects/tests/typed-racket/succeed/box-num.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/box-num.rkt rename to collects/tests/typed-racket/succeed/box-num.rkt diff --git a/collects/tests/typed-scheme/succeed/broken-let-syntax.rkt b/collects/tests/typed-racket/succeed/broken-let-syntax.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/broken-let-syntax.rkt rename to collects/tests/typed-racket/succeed/broken-let-syntax.rkt diff --git a/collects/tests/typed-scheme/succeed/check-expect.rkt b/collects/tests/typed-racket/succeed/check-expect.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/check-expect.rkt rename to collects/tests/typed-racket/succeed/check-expect.rkt diff --git a/collects/tests/typed-scheme/succeed/check-within.rkt b/collects/tests/typed-racket/succeed/check-within.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/check-within.rkt rename to collects/tests/typed-racket/succeed/check-within.rkt diff --git a/collects/tests/typed-scheme/succeed/cl-bug.rkt b/collects/tests/typed-racket/succeed/cl-bug.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/cl-bug.rkt rename to collects/tests/typed-racket/succeed/cl-bug.rkt diff --git a/collects/tests/typed-scheme/succeed/cl-tests.rkt b/collects/tests/typed-racket/succeed/cl-tests.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/cl-tests.rkt rename to collects/tests/typed-racket/succeed/cl-tests.rkt diff --git a/collects/tests/typed-scheme/succeed/cl.rkt b/collects/tests/typed-racket/succeed/cl.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/cl.rkt rename to collects/tests/typed-racket/succeed/cl.rkt diff --git a/collects/tests/typed-scheme/succeed/cmdline.rkt b/collects/tests/typed-racket/succeed/cmdline.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/cmdline.rkt rename to collects/tests/typed-racket/succeed/cmdline.rkt diff --git a/collects/tests/typed-scheme/succeed/cps.rkt b/collects/tests/typed-racket/succeed/cps.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/cps.rkt rename to collects/tests/typed-racket/succeed/cps.rkt diff --git a/collects/tests/typed-scheme/succeed/datum-to-syntax.rkt b/collects/tests/typed-racket/succeed/datum-to-syntax.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/datum-to-syntax.rkt rename to collects/tests/typed-racket/succeed/datum-to-syntax.rkt diff --git a/collects/tests/typed-scheme/succeed/def-pred.rkt b/collects/tests/typed-racket/succeed/def-pred.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/def-pred.rkt rename to collects/tests/typed-racket/succeed/def-pred.rkt diff --git a/collects/tests/typed-scheme/succeed/do.rkt b/collects/tests/typed-racket/succeed/do.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/do.rkt rename to collects/tests/typed-racket/succeed/do.rkt diff --git a/collects/tests/typed-scheme/succeed/dot-intro.rkt b/collects/tests/typed-racket/succeed/dot-intro.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/dot-intro.rkt rename to collects/tests/typed-racket/succeed/dot-intro.rkt diff --git a/collects/tests/typed-scheme/succeed/dotted-identity.rkt b/collects/tests/typed-racket/succeed/dotted-identity.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/dotted-identity.rkt rename to collects/tests/typed-racket/succeed/dotted-identity.rkt diff --git a/collects/tests/typed-scheme/succeed/dotted-identity2.rkt b/collects/tests/typed-racket/succeed/dotted-identity2.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/dotted-identity2.rkt rename to collects/tests/typed-racket/succeed/dotted-identity2.rkt diff --git a/collects/tests/typed-scheme/succeed/empty-or.rkt b/collects/tests/typed-racket/succeed/empty-or.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/empty-or.rkt rename to collects/tests/typed-racket/succeed/empty-or.rkt diff --git a/collects/tests/typed-scheme/succeed/ephemerons.rkt b/collects/tests/typed-racket/succeed/ephemerons.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/ephemerons.rkt rename to collects/tests/typed-racket/succeed/ephemerons.rkt diff --git a/collects/tests/typed-scheme/succeed/even-odd.rkt b/collects/tests/typed-racket/succeed/even-odd.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/even-odd.rkt rename to collects/tests/typed-racket/succeed/even-odd.rkt diff --git a/collects/tests/typed-scheme/succeed/exceptions.rkt b/collects/tests/typed-racket/succeed/exceptions.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/exceptions.rkt rename to collects/tests/typed-racket/succeed/exceptions.rkt diff --git a/collects/tests/typed-scheme/succeed/fix.rkt b/collects/tests/typed-racket/succeed/fix.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/fix.rkt rename to collects/tests/typed-racket/succeed/fix.rkt diff --git a/collects/tests/typed-scheme/succeed/fixnum.rkt b/collects/tests/typed-racket/succeed/fixnum.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/fixnum.rkt rename to collects/tests/typed-racket/succeed/fixnum.rkt diff --git a/collects/tests/typed-scheme/succeed/float-internal-err.rkt b/collects/tests/typed-racket/succeed/float-internal-err.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/float-internal-err.rkt rename to collects/tests/typed-racket/succeed/float-internal-err.rkt diff --git a/collects/tests/typed-scheme/succeed/flonum.rkt b/collects/tests/typed-racket/succeed/flonum.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/flonum.rkt rename to collects/tests/typed-racket/succeed/flonum.rkt diff --git a/collects/tests/typed-scheme/succeed/flvector.rkt b/collects/tests/typed-racket/succeed/flvector.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/flvector.rkt rename to collects/tests/typed-racket/succeed/flvector.rkt diff --git a/collects/tests/typed-scheme/succeed/fold-left-inst.rkt b/collects/tests/typed-racket/succeed/fold-left-inst.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/fold-left-inst.rkt rename to collects/tests/typed-racket/succeed/fold-left-inst.rkt diff --git a/collects/tests/typed-scheme/succeed/fold-left.rkt b/collects/tests/typed-racket/succeed/fold-left.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/fold-left.rkt rename to collects/tests/typed-racket/succeed/fold-left.rkt diff --git a/collects/tests/typed-scheme/succeed/foldo.rkt b/collects/tests/typed-racket/succeed/foldo.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/foldo.rkt rename to collects/tests/typed-racket/succeed/foldo.rkt diff --git a/collects/tests/typed-scheme/succeed/foo.scm b/collects/tests/typed-racket/succeed/foo.scm similarity index 100% rename from collects/tests/typed-scheme/succeed/foo.scm rename to collects/tests/typed-racket/succeed/foo.scm diff --git a/collects/tests/typed-scheme/succeed/for-ann.rkt b/collects/tests/typed-racket/succeed/for-ann.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/for-ann.rkt rename to collects/tests/typed-racket/succeed/for-ann.rkt diff --git a/collects/tests/typed-scheme/succeed/for-in-range.rkt b/collects/tests/typed-racket/succeed/for-in-range.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/for-in-range.rkt rename to collects/tests/typed-racket/succeed/for-in-range.rkt diff --git a/collects/tests/typed-scheme/succeed/for-list.rkt b/collects/tests/typed-racket/succeed/for-list.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/for-list.rkt rename to collects/tests/typed-racket/succeed/for-list.rkt diff --git a/collects/tests/typed-scheme/succeed/for-lists.rkt b/collects/tests/typed-racket/succeed/for-lists.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/for-lists.rkt rename to collects/tests/typed-racket/succeed/for-lists.rkt diff --git a/collects/tests/typed-scheme/succeed/for-no-anns.rkt b/collects/tests/typed-racket/succeed/for-no-anns.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/for-no-anns.rkt rename to collects/tests/typed-racket/succeed/for-no-anns.rkt diff --git a/collects/tests/typed-scheme/succeed/for-no-body-anns.rkt b/collects/tests/typed-racket/succeed/for-no-body-anns.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/for-no-body-anns.rkt rename to collects/tests/typed-racket/succeed/for-no-body-anns.rkt diff --git a/collects/tests/typed-scheme/succeed/for-over-hash.rkt b/collects/tests/typed-racket/succeed/for-over-hash.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/for-over-hash.rkt rename to collects/tests/typed-racket/succeed/for-over-hash.rkt diff --git a/collects/tests/typed-scheme/succeed/for-seq.rkt b/collects/tests/typed-racket/succeed/for-seq.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/for-seq.rkt rename to collects/tests/typed-racket/succeed/for-seq.rkt diff --git a/collects/tests/typed-scheme/succeed/for.rkt b/collects/tests/typed-racket/succeed/for.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/for.rkt rename to collects/tests/typed-racket/succeed/for.rkt diff --git a/collects/tests/typed-scheme/succeed/force-delay.rkt b/collects/tests/typed-racket/succeed/force-delay.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/force-delay.rkt rename to collects/tests/typed-racket/succeed/force-delay.rkt diff --git a/collects/tests/typed-scheme/succeed/function.rkt b/collects/tests/typed-racket/succeed/function.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/function.rkt rename to collects/tests/typed-racket/succeed/function.rkt diff --git a/collects/tests/typed-scheme/succeed/fx-filter.rkt b/collects/tests/typed-racket/succeed/fx-filter.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/fx-filter.rkt rename to collects/tests/typed-racket/succeed/fx-filter.rkt diff --git a/collects/tests/typed-scheme/succeed/generalize-vectors.rkt b/collects/tests/typed-racket/succeed/generalize-vectors.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/generalize-vectors.rkt rename to collects/tests/typed-racket/succeed/generalize-vectors.rkt diff --git a/collects/tests/typed-scheme/succeed/hari-vector-bug.rkt b/collects/tests/typed-racket/succeed/hari-vector-bug.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/hari-vector-bug.rkt rename to collects/tests/typed-racket/succeed/hari-vector-bug.rkt diff --git a/collects/tests/typed-scheme/succeed/hash-ref.rkt b/collects/tests/typed-racket/succeed/hash-ref.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/hash-ref.rkt rename to collects/tests/typed-racket/succeed/hash-ref.rkt diff --git a/collects/tests/typed-scheme/succeed/het-vec.rkt b/collects/tests/typed-racket/succeed/het-vec.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/het-vec.rkt rename to collects/tests/typed-racket/succeed/het-vec.rkt diff --git a/collects/tests/typed-scheme/succeed/het-vec2.rkt b/collects/tests/typed-racket/succeed/het-vec2.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/het-vec2.rkt rename to collects/tests/typed-racket/succeed/het-vec2.rkt diff --git a/collects/tests/typed-scheme/succeed/ho-box.rkt b/collects/tests/typed-racket/succeed/ho-box.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/ho-box.rkt rename to collects/tests/typed-racket/succeed/ho-box.rkt diff --git a/collects/tests/typed-scheme/succeed/hw01.scm b/collects/tests/typed-racket/succeed/hw01.scm similarity index 100% rename from collects/tests/typed-scheme/succeed/hw01.scm rename to collects/tests/typed-racket/succeed/hw01.scm diff --git a/collects/tests/typed-scheme/succeed/icfp-examples.rkt b/collects/tests/typed-racket/succeed/icfp-examples.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/icfp-examples.rkt rename to collects/tests/typed-racket/succeed/icfp-examples.rkt diff --git a/collects/tests/typed-scheme/succeed/if-splitting-test.rkt b/collects/tests/typed-racket/succeed/if-splitting-test.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/if-splitting-test.rkt rename to collects/tests/typed-racket/succeed/if-splitting-test.rkt diff --git a/collects/tests/typed-scheme/succeed/inexact-complex.rkt b/collects/tests/typed-racket/succeed/inexact-complex.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/inexact-complex.rkt rename to collects/tests/typed-racket/succeed/inexact-complex.rkt diff --git a/collects/tests/typed-scheme/succeed/infer-dots.rkt b/collects/tests/typed-racket/succeed/infer-dots.rkt similarity index 93% rename from collects/tests/typed-scheme/succeed/infer-dots.rkt rename to collects/tests/typed-racket/succeed/infer-dots.rkt index 69f766e5e3..d5a43c14e4 100644 --- a/collects/tests/typed-scheme/succeed/infer-dots.rkt +++ b/collects/tests/typed-racket/succeed/infer-dots.rkt @@ -1,6 +1,6 @@ #lang typed-scheme -(require typed-scheme/base-env/extra-procs) +(require typed-racket/base-env/extra-procs) (: f (Integer Integer -> Integer)) (define (f x y) (+ x y)) diff --git a/collects/tests/typed-scheme/succeed/infer-funargs.rkt b/collects/tests/typed-racket/succeed/infer-funargs.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/infer-funargs.rkt rename to collects/tests/typed-racket/succeed/infer-funargs.rkt diff --git a/collects/tests/typed-scheme/succeed/inst-dots.rkt b/collects/tests/typed-racket/succeed/inst-dots.rkt similarity index 69% rename from collects/tests/typed-scheme/succeed/inst-dots.rkt rename to collects/tests/typed-racket/succeed/inst-dots.rkt index 571c51f261..05d56c278e 100644 --- a/collects/tests/typed-scheme/succeed/inst-dots.rkt +++ b/collects/tests/typed-racket/succeed/inst-dots.rkt @@ -1,6 +1,6 @@ -#lang typed-scheme +#lang typed/racket -(require typed-scheme/base-env/extra-procs) +(require typed-racket/base-env/extra-procs) ((inst map Number Number Number Number Number Number Number) + diff --git a/collects/tests/typed-scheme/succeed/inst-expected.rkt b/collects/tests/typed-racket/succeed/inst-expected.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/inst-expected.rkt rename to collects/tests/typed-racket/succeed/inst-expected.rkt diff --git a/collects/tests/typed-scheme/succeed/int-def-colon.rkt b/collects/tests/typed-racket/succeed/int-def-colon.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/int-def-colon.rkt rename to collects/tests/typed-racket/succeed/int-def-colon.rkt diff --git a/collects/tests/typed-scheme/succeed/kw.rkt b/collects/tests/typed-racket/succeed/kw.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/kw.rkt rename to collects/tests/typed-racket/succeed/kw.rkt diff --git a/collects/tests/typed-scheme/succeed/leftist-heap.rkt b/collects/tests/typed-racket/succeed/leftist-heap.rkt similarity index 98% rename from collects/tests/typed-scheme/succeed/leftist-heap.rkt rename to collects/tests/typed-racket/succeed/leftist-heap.rkt index 4d87e6c386..3dd6f1aaf9 100644 --- a/collects/tests/typed-scheme/succeed/leftist-heap.rkt +++ b/collects/tests/typed-racket/succeed/leftist-heap.rkt @@ -23,10 +23,6 @@ ;; need rest args ;; didn't attempt generators -;#reader (planet "typed-reader.rkt" ("plt" "typed-scheme.plt")) -;(module leftist-heap (planet "typed-scheme.rkt" ("plt" "typed-scheme.plt" 3 0)) -;(module leftist-heap mzscheme - #lang typed-scheme (define-type-alias number Number) (define-type-alias boolean Boolean) diff --git a/collects/tests/typed-scheme/succeed/let-no-anns.rkt b/collects/tests/typed-racket/succeed/let-no-anns.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/let-no-anns.rkt rename to collects/tests/typed-racket/succeed/let-no-anns.rkt diff --git a/collects/tests/typed-scheme/succeed/let-values-tests.rkt b/collects/tests/typed-racket/succeed/let-values-tests.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/let-values-tests.rkt rename to collects/tests/typed-racket/succeed/let-values-tests.rkt diff --git a/collects/tests/typed-scheme/succeed/list-dots.rkt b/collects/tests/typed-racket/succeed/list-dots.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/list-dots.rkt rename to collects/tests/typed-racket/succeed/list-dots.rkt diff --git a/collects/tests/typed-scheme/succeed/list-ref-vec.rkt b/collects/tests/typed-racket/succeed/list-ref-vec.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/list-ref-vec.rkt rename to collects/tests/typed-racket/succeed/list-ref-vec.rkt diff --git a/collects/tests/typed-scheme/succeed/list-struct-sum.rkt b/collects/tests/typed-racket/succeed/list-struct-sum.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/list-struct-sum.rkt rename to collects/tests/typed-racket/succeed/list-struct-sum.rkt diff --git a/collects/tests/typed-scheme/succeed/little-schemer.rkt b/collects/tests/typed-racket/succeed/little-schemer.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/little-schemer.rkt rename to collects/tests/typed-racket/succeed/little-schemer.rkt diff --git a/collects/tests/typed-scheme/succeed/logic.rkt b/collects/tests/typed-racket/succeed/logic.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/logic.rkt rename to collects/tests/typed-racket/succeed/logic.rkt diff --git a/collects/tests/typed-scheme/succeed/lots-o-bugs.rkt b/collects/tests/typed-racket/succeed/lots-o-bugs.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/lots-o-bugs.rkt rename to collects/tests/typed-racket/succeed/lots-o-bugs.rkt diff --git a/collects/tests/typed-scheme/succeed/mandelbrot.rkt b/collects/tests/typed-racket/succeed/mandelbrot.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/mandelbrot.rkt rename to collects/tests/typed-racket/succeed/mandelbrot.rkt diff --git a/collects/tests/typed-scheme/succeed/manual-examples.rkt b/collects/tests/typed-racket/succeed/manual-examples.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/manual-examples.rkt rename to collects/tests/typed-racket/succeed/manual-examples.rkt diff --git a/collects/tests/typed-scheme/succeed/map-nonempty.rkt b/collects/tests/typed-racket/succeed/map-nonempty.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/map-nonempty.rkt rename to collects/tests/typed-racket/succeed/map-nonempty.rkt diff --git a/collects/tests/typed-scheme/succeed/map1.rkt b/collects/tests/typed-racket/succeed/map1.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/map1.rkt rename to collects/tests/typed-racket/succeed/map1.rkt diff --git a/collects/tests/typed-scheme/succeed/map2.rkt b/collects/tests/typed-racket/succeed/map2.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/map2.rkt rename to collects/tests/typed-racket/succeed/map2.rkt diff --git a/collects/tests/typed-scheme/succeed/match-dots.rkt b/collects/tests/typed-racket/succeed/match-dots.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/match-dots.rkt rename to collects/tests/typed-racket/succeed/match-dots.rkt diff --git a/collects/tests/typed-scheme/succeed/match-dots2.rkt b/collects/tests/typed-racket/succeed/match-dots2.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/match-dots2.rkt rename to collects/tests/typed-racket/succeed/match-dots2.rkt diff --git a/collects/tests/typed-scheme/succeed/match-expander-problem.rkt b/collects/tests/typed-racket/succeed/match-expander-problem.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/match-expander-problem.rkt rename to collects/tests/typed-racket/succeed/match-expander-problem.rkt diff --git a/collects/tests/typed-scheme/succeed/match-tests.rkt b/collects/tests/typed-racket/succeed/match-tests.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/match-tests.rkt rename to collects/tests/typed-racket/succeed/match-tests.rkt diff --git a/collects/tests/typed-scheme/succeed/match.rkt b/collects/tests/typed-racket/succeed/match.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/match.rkt rename to collects/tests/typed-racket/succeed/match.rkt diff --git a/collects/tests/typed-scheme/succeed/member-pred.rkt b/collects/tests/typed-racket/succeed/member-pred.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/member-pred.rkt rename to collects/tests/typed-racket/succeed/member-pred.rkt diff --git a/collects/tests/typed-scheme/succeed/metrics.rkt b/collects/tests/typed-racket/succeed/metrics.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/metrics.rkt rename to collects/tests/typed-racket/succeed/metrics.rkt diff --git a/collects/tests/typed-scheme/succeed/module-lang.rkt b/collects/tests/typed-racket/succeed/module-lang.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/module-lang.rkt rename to collects/tests/typed-racket/succeed/module-lang.rkt diff --git a/collects/tests/typed-scheme/succeed/mpair.rkt b/collects/tests/typed-racket/succeed/mpair.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/mpair.rkt rename to collects/tests/typed-racket/succeed/mpair.rkt diff --git a/collects/tests/typed-scheme/succeed/mu-rec.rkt b/collects/tests/typed-racket/succeed/mu-rec.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/mu-rec.rkt rename to collects/tests/typed-racket/succeed/mu-rec.rkt diff --git a/collects/tests/typed-scheme/succeed/multi-arr-parse.rkt b/collects/tests/typed-racket/succeed/multi-arr-parse.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/multi-arr-parse.rkt rename to collects/tests/typed-racket/succeed/multi-arr-parse.rkt diff --git a/collects/tests/typed-scheme/succeed/mutable-poly-struct.rkt b/collects/tests/typed-racket/succeed/mutable-poly-struct.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/mutable-poly-struct.rkt rename to collects/tests/typed-racket/succeed/mutable-poly-struct.rkt diff --git a/collects/tests/typed-scheme/succeed/mutable-struct-pred.rkt b/collects/tests/typed-racket/succeed/mutable-struct-pred.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/mutable-struct-pred.rkt rename to collects/tests/typed-racket/succeed/mutable-struct-pred.rkt diff --git a/collects/tests/typed-scheme/succeed/nested-poly.rkt b/collects/tests/typed-racket/succeed/nested-poly.rkt similarity index 91% rename from collects/tests/typed-scheme/succeed/nested-poly.rkt rename to collects/tests/typed-racket/succeed/nested-poly.rkt index 18d3e48a29..27620d07c8 100644 --- a/collects/tests/typed-scheme/succeed/nested-poly.rkt +++ b/collects/tests/typed-racket/succeed/nested-poly.rkt @@ -1,6 +1,6 @@ #lang typed-scheme -(require typed-scheme/base-env/extra-procs) +(require typed-racket/base-env/extra-procs) (: f (All (A ...) (All (B ...) (A ... A -> Integer)))) diff --git a/collects/tests/typed-scheme/succeed/new-metrics.rkt b/collects/tests/typed-racket/succeed/new-metrics.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/new-metrics.rkt rename to collects/tests/typed-racket/succeed/new-metrics.rkt diff --git a/collects/tests/typed-scheme/succeed/no-bound-fl.rkt b/collects/tests/typed-racket/succeed/no-bound-fl.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/no-bound-fl.rkt rename to collects/tests/typed-racket/succeed/no-bound-fl.rkt diff --git a/collects/tests/typed-scheme/succeed/nonnegative-float.rkt b/collects/tests/typed-racket/succeed/nonnegative-float.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/nonnegative-float.rkt rename to collects/tests/typed-racket/succeed/nonnegative-float.rkt diff --git a/collects/tests/typed-scheme/succeed/null-program.rkt b/collects/tests/typed-racket/succeed/null-program.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/null-program.rkt rename to collects/tests/typed-racket/succeed/null-program.rkt diff --git a/collects/tests/typed-scheme/succeed/opt-arg-test.rkt b/collects/tests/typed-racket/succeed/opt-arg-test.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/opt-arg-test.rkt rename to collects/tests/typed-racket/succeed/opt-arg-test.rkt diff --git a/collects/tests/typed-scheme/succeed/opt-lambda.rkt b/collects/tests/typed-racket/succeed/opt-lambda.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/opt-lambda.rkt rename to collects/tests/typed-racket/succeed/opt-lambda.rkt diff --git a/collects/tests/typed-scheme/succeed/optimize-simple.rkt b/collects/tests/typed-racket/succeed/optimize-simple.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/optimize-simple.rkt rename to collects/tests/typed-racket/succeed/optimize-simple.rkt diff --git a/collects/tests/typed-scheme/succeed/or-sym.rkt b/collects/tests/typed-racket/succeed/or-sym.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/or-sym.rkt rename to collects/tests/typed-racket/succeed/or-sym.rkt diff --git a/collects/tests/typed-scheme/succeed/overloading.rkt b/collects/tests/typed-racket/succeed/overloading.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/overloading.rkt rename to collects/tests/typed-racket/succeed/overloading.rkt diff --git a/collects/tests/typed-scheme/succeed/pair-test.rkt b/collects/tests/typed-racket/succeed/pair-test.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pair-test.rkt rename to collects/tests/typed-racket/succeed/pair-test.rkt diff --git a/collects/tests/typed-scheme/succeed/pair-test2.rkt b/collects/tests/typed-racket/succeed/pair-test2.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pair-test2.rkt rename to collects/tests/typed-racket/succeed/pair-test2.rkt diff --git a/collects/tests/typed-scheme/succeed/pair-test3.rkt b/collects/tests/typed-racket/succeed/pair-test3.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pair-test3.rkt rename to collects/tests/typed-racket/succeed/pair-test3.rkt diff --git a/collects/tests/typed-scheme/succeed/param.rkt b/collects/tests/typed-racket/succeed/param.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/param.rkt rename to collects/tests/typed-racket/succeed/param.rkt diff --git a/collects/tests/typed-scheme/succeed/parse-path.rkt b/collects/tests/typed-racket/succeed/parse-path.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/parse-path.rkt rename to collects/tests/typed-racket/succeed/parse-path.rkt diff --git a/collects/tests/typed-scheme/succeed/patch.rkt b/collects/tests/typed-racket/succeed/patch.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/patch.rkt rename to collects/tests/typed-racket/succeed/patch.rkt diff --git a/collects/tests/typed-scheme/succeed/paths.rkt b/collects/tests/typed-racket/succeed/paths.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/paths.rkt rename to collects/tests/typed-racket/succeed/paths.rkt diff --git a/collects/tests/typed-scheme/succeed/pathstrings.rkt b/collects/tests/typed-racket/succeed/pathstrings.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pathstrings.rkt rename to collects/tests/typed-racket/succeed/pathstrings.rkt diff --git a/collects/tests/typed-scheme/succeed/places-helper.rkt b/collects/tests/typed-racket/succeed/places-helper.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/places-helper.rkt rename to collects/tests/typed-racket/succeed/places-helper.rkt diff --git a/collects/tests/typed-scheme/succeed/places.rkt b/collects/tests/typed-racket/succeed/places.rkt similarity index 58% rename from collects/tests/typed-scheme/succeed/places.rkt rename to collects/tests/typed-racket/succeed/places.rkt index 9b0cdd98fd..11bd1d68f1 100644 --- a/collects/tests/typed-scheme/succeed/places.rkt +++ b/collects/tests/typed-racket/succeed/places.rkt @@ -4,16 +4,16 @@ (: p2 Place) (: p3 Place) -(define p (dynamic-place 'tests/typed-scheme/succeed/places-helper 'double-place)) +(define p (dynamic-place 'tests/typed-racket/succeed/places-helper 'double-place)) (place-channel-put/get p 10) (place-wait p) -(define p2 (dynamic-place 'tests/typed-scheme/succeed/places-helper 'double-place)) +(define p2 (dynamic-place 'tests/typed-racket/succeed/places-helper 'double-place)) (place-channel-put/get p2 -2+4i) (place-wait p2) -(define p3 (dynamic-place 'tests/typed-scheme/succeed/places-helper 'echo-place)) +(define p3 (dynamic-place 'tests/typed-racket/succeed/places-helper 'echo-place)) (place-channel-put/get p3 'echo-this) (place-wait p3) diff --git a/collects/tests/typed-scheme/succeed/poly-ret-ann.rkt b/collects/tests/typed-racket/succeed/poly-ret-ann.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/poly-ret-ann.rkt rename to collects/tests/typed-racket/succeed/poly-ret-ann.rkt diff --git a/collects/tests/typed-scheme/succeed/poly-struct-union.rkt b/collects/tests/typed-racket/succeed/poly-struct-union.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/poly-struct-union.rkt rename to collects/tests/typed-racket/succeed/poly-struct-union.rkt diff --git a/collects/tests/typed-scheme/succeed/poly-struct.rkt b/collects/tests/typed-racket/succeed/poly-struct.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/poly-struct.rkt rename to collects/tests/typed-racket/succeed/poly-struct.rkt diff --git a/collects/tests/typed-scheme/succeed/poly-subtype.rkt b/collects/tests/typed-racket/succeed/poly-subtype.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/poly-subtype.rkt rename to collects/tests/typed-racket/succeed/poly-subtype.rkt diff --git a/collects/tests/typed-scheme/succeed/poly-tests.rkt b/collects/tests/typed-racket/succeed/poly-tests.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/poly-tests.rkt rename to collects/tests/typed-racket/succeed/poly-tests.rkt diff --git a/collects/tests/typed-scheme/succeed/ports.rkt b/collects/tests/typed-racket/succeed/ports.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/ports.rkt rename to collects/tests/typed-racket/succeed/ports.rkt diff --git a/collects/tests/typed-scheme/succeed/pr10057.rkt b/collects/tests/typed-racket/succeed/pr10057.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr10057.rkt rename to collects/tests/typed-racket/succeed/pr10057.rkt diff --git a/collects/tests/typed-scheme/succeed/pr10318.rkt b/collects/tests/typed-racket/succeed/pr10318.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr10318.rkt rename to collects/tests/typed-racket/succeed/pr10318.rkt diff --git a/collects/tests/typed-scheme/succeed/pr10319.rkt b/collects/tests/typed-racket/succeed/pr10319.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr10319.rkt rename to collects/tests/typed-racket/succeed/pr10319.rkt diff --git a/collects/tests/typed-scheme/succeed/pr10342.rkt b/collects/tests/typed-racket/succeed/pr10342.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr10342.rkt rename to collects/tests/typed-racket/succeed/pr10342.rkt diff --git a/collects/tests/typed-scheme/succeed/pr10470.rkt b/collects/tests/typed-racket/succeed/pr10470.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr10470.rkt rename to collects/tests/typed-racket/succeed/pr10470.rkt diff --git a/collects/tests/typed-scheme/succeed/pr10552.rkt b/collects/tests/typed-racket/succeed/pr10552.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr10552.rkt rename to collects/tests/typed-racket/succeed/pr10552.rkt diff --git a/collects/tests/typed-scheme/succeed/pr10562.rkt b/collects/tests/typed-racket/succeed/pr10562.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr10562.rkt rename to collects/tests/typed-racket/succeed/pr10562.rkt diff --git a/collects/tests/typed-scheme/succeed/pr10718+10755.rkt b/collects/tests/typed-racket/succeed/pr10718+10755.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr10718+10755.rkt rename to collects/tests/typed-racket/succeed/pr10718+10755.rkt diff --git a/collects/tests/typed-scheme/succeed/pr10729.rkt b/collects/tests/typed-racket/succeed/pr10729.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr10729.rkt rename to collects/tests/typed-racket/succeed/pr10729.rkt diff --git a/collects/tests/typed-scheme/succeed/pr10937.rkt b/collects/tests/typed-racket/succeed/pr10937.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr10937.rkt rename to collects/tests/typed-racket/succeed/pr10937.rkt diff --git a/collects/tests/typed-scheme/succeed/pr10939.rkt b/collects/tests/typed-racket/succeed/pr10939.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr10939.rkt rename to collects/tests/typed-racket/succeed/pr10939.rkt diff --git a/collects/tests/typed-scheme/succeed/pr11171.rkt b/collects/tests/typed-racket/succeed/pr11171.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr11171.rkt rename to collects/tests/typed-racket/succeed/pr11171.rkt diff --git a/collects/tests/typed-scheme/succeed/pr11193.rkt b/collects/tests/typed-racket/succeed/pr11193.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr11193.rkt rename to collects/tests/typed-racket/succeed/pr11193.rkt diff --git a/collects/tests/typed-scheme/succeed/pr11194.rkt b/collects/tests/typed-racket/succeed/pr11194.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr11194.rkt rename to collects/tests/typed-racket/succeed/pr11194.rkt diff --git a/collects/tests/typed-scheme/succeed/pr11314.rkt b/collects/tests/typed-racket/succeed/pr11314.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr11314.rkt rename to collects/tests/typed-racket/succeed/pr11314.rkt diff --git a/collects/tests/typed-scheme/succeed/pr11425.rkt b/collects/tests/typed-racket/succeed/pr11425.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr11425.rkt rename to collects/tests/typed-racket/succeed/pr11425.rkt diff --git a/collects/tests/typed-scheme/succeed/pr11504.rkt b/collects/tests/typed-racket/succeed/pr11504.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr11504.rkt rename to collects/tests/typed-racket/succeed/pr11504.rkt diff --git a/collects/tests/typed-scheme/succeed/pr11509.rkt b/collects/tests/typed-racket/succeed/pr11509.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr11509.rkt rename to collects/tests/typed-racket/succeed/pr11509.rkt diff --git a/collects/tests/typed-scheme/succeed/pr11532.rkt b/collects/tests/typed-racket/succeed/pr11532.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr11532.rkt rename to collects/tests/typed-racket/succeed/pr11532.rkt diff --git a/collects/tests/typed-scheme/succeed/pr11545+11776.rkt b/collects/tests/typed-racket/succeed/pr11545+11776.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr11545+11776.rkt rename to collects/tests/typed-racket/succeed/pr11545+11776.rkt diff --git a/collects/tests/typed-scheme/succeed/pr11560.rkt b/collects/tests/typed-racket/succeed/pr11560.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr11560.rkt rename to collects/tests/typed-racket/succeed/pr11560.rkt diff --git a/collects/tests/typed-scheme/succeed/pr11578.rkt b/collects/tests/typed-racket/succeed/pr11578.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr11578.rkt rename to collects/tests/typed-racket/succeed/pr11578.rkt diff --git a/collects/tests/typed-scheme/succeed/pr11617.rkt b/collects/tests/typed-racket/succeed/pr11617.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr11617.rkt rename to collects/tests/typed-racket/succeed/pr11617.rkt diff --git a/collects/tests/typed-scheme/succeed/pr11686.rkt b/collects/tests/typed-racket/succeed/pr11686.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr11686.rkt rename to collects/tests/typed-racket/succeed/pr11686.rkt diff --git a/collects/tests/typed-scheme/succeed/pr11709.rkt b/collects/tests/typed-racket/succeed/pr11709.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr11709.rkt rename to collects/tests/typed-racket/succeed/pr11709.rkt diff --git a/collects/tests/typed-scheme/succeed/pr11728.rkt b/collects/tests/typed-racket/succeed/pr11728.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr11728.rkt rename to collects/tests/typed-racket/succeed/pr11728.rkt diff --git a/collects/tests/typed-scheme/succeed/pr11756.rkt b/collects/tests/typed-racket/succeed/pr11756.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr11756.rkt rename to collects/tests/typed-racket/succeed/pr11756.rkt diff --git a/collects/tests/typed-scheme/succeed/pr11859.rkt b/collects/tests/typed-racket/succeed/pr11859.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr11859.rkt rename to collects/tests/typed-racket/succeed/pr11859.rkt diff --git a/collects/tests/typed-scheme/succeed/pr11866.rkt b/collects/tests/typed-racket/succeed/pr11866.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr11866.rkt rename to collects/tests/typed-racket/succeed/pr11866.rkt diff --git a/collects/tests/typed-scheme/succeed/pr11887.rkt b/collects/tests/typed-racket/succeed/pr11887.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr11887.rkt rename to collects/tests/typed-racket/succeed/pr11887.rkt diff --git a/collects/tests/typed-scheme/succeed/pr11897.rkt b/collects/tests/typed-racket/succeed/pr11897.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr11897.rkt rename to collects/tests/typed-racket/succeed/pr11897.rkt diff --git a/collects/tests/typed-scheme/succeed/pr11912.rkt b/collects/tests/typed-racket/succeed/pr11912.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr11912.rkt rename to collects/tests/typed-racket/succeed/pr11912.rkt diff --git a/collects/tests/typed-scheme/succeed/pr9043.rkt b/collects/tests/typed-racket/succeed/pr9043.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr9043.rkt rename to collects/tests/typed-racket/succeed/pr9043.rkt diff --git a/collects/tests/typed-scheme/succeed/pr9046.rkt b/collects/tests/typed-racket/succeed/pr9046.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr9046.rkt rename to collects/tests/typed-racket/succeed/pr9046.rkt diff --git a/collects/tests/typed-scheme/succeed/pr9048.rkt b/collects/tests/typed-racket/succeed/pr9048.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr9048.rkt rename to collects/tests/typed-racket/succeed/pr9048.rkt diff --git a/collects/tests/typed-scheme/succeed/pr9053-2.rkt b/collects/tests/typed-racket/succeed/pr9053-2.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr9053-2.rkt rename to collects/tests/typed-racket/succeed/pr9053-2.rkt diff --git a/collects/tests/typed-scheme/succeed/pr9053.rkt b/collects/tests/typed-racket/succeed/pr9053.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr9053.rkt rename to collects/tests/typed-racket/succeed/pr9053.rkt diff --git a/collects/tests/typed-scheme/succeed/pr9054.rkt b/collects/tests/typed-racket/succeed/pr9054.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/pr9054.rkt rename to collects/tests/typed-racket/succeed/pr9054.rkt diff --git a/collects/tests/typed-scheme/succeed/priority-queue.scm b/collects/tests/typed-racket/succeed/priority-queue.scm similarity index 100% rename from collects/tests/typed-scheme/succeed/priority-queue.scm rename to collects/tests/typed-racket/succeed/priority-queue.scm diff --git a/collects/tests/typed-scheme/succeed/provide-case-rest.rkt b/collects/tests/typed-racket/succeed/provide-case-rest.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/provide-case-rest.rkt rename to collects/tests/typed-racket/succeed/provide-case-rest.rkt diff --git a/collects/tests/typed-scheme/succeed/provide-poly-struct.rkt b/collects/tests/typed-racket/succeed/provide-poly-struct.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/provide-poly-struct.rkt rename to collects/tests/typed-racket/succeed/provide-poly-struct.rkt diff --git a/collects/tests/typed-scheme/succeed/provide-sexp.rkt b/collects/tests/typed-racket/succeed/provide-sexp.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/provide-sexp.rkt rename to collects/tests/typed-racket/succeed/provide-sexp.rkt diff --git a/collects/tests/typed-scheme/succeed/provide-struct-untyped.rkt b/collects/tests/typed-racket/succeed/provide-struct-untyped.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/provide-struct-untyped.rkt rename to collects/tests/typed-racket/succeed/provide-struct-untyped.rkt diff --git a/collects/tests/typed-scheme/succeed/provide-struct.rkt b/collects/tests/typed-racket/succeed/provide-struct.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/provide-struct.rkt rename to collects/tests/typed-racket/succeed/provide-struct.rkt diff --git a/collects/tests/typed-scheme/succeed/provide-syntax.rkt b/collects/tests/typed-racket/succeed/provide-syntax.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/provide-syntax.rkt rename to collects/tests/typed-racket/succeed/provide-syntax.rkt diff --git a/collects/tests/typed-scheme/succeed/racket-struct.rkt b/collects/tests/typed-racket/succeed/racket-struct.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/racket-struct.rkt rename to collects/tests/typed-racket/succeed/racket-struct.rkt diff --git a/collects/tests/typed-scheme/succeed/rackunit.rkt b/collects/tests/typed-racket/succeed/rackunit.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/rackunit.rkt rename to collects/tests/typed-racket/succeed/rackunit.rkt diff --git a/collects/tests/typed-scheme/succeed/random-bits.rkt b/collects/tests/typed-racket/succeed/random-bits.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/random-bits.rkt rename to collects/tests/typed-racket/succeed/random-bits.rkt diff --git a/collects/tests/typed-scheme/succeed/rec-het-vec-infer.rkt b/collects/tests/typed-racket/succeed/rec-het-vec-infer.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/rec-het-vec-infer.rkt rename to collects/tests/typed-racket/succeed/rec-het-vec-infer.rkt diff --git a/collects/tests/typed-scheme/succeed/rec-types.rkt b/collects/tests/typed-racket/succeed/rec-types.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/rec-types.rkt rename to collects/tests/typed-racket/succeed/rec-types.rkt diff --git a/collects/tests/typed-scheme/succeed/refinement-even.rkt b/collects/tests/typed-racket/succeed/refinement-even.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/refinement-even.rkt rename to collects/tests/typed-racket/succeed/refinement-even.rkt diff --git a/collects/tests/typed-scheme/succeed/require-poly.rkt b/collects/tests/typed-racket/succeed/require-poly.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/require-poly.rkt rename to collects/tests/typed-racket/succeed/require-poly.rkt diff --git a/collects/tests/typed-scheme/succeed/require-procedure.rkt b/collects/tests/typed-racket/succeed/require-procedure.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/require-procedure.rkt rename to collects/tests/typed-racket/succeed/require-procedure.rkt diff --git a/collects/tests/typed-scheme/succeed/require-struct.rkt b/collects/tests/typed-racket/succeed/require-struct.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/require-struct.rkt rename to collects/tests/typed-racket/succeed/require-struct.rkt diff --git a/collects/tests/typed-scheme/succeed/require-substruct.rkt b/collects/tests/typed-racket/succeed/require-substruct.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/require-substruct.rkt rename to collects/tests/typed-racket/succeed/require-substruct.rkt diff --git a/collects/tests/typed-scheme/succeed/require-tests.rkt b/collects/tests/typed-racket/succeed/require-tests.rkt similarity index 84% rename from collects/tests/typed-scheme/succeed/require-tests.rkt rename to collects/tests/typed-racket/succeed/require-tests.rkt index 692278f503..1fa0bf15fe 100644 --- a/collects/tests/typed-scheme/succeed/require-tests.rkt +++ b/collects/tests/typed-racket/succeed/require-tests.rkt @@ -1,5 +1,5 @@ #lang scheme/load -#reader typed-scheme/typed-reader +#reader typed-racket/typed-reader (module bang-tests typed-scheme (define #{x : Number} 1) (provide x) diff --git a/collects/tests/typed-scheme/succeed/require-typed-parse.rkt b/collects/tests/typed-racket/succeed/require-typed-parse.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/require-typed-parse.rkt rename to collects/tests/typed-racket/succeed/require-typed-parse.rkt diff --git a/collects/tests/typed-scheme/succeed/require-typed-rename.rkt b/collects/tests/typed-racket/succeed/require-typed-rename.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/require-typed-rename.rkt rename to collects/tests/typed-racket/succeed/require-typed-rename.rkt diff --git a/collects/tests/typed-scheme/succeed/richard-bugs.rkt b/collects/tests/typed-racket/succeed/richard-bugs.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/richard-bugs.rkt rename to collects/tests/typed-racket/succeed/richard-bugs.rkt diff --git a/collects/tests/typed-scheme/succeed/safe-letrec.rkt b/collects/tests/typed-racket/succeed/safe-letrec.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/safe-letrec.rkt rename to collects/tests/typed-racket/succeed/safe-letrec.rkt diff --git a/collects/tests/typed-scheme/succeed/scratch.rkt b/collects/tests/typed-racket/succeed/scratch.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/scratch.rkt rename to collects/tests/typed-racket/succeed/scratch.rkt diff --git a/collects/tests/typed-scheme/succeed/seasoned-schemer.rkt b/collects/tests/typed-racket/succeed/seasoned-schemer.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/seasoned-schemer.rkt rename to collects/tests/typed-racket/succeed/seasoned-schemer.rkt diff --git a/collects/tests/typed-scheme/succeed/sequence-cnt.rkt b/collects/tests/typed-racket/succeed/sequence-cnt.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/sequence-cnt.rkt rename to collects/tests/typed-racket/succeed/sequence-cnt.rkt diff --git a/collects/tests/typed-scheme/succeed/sequences.rkt b/collects/tests/typed-racket/succeed/sequences.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/sequences.rkt rename to collects/tests/typed-racket/succeed/sequences.rkt diff --git a/collects/tests/typed-scheme/succeed/set-contract.rkt b/collects/tests/typed-racket/succeed/set-contract.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/set-contract.rkt rename to collects/tests/typed-racket/succeed/set-contract.rkt diff --git a/collects/tests/typed-scheme/succeed/set.rkt b/collects/tests/typed-racket/succeed/set.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/set.rkt rename to collects/tests/typed-racket/succeed/set.rkt diff --git a/collects/tests/typed-scheme/succeed/simple-fake-or.rkt b/collects/tests/typed-racket/succeed/simple-fake-or.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/simple-fake-or.rkt rename to collects/tests/typed-racket/succeed/simple-fake-or.rkt diff --git a/collects/tests/typed-scheme/succeed/simple-implies.rkt b/collects/tests/typed-racket/succeed/simple-implies.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/simple-implies.rkt rename to collects/tests/typed-racket/succeed/simple-implies.rkt diff --git a/collects/tests/typed-scheme/succeed/simple-kw-app.rkt b/collects/tests/typed-racket/succeed/simple-kw-app.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/simple-kw-app.rkt rename to collects/tests/typed-racket/succeed/simple-kw-app.rkt diff --git a/collects/tests/typed-scheme/succeed/simple-occurr.rkt b/collects/tests/typed-racket/succeed/simple-occurr.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/simple-occurr.rkt rename to collects/tests/typed-racket/succeed/simple-occurr.rkt diff --git a/collects/tests/typed-scheme/succeed/simple-or.rkt b/collects/tests/typed-racket/succeed/simple-or.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/simple-or.rkt rename to collects/tests/typed-racket/succeed/simple-or.rkt diff --git a/collects/tests/typed-scheme/succeed/simple-poly.rkt b/collects/tests/typed-racket/succeed/simple-poly.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/simple-poly.rkt rename to collects/tests/typed-racket/succeed/simple-poly.rkt diff --git a/collects/tests/typed-scheme/succeed/somesystempath.rkt b/collects/tests/typed-racket/succeed/somesystempath.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/somesystempath.rkt rename to collects/tests/typed-racket/succeed/somesystempath.rkt diff --git a/collects/tests/typed-scheme/succeed/star-sizes.rkt b/collects/tests/typed-racket/succeed/star-sizes.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/star-sizes.rkt rename to collects/tests/typed-racket/succeed/star-sizes.rkt diff --git a/collects/tests/typed-scheme/succeed/stream.rkt b/collects/tests/typed-racket/succeed/stream.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/stream.rkt rename to collects/tests/typed-racket/succeed/stream.rkt diff --git a/collects/tests/typed-scheme/succeed/string-const.rkt b/collects/tests/typed-racket/succeed/string-const.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/string-const.rkt rename to collects/tests/typed-racket/succeed/string-const.rkt diff --git a/collects/tests/typed-scheme/succeed/struct-cert.rkt b/collects/tests/typed-racket/succeed/struct-cert.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/struct-cert.rkt rename to collects/tests/typed-racket/succeed/struct-cert.rkt diff --git a/collects/tests/typed-scheme/succeed/struct-exec.rkt b/collects/tests/typed-racket/succeed/struct-exec.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/struct-exec.rkt rename to collects/tests/typed-racket/succeed/struct-exec.rkt diff --git a/collects/tests/typed-scheme/succeed/struct-mutable.rkt b/collects/tests/typed-racket/succeed/struct-mutable.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/struct-mutable.rkt rename to collects/tests/typed-racket/succeed/struct-mutable.rkt diff --git a/collects/tests/typed-scheme/succeed/struct-out.rkt b/collects/tests/typed-racket/succeed/struct-out.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/struct-out.rkt rename to collects/tests/typed-racket/succeed/struct-out.rkt diff --git a/collects/tests/typed-scheme/succeed/struct-path-update.rkt b/collects/tests/typed-racket/succeed/struct-path-update.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/struct-path-update.rkt rename to collects/tests/typed-racket/succeed/struct-path-update.rkt diff --git a/collects/tests/typed-scheme/succeed/test-child-field.rkt b/collects/tests/typed-racket/succeed/test-child-field.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/test-child-field.rkt rename to collects/tests/typed-racket/succeed/test-child-field.rkt diff --git a/collects/tests/typed-scheme/succeed/test.rkt b/collects/tests/typed-racket/succeed/test.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/test.rkt rename to collects/tests/typed-racket/succeed/test.rkt diff --git a/collects/tests/typed-scheme/succeed/test2.rkt b/collects/tests/typed-racket/succeed/test2.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/test2.rkt rename to collects/tests/typed-racket/succeed/test2.rkt diff --git a/collects/tests/typed-scheme/succeed/threads-and-channels.rkt b/collects/tests/typed-racket/succeed/threads-and-channels.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/threads-and-channels.rkt rename to collects/tests/typed-racket/succeed/threads-and-channels.rkt diff --git a/collects/tests/typed-scheme/succeed/time.rkt b/collects/tests/typed-racket/succeed/time.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/time.rkt rename to collects/tests/typed-racket/succeed/time.rkt diff --git a/collects/tests/typed-scheme/succeed/typeann-letrec.rkt b/collects/tests/typed-racket/succeed/typeann-letrec.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/typeann-letrec.rkt rename to collects/tests/typed-racket/succeed/typeann-letrec.rkt diff --git a/collects/tests/typed-scheme/succeed/typed-list.rkt b/collects/tests/typed-racket/succeed/typed-list.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/typed-list.rkt rename to collects/tests/typed-racket/succeed/typed-list.rkt diff --git a/collects/tests/typed-scheme/succeed/typed-scheme-no-check-arrow.rkt b/collects/tests/typed-racket/succeed/typed-scheme-no-check-arrow.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/typed-scheme-no-check-arrow.rkt rename to collects/tests/typed-racket/succeed/typed-scheme-no-check-arrow.rkt diff --git a/collects/tests/typed-scheme/succeed/unsafe-struct-parent.rkt b/collects/tests/typed-racket/succeed/unsafe-struct-parent.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/unsafe-struct-parent.rkt rename to collects/tests/typed-racket/succeed/unsafe-struct-parent.rkt diff --git a/collects/tests/typed-scheme/succeed/unsafe-struct.rkt b/collects/tests/typed-racket/succeed/unsafe-struct.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/unsafe-struct.rkt rename to collects/tests/typed-racket/succeed/unsafe-struct.rkt diff --git a/collects/tests/typed-scheme/succeed/values-dots.rkt b/collects/tests/typed-racket/succeed/values-dots.rkt similarity index 95% rename from collects/tests/typed-scheme/succeed/values-dots.rkt rename to collects/tests/typed-racket/succeed/values-dots.rkt index f97ef0f472..efe5f3d11f 100644 --- a/collects/tests/typed-scheme/succeed/values-dots.rkt +++ b/collects/tests/typed-racket/succeed/values-dots.rkt @@ -1,6 +1,6 @@ #lang typed/scheme/base -(require typed-scheme/base-env/extra-procs) +(require typed-racket/base-env/extra-procs) (call-with-values (lambda () (values 1 2)) (lambda: ([x : Number] [y : Number]) (+ x y))) diff --git a/collects/tests/typed-scheme/succeed/varargs-tests.rkt b/collects/tests/typed-racket/succeed/varargs-tests.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/varargs-tests.rkt rename to collects/tests/typed-racket/succeed/varargs-tests.rkt diff --git a/collects/tests/typed-scheme/succeed/vec-tests.rkt b/collects/tests/typed-racket/succeed/vec-tests.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/vec-tests.rkt rename to collects/tests/typed-racket/succeed/vec-tests.rkt diff --git a/collects/tests/typed-scheme/succeed/with-asserts.rkt b/collects/tests/typed-racket/succeed/with-asserts.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/with-asserts.rkt rename to collects/tests/typed-racket/succeed/with-asserts.rkt diff --git a/collects/tests/typed-scheme/succeed/with-handlers.rkt b/collects/tests/typed-racket/succeed/with-handlers.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/with-handlers.rkt rename to collects/tests/typed-racket/succeed/with-handlers.rkt diff --git a/collects/tests/typed-scheme/succeed/with-syntax.rkt b/collects/tests/typed-racket/succeed/with-syntax.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/with-syntax.rkt rename to collects/tests/typed-racket/succeed/with-syntax.rkt diff --git a/collects/tests/typed-scheme/succeed/with-type.rkt b/collects/tests/typed-racket/succeed/with-type.rkt similarity index 100% rename from collects/tests/typed-scheme/succeed/with-type.rkt rename to collects/tests/typed-racket/succeed/with-type.rkt diff --git a/collects/tests/typed-scheme/unit-tests/all-tests.rkt b/collects/tests/typed-racket/unit-tests/all-tests.rkt similarity index 100% rename from collects/tests/typed-scheme/unit-tests/all-tests.rkt rename to collects/tests/typed-racket/unit-tests/all-tests.rkt diff --git a/collects/tests/typed-scheme/unit-tests/contract-tests.rkt b/collects/tests/typed-racket/unit-tests/contract-tests.rkt similarity index 100% rename from collects/tests/typed-scheme/unit-tests/contract-tests.rkt rename to collects/tests/typed-racket/unit-tests/contract-tests.rkt diff --git a/collects/tests/typed-scheme/unit-tests/infer-tests.rkt b/collects/tests/typed-racket/unit-tests/infer-tests.rkt similarity index 100% rename from collects/tests/typed-scheme/unit-tests/infer-tests.rkt rename to collects/tests/typed-racket/unit-tests/infer-tests.rkt diff --git a/collects/tests/typed-scheme/unit-tests/module-tests.rkt b/collects/tests/typed-racket/unit-tests/module-tests.rkt similarity index 100% rename from collects/tests/typed-scheme/unit-tests/module-tests.rkt rename to collects/tests/typed-racket/unit-tests/module-tests.rkt diff --git a/collects/tests/typed-scheme/unit-tests/parse-type-tests.rkt b/collects/tests/typed-racket/unit-tests/parse-type-tests.rkt similarity index 100% rename from collects/tests/typed-scheme/unit-tests/parse-type-tests.rkt rename to collects/tests/typed-racket/unit-tests/parse-type-tests.rkt diff --git a/collects/tests/typed-scheme/unit-tests/planet-requires.rkt b/collects/tests/typed-racket/unit-tests/planet-requires.rkt similarity index 100% rename from collects/tests/typed-scheme/unit-tests/planet-requires.rkt rename to collects/tests/typed-racket/unit-tests/planet-requires.rkt diff --git a/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.rkt b/collects/tests/typed-racket/unit-tests/remove-intersect-tests.rkt similarity index 100% rename from collects/tests/typed-scheme/unit-tests/remove-intersect-tests.rkt rename to collects/tests/typed-racket/unit-tests/remove-intersect-tests.rkt diff --git a/collects/tests/typed-scheme/unit-tests/special-env-typecheck-tests.rkt b/collects/tests/typed-racket/unit-tests/special-env-typecheck-tests.rkt similarity index 95% rename from collects/tests/typed-scheme/unit-tests/special-env-typecheck-tests.rkt rename to collects/tests/typed-racket/unit-tests/special-env-typecheck-tests.rkt index f8a639a7e5..fc148ac1c0 100644 --- a/collects/tests/typed-scheme/unit-tests/special-env-typecheck-tests.rkt +++ b/collects/tests/typed-racket/unit-tests/special-env-typecheck-tests.rkt @@ -10,7 +10,7 @@ [true-filter -true-filter] [-> t:->])) (except-in (utils tc-utils utils) infer) - typed-scheme/infer/infer-dummy typed-scheme/infer/infer + typed-racket/infer/infer-dummy typed-racket/infer/infer unstable/mutated-vars rackunit rackunit/text-ui @@ -20,9 +20,9 @@ (types abbrev convenience utils) unstable/mutated-vars (utils tc-utils) (typecheck typechecker)) - typed-scheme/base-env/prims - typed-scheme/base-env/base-types - (only-in typed-scheme/typed-scheme do-standard-inits)) + typed-racket/base-env/prims + typed-racket/base-env/base-types + (only-in typed-racket/typed-racket do-standard-inits)) (begin-for-syntax (do-standard-inits)) diff --git a/collects/tests/typed-scheme/unit-tests/subst-tests.rkt b/collects/tests/typed-racket/unit-tests/subst-tests.rkt similarity index 100% rename from collects/tests/typed-scheme/unit-tests/subst-tests.rkt rename to collects/tests/typed-racket/unit-tests/subst-tests.rkt diff --git a/collects/tests/typed-scheme/unit-tests/subtype-tests.rkt b/collects/tests/typed-racket/unit-tests/subtype-tests.rkt similarity index 100% rename from collects/tests/typed-scheme/unit-tests/subtype-tests.rkt rename to collects/tests/typed-racket/unit-tests/subtype-tests.rkt diff --git a/collects/tests/typed-scheme/unit-tests/test-utils.rkt b/collects/tests/typed-racket/unit-tests/test-utils.rkt similarity index 98% rename from collects/tests/typed-scheme/unit-tests/test-utils.rkt rename to collects/tests/typed-racket/unit-tests/test-utils.rkt index 26e3474be7..673ae4c0ab 100644 --- a/collects/tests/typed-scheme/unit-tests/test-utils.rkt +++ b/collects/tests/typed-racket/unit-tests/test-utils.rkt @@ -4,7 +4,7 @@ (require scheme/require-syntax scheme/match scheme/gui/dynamic - typed-scheme/utils/utils + typed-racket/utils/utils (for-syntax scheme/base) (types comparison utils) rackunit rackunit/text-ui) diff --git a/collects/tests/typed-scheme/unit-tests/type-annotation-test.rkt b/collects/tests/typed-racket/unit-tests/type-annotation-test.rkt similarity index 85% rename from collects/tests/typed-scheme/unit-tests/type-annotation-test.rkt rename to collects/tests/typed-racket/unit-tests/type-annotation-test.rkt index 6a4f73446f..7bbf7883b3 100644 --- a/collects/tests/typed-scheme/unit-tests/type-annotation-test.rkt +++ b/collects/tests/typed-racket/unit-tests/type-annotation-test.rkt @@ -1,8 +1,8 @@ #lang scheme/base (require "test-utils.rkt" (for-syntax scheme/base) - typed-scheme/private/type-annotation - typed-scheme/private/parse-type + typed-racket/private/type-annotation + typed-racket/private/parse-type (types abbrev numeric-tower utils) (env type-env-structs init-envs) (utils tc-utils) @@ -16,9 +16,9 @@ (type-ascription (let ([ons (current-namespace)] [ns (make-base-namespace)]) (parameterize ([current-namespace ns]) - (namespace-require 'typed-scheme/base-env/prims) - (namespace-require 'typed-scheme/base-env/base-types) - (namespace-require 'typed-scheme/base-env/base-types-extra) + (namespace-require 'typed-racket/base-env/prims) + (namespace-require 'typed-racket/base-env/base-types) + (namespace-require 'typed-racket/base-env/base-types-extra) (expand 'ann-stx)))) ty)) diff --git a/collects/tests/typed-scheme/unit-tests/type-equal-tests.rkt b/collects/tests/typed-racket/unit-tests/type-equal-tests.rkt similarity index 100% rename from collects/tests/typed-scheme/unit-tests/type-equal-tests.rkt rename to collects/tests/typed-racket/unit-tests/type-equal-tests.rkt diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt b/collects/tests/typed-racket/unit-tests/typecheck-tests.rkt similarity index 99% rename from collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt rename to collects/tests/typed-racket/unit-tests/typecheck-tests.rkt index 4a2d805ef6..b6a1a59abb 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-racket/unit-tests/typecheck-tests.rkt @@ -15,7 +15,7 @@ [true-filter -true-filter] [-> t:->]) (except-in (utils tc-utils utils) infer) - typed-scheme/infer/infer-dummy typed-scheme/infer/infer + typed-racket/infer/infer-dummy typed-racket/infer/infer unstable/mutated-vars (env type-name-env type-env-structs init-envs) rackunit rackunit/text-ui @@ -134,7 +134,7 @@ (define (typecheck-tests) (test-suite "Typechecker tests" - #reader typed-scheme/typed-reader + #reader typed-racket/typed-reader (test-suite "tc-expr tests" @@ -1376,7 +1376,7 @@ ;; these no longer work with the new scheme for top-level identifiers ;; could probably be revived #;(define (tc-toplevel-tests) -#reader typed-scheme/typed-reader +#reader typed-racket/typed-reader (test-suite "Tests for tc-toplevel" (tc-tl 3) (tc-tl (define: x : Number 4)) diff --git a/collects/tests/typed-scheme/xfail/ann-map-funcs.rkt b/collects/tests/typed-racket/xfail/ann-map-funcs.rkt similarity index 100% rename from collects/tests/typed-scheme/xfail/ann-map-funcs.rkt rename to collects/tests/typed-racket/xfail/ann-map-funcs.rkt diff --git a/collects/tests/typed-scheme/xfail/applicative.rkt b/collects/tests/typed-racket/xfail/applicative.rkt similarity index 100% rename from collects/tests/typed-scheme/xfail/applicative.rkt rename to collects/tests/typed-racket/xfail/applicative.rkt diff --git a/collects/tests/typed-scheme/xfail/apply-map-bug.rkt b/collects/tests/typed-racket/xfail/apply-map-bug.rkt similarity index 100% rename from collects/tests/typed-scheme/xfail/apply-map-bug.rkt rename to collects/tests/typed-racket/xfail/apply-map-bug.rkt diff --git a/collects/tests/typed-scheme/xfail/cl-expected.rkt b/collects/tests/typed-racket/xfail/cl-expected.rkt similarity index 100% rename from collects/tests/typed-scheme/xfail/cl-expected.rkt rename to collects/tests/typed-racket/xfail/cl-expected.rkt diff --git a/collects/tests/typed-scheme/xfail/for-inference.rkt b/collects/tests/typed-racket/xfail/for-inference.rkt similarity index 100% rename from collects/tests/typed-scheme/xfail/for-inference.rkt rename to collects/tests/typed-racket/xfail/for-inference.rkt diff --git a/collects/tests/typed-scheme/xfail/pr10618.rkt b/collects/tests/typed-racket/xfail/pr10618.rkt similarity index 100% rename from collects/tests/typed-scheme/xfail/pr10618.rkt rename to collects/tests/typed-racket/xfail/pr10618.rkt diff --git a/collects/tests/typed-scheme/xfail/priority-queue.scm b/collects/tests/typed-racket/xfail/priority-queue.scm similarity index 100% rename from collects/tests/typed-scheme/xfail/priority-queue.scm rename to collects/tests/typed-racket/xfail/priority-queue.scm diff --git a/collects/tests/typed-scheme/xfail/rec-contract.rkt b/collects/tests/typed-racket/xfail/rec-contract.rkt similarity index 100% rename from collects/tests/typed-scheme/xfail/rec-contract.rkt rename to collects/tests/typed-racket/xfail/rec-contract.rkt diff --git a/collects/tests/typed-scheme/xfail/unholy-terror.rkt b/collects/tests/typed-racket/xfail/unholy-terror.rkt similarity index 100% rename from collects/tests/typed-scheme/xfail/unholy-terror.rkt rename to collects/tests/typed-racket/xfail/unholy-terror.rkt diff --git a/collects/tests/typed-scheme/xfail/xmodule-mutation.rkt b/collects/tests/typed-racket/xfail/xmodule-mutation.rkt similarity index 100% rename from collects/tests/typed-scheme/xfail/xmodule-mutation.rkt rename to collects/tests/typed-racket/xfail/xmodule-mutation.rkt diff --git a/collects/typed-scheme/base-env/annotate-classes.rkt b/collects/typed-racket/base-env/annotate-classes.rkt similarity index 100% rename from collects/typed-scheme/base-env/annotate-classes.rkt rename to collects/typed-racket/base-env/annotate-classes.rkt diff --git a/collects/typed-scheme/base-env/base-env-indexing-abs.rkt b/collects/typed-racket/base-env/base-env-indexing-abs.rkt similarity index 100% rename from collects/typed-scheme/base-env/base-env-indexing-abs.rkt rename to collects/typed-racket/base-env/base-env-indexing-abs.rkt diff --git a/collects/typed-scheme/base-env/base-env-indexing.rkt b/collects/typed-racket/base-env/base-env-indexing.rkt similarity index 100% rename from collects/typed-scheme/base-env/base-env-indexing.rkt rename to collects/typed-racket/base-env/base-env-indexing.rkt diff --git a/collects/typed-scheme/base-env/base-env-numeric.rkt b/collects/typed-racket/base-env/base-env-numeric.rkt similarity index 100% rename from collects/typed-scheme/base-env/base-env-numeric.rkt rename to collects/typed-racket/base-env/base-env-numeric.rkt diff --git a/collects/typed-scheme/base-env/base-env.rkt b/collects/typed-racket/base-env/base-env.rkt similarity index 100% rename from collects/typed-scheme/base-env/base-env.rkt rename to collects/typed-racket/base-env/base-env.rkt diff --git a/collects/typed-scheme/base-env/base-special-env.rkt b/collects/typed-racket/base-env/base-special-env.rkt similarity index 100% rename from collects/typed-scheme/base-env/base-special-env.rkt rename to collects/typed-racket/base-env/base-special-env.rkt diff --git a/collects/typed-scheme/base-env/base-structs.rkt b/collects/typed-racket/base-env/base-structs.rkt similarity index 100% rename from collects/typed-scheme/base-env/base-structs.rkt rename to collects/typed-racket/base-env/base-structs.rkt diff --git a/collects/typed-scheme/base-env/base-types-extra.rkt b/collects/typed-racket/base-env/base-types-extra.rkt similarity index 100% rename from collects/typed-scheme/base-env/base-types-extra.rkt rename to collects/typed-racket/base-env/base-types-extra.rkt diff --git a/collects/typed-scheme/base-env/base-types.rkt b/collects/typed-racket/base-env/base-types.rkt similarity index 100% rename from collects/typed-scheme/base-env/base-types.rkt rename to collects/typed-racket/base-env/base-types.rkt diff --git a/collects/typed-scheme/base-env/colon.rkt b/collects/typed-racket/base-env/colon.rkt similarity index 100% rename from collects/typed-scheme/base-env/colon.rkt rename to collects/typed-racket/base-env/colon.rkt diff --git a/collects/typed-scheme/base-env/env-lang.rkt b/collects/typed-racket/base-env/env-lang.rkt similarity index 100% rename from collects/typed-scheme/base-env/env-lang.rkt rename to collects/typed-racket/base-env/env-lang.rkt diff --git a/collects/typed-scheme/base-env/extra-procs.rkt b/collects/typed-racket/base-env/extra-procs.rkt similarity index 100% rename from collects/typed-scheme/base-env/extra-procs.rkt rename to collects/typed-racket/base-env/extra-procs.rkt diff --git a/collects/typed-scheme/base-env/for-clauses.rkt b/collects/typed-racket/base-env/for-clauses.rkt similarity index 100% rename from collects/typed-scheme/base-env/for-clauses.rkt rename to collects/typed-racket/base-env/for-clauses.rkt diff --git a/collects/typed-scheme/base-env/internal.rkt b/collects/typed-racket/base-env/internal.rkt similarity index 100% rename from collects/typed-scheme/base-env/internal.rkt rename to collects/typed-racket/base-env/internal.rkt diff --git a/collects/typed-scheme/base-env/prims.rkt b/collects/typed-racket/base-env/prims.rkt similarity index 99% rename from collects/typed-scheme/base-env/prims.rkt rename to collects/typed-racket/base-env/prims.rkt index a1088ef84b..ac057f211b 100644 --- a/collects/typed-scheme/base-env/prims.rkt +++ b/collects/typed-racket/base-env/prims.rkt @@ -55,8 +55,8 @@ This file defines two sorts of primitives. All of them are provided into any mod ;; dynamically loaded b/c they're only used at the top-level, so we save a lot ;; of loading by not having them when we're in a module -(define-for-syntax (parse-type stx) ((dynamic-require 'typed-scheme/private/parse-type 'parse-type) stx)) -(define-for-syntax (type->contract stx) ((dynamic-require 'typed-scheme/private/type-contract 'type->contract) stx)) +(define-for-syntax (parse-type stx) ((dynamic-require 'typed-racket/private/parse-type 'parse-type) stx)) +(define-for-syntax (type->contract stx) ((dynamic-require 'typed-racket/private/type-contract 'type->contract) stx)) (define-syntaxes (require/typed-legacy require/typed) diff --git a/collects/typed-scheme/base-env/type-env-lang.rkt b/collects/typed-racket/base-env/type-env-lang.rkt similarity index 100% rename from collects/typed-scheme/base-env/type-env-lang.rkt rename to collects/typed-racket/base-env/type-env-lang.rkt diff --git a/collects/typed-scheme/core.rkt b/collects/typed-racket/core.rkt similarity index 100% rename from collects/typed-scheme/core.rkt rename to collects/typed-racket/core.rkt diff --git a/collects/typed-scheme/env/global-env.rkt b/collects/typed-racket/env/global-env.rkt similarity index 100% rename from collects/typed-scheme/env/global-env.rkt rename to collects/typed-racket/env/global-env.rkt diff --git a/collects/typed-scheme/env/index-env.rkt b/collects/typed-racket/env/index-env.rkt similarity index 100% rename from collects/typed-scheme/env/index-env.rkt rename to collects/typed-racket/env/index-env.rkt diff --git a/collects/typed-scheme/env/init-envs.rkt b/collects/typed-racket/env/init-envs.rkt similarity index 100% rename from collects/typed-scheme/env/init-envs.rkt rename to collects/typed-racket/env/init-envs.rkt diff --git a/collects/typed-scheme/env/lexical-env.rkt b/collects/typed-racket/env/lexical-env.rkt similarity index 100% rename from collects/typed-scheme/env/lexical-env.rkt rename to collects/typed-racket/env/lexical-env.rkt diff --git a/collects/typed-scheme/env/tvar-env.rkt b/collects/typed-racket/env/tvar-env.rkt similarity index 100% rename from collects/typed-scheme/env/tvar-env.rkt rename to collects/typed-racket/env/tvar-env.rkt diff --git a/collects/typed-scheme/env/type-alias-env.rkt b/collects/typed-racket/env/type-alias-env.rkt similarity index 100% rename from collects/typed-scheme/env/type-alias-env.rkt rename to collects/typed-racket/env/type-alias-env.rkt diff --git a/collects/typed-scheme/env/type-env-structs.rkt b/collects/typed-racket/env/type-env-structs.rkt similarity index 100% rename from collects/typed-scheme/env/type-env-structs.rkt rename to collects/typed-racket/env/type-env-structs.rkt diff --git a/collects/typed-scheme/env/type-name-env.rkt b/collects/typed-racket/env/type-name-env.rkt similarity index 100% rename from collects/typed-scheme/env/type-name-env.rkt rename to collects/typed-racket/env/type-name-env.rkt diff --git a/collects/typed-scheme/infer/constraint-structs.rkt b/collects/typed-racket/infer/constraint-structs.rkt similarity index 100% rename from collects/typed-scheme/infer/constraint-structs.rkt rename to collects/typed-racket/infer/constraint-structs.rkt diff --git a/collects/typed-scheme/infer/constraints.rkt b/collects/typed-racket/infer/constraints.rkt similarity index 100% rename from collects/typed-scheme/infer/constraints.rkt rename to collects/typed-racket/infer/constraints.rkt diff --git a/collects/typed-scheme/infer/dmap.rkt b/collects/typed-racket/infer/dmap.rkt similarity index 100% rename from collects/typed-scheme/infer/dmap.rkt rename to collects/typed-racket/infer/dmap.rkt diff --git a/collects/typed-scheme/infer/infer-dummy.rkt b/collects/typed-racket/infer/infer-dummy.rkt similarity index 100% rename from collects/typed-scheme/infer/infer-dummy.rkt rename to collects/typed-racket/infer/infer-dummy.rkt diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-racket/infer/infer-unit.rkt similarity index 100% rename from collects/typed-scheme/infer/infer-unit.rkt rename to collects/typed-racket/infer/infer-unit.rkt diff --git a/collects/typed-scheme/infer/infer.rkt b/collects/typed-racket/infer/infer.rkt similarity index 100% rename from collects/typed-scheme/infer/infer.rkt rename to collects/typed-racket/infer/infer.rkt diff --git a/collects/typed-scheme/infer/promote-demote.rkt b/collects/typed-racket/infer/promote-demote.rkt similarity index 100% rename from collects/typed-scheme/infer/promote-demote.rkt rename to collects/typed-racket/infer/promote-demote.rkt diff --git a/collects/typed-scheme/infer/restrict.rkt b/collects/typed-racket/infer/restrict.rkt similarity index 100% rename from collects/typed-scheme/infer/restrict.rkt rename to collects/typed-racket/infer/restrict.rkt diff --git a/collects/typed-scheme/infer/signatures.rkt b/collects/typed-racket/infer/signatures.rkt similarity index 100% rename from collects/typed-scheme/infer/signatures.rkt rename to collects/typed-racket/infer/signatures.rkt diff --git a/collects/typed-scheme/info.rkt b/collects/typed-racket/info.rkt similarity index 100% rename from collects/typed-scheme/info.rkt rename to collects/typed-racket/info.rkt diff --git a/collects/typed-scheme/language-info.rkt b/collects/typed-racket/language-info.rkt similarity index 69% rename from collects/typed-scheme/language-info.rkt rename to collects/typed-racket/language-info.rkt index 311186d59c..56b7e99ad5 100644 --- a/collects/typed-scheme/language-info.rkt +++ b/collects/typed-racket/language-info.rkt @@ -1,17 +1,17 @@ #lang racket/base -(require typed-scheme/typed-reader) +(require typed-racket/typed-reader) (provide get-info configure) (define ((get-info arg) key default) (case key - [(configure-runtime) `(#(typed-scheme/language-info configure ()))] + [(configure-runtime) `(#(typed-racket/language-info configure ()))] [else default])) ;; options currently always empty (define (configure options) (namespace-require 'racket/base) (eval '(begin - (require (for-syntax typed-scheme/utils/tc-utils racket/base)) + (require (for-syntax typed-racket/utils/tc-utils racket/base)) (begin-for-syntax (set-box! typed-context? #t))) (current-namespace)) (current-readtable (readtable))) diff --git a/collects/typed-scheme/minimal.rkt b/collects/typed-racket/minimal.rkt similarity index 94% rename from collects/typed-scheme/minimal.rkt rename to collects/typed-racket/minimal.rkt index 837344a9c0..e5de966449 100644 --- a/collects/typed-scheme/minimal.rkt +++ b/collects/typed-racket/minimal.rkt @@ -5,7 +5,7 @@ (require (for-syntax racket/base) racket/require) -(define-for-syntax ts-mod 'typed-scheme/typed-scheme) +(define-for-syntax ts-mod 'typed-racket/typed-racket) (define-syntax (providing stx) (syntax-case stx (libs from basics except) diff --git a/collects/typed-scheme/minimal/lang/reader.rkt b/collects/typed-racket/minimal/lang/reader.rkt similarity index 75% rename from collects/typed-scheme/minimal/lang/reader.rkt rename to collects/typed-racket/minimal/lang/reader.rkt index 5267b951c7..0c5c481cbf 100644 --- a/collects/typed-scheme/minimal/lang/reader.rkt +++ b/collects/typed-racket/minimal/lang/reader.rkt @@ -1,6 +1,6 @@ #lang s-exp syntax/module-reader -typed-scheme/minimal +typed-racket/minimal #:language-info make-language-info #:info make-info @@ -10,4 +10,4 @@ typed-scheme/minimal [else (use-default key default)])) (define make-language-info - `#(typed-scheme/language-info get-info ())) + `#(typed-racket/language-info get-info ())) diff --git a/collects/typed-scheme/optimizer/apply.rkt b/collects/typed-racket/optimizer/apply.rkt similarity index 100% rename from collects/typed-scheme/optimizer/apply.rkt rename to collects/typed-racket/optimizer/apply.rkt diff --git a/collects/typed-scheme/optimizer/box.rkt b/collects/typed-racket/optimizer/box.rkt similarity index 100% rename from collects/typed-scheme/optimizer/box.rkt rename to collects/typed-racket/optimizer/box.rkt diff --git a/collects/typed-scheme/optimizer/dead-code.rkt b/collects/typed-racket/optimizer/dead-code.rkt similarity index 100% rename from collects/typed-scheme/optimizer/dead-code.rkt rename to collects/typed-racket/optimizer/dead-code.rkt diff --git a/collects/typed-scheme/optimizer/fixnum.rkt b/collects/typed-racket/optimizer/fixnum.rkt similarity index 100% rename from collects/typed-scheme/optimizer/fixnum.rkt rename to collects/typed-racket/optimizer/fixnum.rkt diff --git a/collects/typed-scheme/optimizer/float-complex.rkt b/collects/typed-racket/optimizer/float-complex.rkt similarity index 100% rename from collects/typed-scheme/optimizer/float-complex.rkt rename to collects/typed-racket/optimizer/float-complex.rkt diff --git a/collects/typed-scheme/optimizer/float.rkt b/collects/typed-racket/optimizer/float.rkt similarity index 100% rename from collects/typed-scheme/optimizer/float.rkt rename to collects/typed-racket/optimizer/float.rkt diff --git a/collects/typed-scheme/optimizer/list.rkt b/collects/typed-racket/optimizer/list.rkt similarity index 100% rename from collects/typed-scheme/optimizer/list.rkt rename to collects/typed-racket/optimizer/list.rkt diff --git a/collects/typed-scheme/optimizer/logging.rkt b/collects/typed-racket/optimizer/logging.rkt similarity index 100% rename from collects/typed-scheme/optimizer/logging.rkt rename to collects/typed-racket/optimizer/logging.rkt diff --git a/collects/typed-scheme/optimizer/number.rkt b/collects/typed-racket/optimizer/number.rkt similarity index 100% rename from collects/typed-scheme/optimizer/number.rkt rename to collects/typed-racket/optimizer/number.rkt diff --git a/collects/typed-scheme/optimizer/numeric-utils.rkt b/collects/typed-racket/optimizer/numeric-utils.rkt similarity index 100% rename from collects/typed-scheme/optimizer/numeric-utils.rkt rename to collects/typed-racket/optimizer/numeric-utils.rkt diff --git a/collects/typed-scheme/optimizer/optimizer.rkt b/collects/typed-racket/optimizer/optimizer.rkt similarity index 100% rename from collects/typed-scheme/optimizer/optimizer.rkt rename to collects/typed-racket/optimizer/optimizer.rkt diff --git a/collects/typed-scheme/optimizer/pair.rkt b/collects/typed-racket/optimizer/pair.rkt similarity index 100% rename from collects/typed-scheme/optimizer/pair.rkt rename to collects/typed-racket/optimizer/pair.rkt diff --git a/collects/typed-scheme/optimizer/sequence.rkt b/collects/typed-racket/optimizer/sequence.rkt similarity index 100% rename from collects/typed-scheme/optimizer/sequence.rkt rename to collects/typed-racket/optimizer/sequence.rkt diff --git a/collects/typed-scheme/optimizer/string.rkt b/collects/typed-racket/optimizer/string.rkt similarity index 100% rename from collects/typed-scheme/optimizer/string.rkt rename to collects/typed-racket/optimizer/string.rkt diff --git a/collects/typed-scheme/optimizer/struct.rkt b/collects/typed-racket/optimizer/struct.rkt similarity index 100% rename from collects/typed-scheme/optimizer/struct.rkt rename to collects/typed-racket/optimizer/struct.rkt diff --git a/collects/typed-scheme/optimizer/tool/display.rkt b/collects/typed-racket/optimizer/tool/display.rkt similarity index 100% rename from collects/typed-scheme/optimizer/tool/display.rkt rename to collects/typed-racket/optimizer/tool/display.rkt diff --git a/collects/typed-scheme/optimizer/tool/report.rkt b/collects/typed-racket/optimizer/tool/report.rkt similarity index 98% rename from collects/typed-scheme/optimizer/tool/report.rkt rename to collects/typed-racket/optimizer/tool/report.rkt index f27f7cf140..f735f2e2fb 100644 --- a/collects/typed-scheme/optimizer/tool/report.rkt +++ b/collects/typed-racket/optimizer/tool/report.rkt @@ -2,8 +2,8 @@ (require racket/class racket/gui/base racket/match racket/port unstable/syntax unstable/port racket/sandbox - typed-scheme/optimizer/logging - (prefix-in tr: typed-scheme/typed-reader)) + typed-racket/optimizer/logging + (prefix-in tr: typed-racket/typed-reader)) (provide (struct-out report-entry) (struct-out sub-report-entry) diff --git a/collects/typed-scheme/optimizer/tool/tool.rkt b/collects/typed-racket/optimizer/tool/tool.rkt similarity index 100% rename from collects/typed-scheme/optimizer/tool/tool.rkt rename to collects/typed-racket/optimizer/tool/tool.rkt diff --git a/collects/typed-scheme/optimizer/unboxed-let.rkt b/collects/typed-racket/optimizer/unboxed-let.rkt similarity index 100% rename from collects/typed-scheme/optimizer/unboxed-let.rkt rename to collects/typed-racket/optimizer/unboxed-let.rkt diff --git a/collects/typed-scheme/optimizer/utils.rkt b/collects/typed-racket/optimizer/utils.rkt similarity index 100% rename from collects/typed-scheme/optimizer/utils.rkt rename to collects/typed-racket/optimizer/utils.rkt diff --git a/collects/typed-scheme/optimizer/vector.rkt b/collects/typed-racket/optimizer/vector.rkt similarity index 100% rename from collects/typed-scheme/optimizer/vector.rkt rename to collects/typed-racket/optimizer/vector.rkt diff --git a/collects/typed-scheme/private/parse-classes.rkt b/collects/typed-racket/private/parse-classes.rkt similarity index 100% rename from collects/typed-scheme/private/parse-classes.rkt rename to collects/typed-racket/private/parse-classes.rkt diff --git a/collects/typed-scheme/private/parse-type.rkt b/collects/typed-racket/private/parse-type.rkt similarity index 100% rename from collects/typed-scheme/private/parse-type.rkt rename to collects/typed-racket/private/parse-type.rkt diff --git a/collects/typed-scheme/private/type-annotation.rkt b/collects/typed-racket/private/type-annotation.rkt similarity index 100% rename from collects/typed-scheme/private/type-annotation.rkt rename to collects/typed-racket/private/type-annotation.rkt diff --git a/collects/typed-scheme/private/type-contract.rkt b/collects/typed-racket/private/type-contract.rkt similarity index 100% rename from collects/typed-scheme/private/type-contract.rkt rename to collects/typed-racket/private/type-contract.rkt diff --git a/collects/typed-scheme/private/typed-renaming.rkt b/collects/typed-racket/private/typed-renaming.rkt similarity index 100% rename from collects/typed-scheme/private/typed-renaming.rkt rename to collects/typed-racket/private/typed-renaming.rkt diff --git a/collects/typed-scheme/private/with-types.rkt b/collects/typed-racket/private/with-types.rkt similarity index 100% rename from collects/typed-scheme/private/with-types.rkt rename to collects/typed-racket/private/with-types.rkt diff --git a/collects/typed-scheme/rep/filter-rep.rkt b/collects/typed-racket/rep/filter-rep.rkt similarity index 100% rename from collects/typed-scheme/rep/filter-rep.rkt rename to collects/typed-racket/rep/filter-rep.rkt diff --git a/collects/typed-scheme/rep/free-variance.rkt b/collects/typed-racket/rep/free-variance.rkt similarity index 100% rename from collects/typed-scheme/rep/free-variance.rkt rename to collects/typed-racket/rep/free-variance.rkt diff --git a/collects/typed-scheme/rep/interning.rkt b/collects/typed-racket/rep/interning.rkt similarity index 100% rename from collects/typed-scheme/rep/interning.rkt rename to collects/typed-racket/rep/interning.rkt diff --git a/collects/typed-scheme/rep/object-rep.rkt b/collects/typed-racket/rep/object-rep.rkt similarity index 100% rename from collects/typed-scheme/rep/object-rep.rkt rename to collects/typed-racket/rep/object-rep.rkt diff --git a/collects/typed-scheme/rep/rep-utils.rkt b/collects/typed-racket/rep/rep-utils.rkt similarity index 100% rename from collects/typed-scheme/rep/rep-utils.rkt rename to collects/typed-racket/rep/rep-utils.rkt diff --git a/collects/typed-scheme/rep/type-rep.rkt b/collects/typed-racket/rep/type-rep.rkt similarity index 100% rename from collects/typed-scheme/rep/type-rep.rkt rename to collects/typed-racket/rep/type-rep.rkt diff --git a/collects/typed-scheme/scribblings/guide/begin.scrbl b/collects/typed-racket/scribblings/guide/begin.scrbl similarity index 100% rename from collects/typed-scheme/scribblings/guide/begin.scrbl rename to collects/typed-racket/scribblings/guide/begin.scrbl diff --git a/collects/typed-scheme/scribblings/guide/more.scrbl b/collects/typed-racket/scribblings/guide/more.scrbl similarity index 100% rename from collects/typed-scheme/scribblings/guide/more.scrbl rename to collects/typed-racket/scribblings/guide/more.scrbl diff --git a/collects/typed-scheme/scribblings/guide/optimization.scrbl b/collects/typed-racket/scribblings/guide/optimization.scrbl similarity index 100% rename from collects/typed-scheme/scribblings/guide/optimization.scrbl rename to collects/typed-racket/scribblings/guide/optimization.scrbl diff --git a/collects/typed-scheme/scribblings/guide/quick.scrbl b/collects/typed-racket/scribblings/guide/quick.scrbl similarity index 100% rename from collects/typed-scheme/scribblings/guide/quick.scrbl rename to collects/typed-racket/scribblings/guide/quick.scrbl diff --git a/collects/typed-scheme/scribblings/guide/types.scrbl b/collects/typed-racket/scribblings/guide/types.scrbl similarity index 100% rename from collects/typed-scheme/scribblings/guide/types.scrbl rename to collects/typed-racket/scribblings/guide/types.scrbl diff --git a/collects/typed-scheme/scribblings/guide/varargs.scrbl b/collects/typed-racket/scribblings/guide/varargs.scrbl similarity index 100% rename from collects/typed-scheme/scribblings/guide/varargs.scrbl rename to collects/typed-racket/scribblings/guide/varargs.scrbl diff --git a/collects/typed-scheme/scribblings/reference/compatibility-languages.scrbl b/collects/typed-racket/scribblings/reference/compatibility-languages.scrbl similarity index 83% rename from collects/typed-scheme/scribblings/reference/compatibility-languages.scrbl rename to collects/typed-racket/scribblings/reference/compatibility-languages.scrbl index 7428ccce24..d8969825a1 100644 --- a/collects/typed-scheme/scribblings/reference/compatibility-languages.scrbl +++ b/collects/typed-racket/scribblings/reference/compatibility-languages.scrbl @@ -12,11 +12,11 @@ languages. The @racketmod[typed-scheme] language is equivalent to the @(declare-exporting typed/scheme/base typed/scheme typed-scheme #:use-sources - (typed-scheme/typed-scheme - typed-scheme/base-env/prims - typed-scheme/base-env/extra-procs - typed-scheme/base-env/base-types - typed-scheme/base-env/base-types-extra)) + (typed-racket/typed-racket + typed-racket/base-env/prims + typed-racket/base-env/extra-procs + typed-racket/base-env/base-types + typed-racket/base-env/base-types-extra)) @(define-syntax-rule (def-racket rts rt) (begin diff --git a/collects/typed-scheme/scribblings/reference/experimental.scrbl b/collects/typed-racket/scribblings/reference/experimental.scrbl similarity index 100% rename from collects/typed-scheme/scribblings/reference/experimental.scrbl rename to collects/typed-racket/scribblings/reference/experimental.scrbl diff --git a/collects/typed-scheme/scribblings/reference/legacy.scrbl b/collects/typed-racket/scribblings/reference/legacy.scrbl similarity index 100% rename from collects/typed-scheme/scribblings/reference/legacy.scrbl rename to collects/typed-racket/scribblings/reference/legacy.scrbl diff --git a/collects/typed-scheme/scribblings/reference/libraries.scrbl b/collects/typed-racket/scribblings/reference/libraries.scrbl similarity index 100% rename from collects/typed-scheme/scribblings/reference/libraries.scrbl rename to collects/typed-racket/scribblings/reference/libraries.scrbl diff --git a/collects/typed-scheme/scribblings/reference/no-check.scrbl b/collects/typed-racket/scribblings/reference/no-check.scrbl similarity index 100% rename from collects/typed-scheme/scribblings/reference/no-check.scrbl rename to collects/typed-racket/scribblings/reference/no-check.scrbl diff --git a/collects/typed-scheme/scribblings/reference/optimization.scrbl b/collects/typed-racket/scribblings/reference/optimization.scrbl similarity index 91% rename from collects/typed-scheme/scribblings/reference/optimization.scrbl rename to collects/typed-racket/scribblings/reference/optimization.scrbl index e4b459e8a0..7a3c0429ee 100644 --- a/collects/typed-scheme/scribblings/reference/optimization.scrbl +++ b/collects/typed-racket/scribblings/reference/optimization.scrbl @@ -7,7 +7,7 @@ @note{ See -@secref[#:doc '(lib "typed-scheme/scribblings/ts-guide.scrbl")]{optimization} +@secref[#:doc '(lib "typed-racket/scribblings/ts-guide.scrbl")]{optimization} in the guide for tips to get the most out of the optimizer. } diff --git a/collects/typed-scheme/scribblings/reference/special-forms.scrbl b/collects/typed-racket/scribblings/reference/special-forms.scrbl similarity index 100% rename from collects/typed-scheme/scribblings/reference/special-forms.scrbl rename to collects/typed-racket/scribblings/reference/special-forms.scrbl diff --git a/collects/typed-scheme/scribblings/reference/typed-regions.scrbl b/collects/typed-racket/scribblings/reference/typed-regions.scrbl similarity index 100% rename from collects/typed-scheme/scribblings/reference/typed-regions.scrbl rename to collects/typed-racket/scribblings/reference/typed-regions.scrbl diff --git a/collects/typed-scheme/scribblings/reference/types.scrbl b/collects/typed-racket/scribblings/reference/types.scrbl similarity index 100% rename from collects/typed-scheme/scribblings/reference/types.scrbl rename to collects/typed-racket/scribblings/reference/types.scrbl diff --git a/collects/typed-scheme/scribblings/reference/utilities.scrbl b/collects/typed-racket/scribblings/reference/utilities.scrbl similarity index 100% rename from collects/typed-scheme/scribblings/reference/utilities.scrbl rename to collects/typed-racket/scribblings/reference/utilities.scrbl diff --git a/collects/typed-scheme/scribblings/ts-guide.scrbl b/collects/typed-racket/scribblings/ts-guide.scrbl similarity index 100% rename from collects/typed-scheme/scribblings/ts-guide.scrbl rename to collects/typed-racket/scribblings/ts-guide.scrbl diff --git a/collects/typed-scheme/scribblings/ts-reference.scrbl b/collects/typed-racket/scribblings/ts-reference.scrbl similarity index 75% rename from collects/typed-scheme/scribblings/ts-reference.scrbl rename to collects/typed-racket/scribblings/ts-reference.scrbl index 83ab1c843c..0f1f6ebc1b 100644 --- a/collects/typed-scheme/scribblings/ts-reference.scrbl +++ b/collects/typed-racket/scribblings/ts-reference.scrbl @@ -7,11 +7,11 @@ @(defmodulelang* (typed/racket/base typed/racket) #:use-sources - (typed-scheme/typed-scheme - typed-scheme/base-env/prims - typed-scheme/base-env/extra-procs - typed-scheme/base-env/base-types - typed-scheme/base-env/base-types-extra)) + (typed-racket/typed-racket + typed-racket/base-env/prims + typed-racket/base-env/extra-procs + typed-racket/base-env/base-types + typed-racket/base-env/base-types-extra)) @local-table-of-contents[] diff --git a/collects/typed-scheme/scribblings/utils.rkt b/collects/typed-racket/scribblings/utils.rkt similarity index 100% rename from collects/typed-scheme/scribblings/utils.rkt rename to collects/typed-racket/scribblings/utils.rkt diff --git a/collects/typed-scheme/tc-setup.rkt b/collects/typed-racket/tc-setup.rkt similarity index 98% rename from collects/typed-scheme/tc-setup.rkt rename to collects/typed-racket/tc-setup.rkt index 2fb9dbf4c2..5d67fa2246 100644 --- a/collects/typed-scheme/tc-setup.rkt +++ b/collects/typed-racket/tc-setup.rkt @@ -27,7 +27,7 @@ ;; do we optimize? (if (optimize?) (let ([optimize-top - (begin0 (dynamic-require 'typed-scheme/optimizer/optimizer + (begin0 (dynamic-require 'typed-racket/optimizer/optimizer 'optimize-top) (do-time "Loading optimizer"))]) (begin0 (map optimize-top (syntax->list body)) diff --git a/collects/typed-scheme/typecheck/check-below.rkt b/collects/typed-racket/typecheck/check-below.rkt similarity index 100% rename from collects/typed-scheme/typecheck/check-below.rkt rename to collects/typed-racket/typecheck/check-below.rkt diff --git a/collects/typed-scheme/typecheck/check-subforms-unit.rkt b/collects/typed-racket/typecheck/check-subforms-unit.rkt similarity index 100% rename from collects/typed-scheme/typecheck/check-subforms-unit.rkt rename to collects/typed-racket/typecheck/check-subforms-unit.rkt diff --git a/collects/typed-scheme/typecheck/def-binding.rkt b/collects/typed-racket/typecheck/def-binding.rkt similarity index 100% rename from collects/typed-scheme/typecheck/def-binding.rkt rename to collects/typed-racket/typecheck/def-binding.rkt diff --git a/collects/typed-scheme/typecheck/def-export.rkt b/collects/typed-racket/typecheck/def-export.rkt similarity index 100% rename from collects/typed-scheme/typecheck/def-export.rkt rename to collects/typed-racket/typecheck/def-export.rkt diff --git a/collects/typed-scheme/typecheck/find-annotation.rkt b/collects/typed-racket/typecheck/find-annotation.rkt similarity index 100% rename from collects/typed-scheme/typecheck/find-annotation.rkt rename to collects/typed-racket/typecheck/find-annotation.rkt diff --git a/collects/typed-scheme/typecheck/internal-forms.rkt b/collects/typed-racket/typecheck/internal-forms.rkt similarity index 100% rename from collects/typed-scheme/typecheck/internal-forms.rkt rename to collects/typed-racket/typecheck/internal-forms.rkt diff --git a/collects/typed-scheme/typecheck/parse-cl.rkt b/collects/typed-racket/typecheck/parse-cl.rkt similarity index 100% rename from collects/typed-scheme/typecheck/parse-cl.rkt rename to collects/typed-racket/typecheck/parse-cl.rkt diff --git a/collects/typed-scheme/typecheck/provide-handling.rkt b/collects/typed-racket/typecheck/provide-handling.rkt similarity index 100% rename from collects/typed-scheme/typecheck/provide-handling.rkt rename to collects/typed-racket/typecheck/provide-handling.rkt diff --git a/collects/typed-scheme/typecheck/renamer.rkt b/collects/typed-racket/typecheck/renamer.rkt similarity index 100% rename from collects/typed-scheme/typecheck/renamer.rkt rename to collects/typed-racket/typecheck/renamer.rkt diff --git a/collects/typed-scheme/typecheck/signatures.rkt b/collects/typed-racket/typecheck/signatures.rkt similarity index 100% rename from collects/typed-scheme/typecheck/signatures.rkt rename to collects/typed-racket/typecheck/signatures.rkt diff --git a/collects/typed-scheme/typecheck/tc-app-helper.rkt b/collects/typed-racket/typecheck/tc-app-helper.rkt similarity index 100% rename from collects/typed-scheme/typecheck/tc-app-helper.rkt rename to collects/typed-racket/typecheck/tc-app-helper.rkt diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-racket/typecheck/tc-app.rkt similarity index 100% rename from collects/typed-scheme/typecheck/tc-app.rkt rename to collects/typed-racket/typecheck/tc-app.rkt diff --git a/collects/typed-scheme/typecheck/tc-apply.rkt b/collects/typed-racket/typecheck/tc-apply.rkt similarity index 100% rename from collects/typed-scheme/typecheck/tc-apply.rkt rename to collects/typed-racket/typecheck/tc-apply.rkt diff --git a/collects/typed-scheme/typecheck/tc-envops.rkt b/collects/typed-racket/typecheck/tc-envops.rkt similarity index 100% rename from collects/typed-scheme/typecheck/tc-envops.rkt rename to collects/typed-racket/typecheck/tc-envops.rkt diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.rkt b/collects/typed-racket/typecheck/tc-expr-unit.rkt similarity index 100% rename from collects/typed-scheme/typecheck/tc-expr-unit.rkt rename to collects/typed-racket/typecheck/tc-expr-unit.rkt diff --git a/collects/typed-scheme/typecheck/tc-funapp.rkt b/collects/typed-racket/typecheck/tc-funapp.rkt similarity index 100% rename from collects/typed-scheme/typecheck/tc-funapp.rkt rename to collects/typed-racket/typecheck/tc-funapp.rkt diff --git a/collects/typed-scheme/typecheck/tc-if.rkt b/collects/typed-racket/typecheck/tc-if.rkt similarity index 100% rename from collects/typed-scheme/typecheck/tc-if.rkt rename to collects/typed-racket/typecheck/tc-if.rkt diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.rkt b/collects/typed-racket/typecheck/tc-lambda-unit.rkt similarity index 100% rename from collects/typed-scheme/typecheck/tc-lambda-unit.rkt rename to collects/typed-racket/typecheck/tc-lambda-unit.rkt diff --git a/collects/typed-scheme/typecheck/tc-let-unit.rkt b/collects/typed-racket/typecheck/tc-let-unit.rkt similarity index 100% rename from collects/typed-scheme/typecheck/tc-let-unit.rkt rename to collects/typed-racket/typecheck/tc-let-unit.rkt diff --git a/collects/typed-scheme/typecheck/tc-metafunctions.rkt b/collects/typed-racket/typecheck/tc-metafunctions.rkt similarity index 100% rename from collects/typed-scheme/typecheck/tc-metafunctions.rkt rename to collects/typed-racket/typecheck/tc-metafunctions.rkt diff --git a/collects/typed-scheme/typecheck/tc-structs.rkt b/collects/typed-racket/typecheck/tc-structs.rkt similarity index 100% rename from collects/typed-scheme/typecheck/tc-structs.rkt rename to collects/typed-racket/typecheck/tc-structs.rkt diff --git a/collects/typed-scheme/typecheck/tc-subst.rkt b/collects/typed-racket/typecheck/tc-subst.rkt similarity index 100% rename from collects/typed-scheme/typecheck/tc-subst.rkt rename to collects/typed-racket/typecheck/tc-subst.rkt diff --git a/collects/typed-scheme/typecheck/tc-toplevel.rkt b/collects/typed-racket/typecheck/tc-toplevel.rkt similarity index 100% rename from collects/typed-scheme/typecheck/tc-toplevel.rkt rename to collects/typed-racket/typecheck/tc-toplevel.rkt diff --git a/collects/typed-scheme/typecheck/typechecker.rkt b/collects/typed-racket/typecheck/typechecker.rkt similarity index 100% rename from collects/typed-scheme/typecheck/typechecker.rkt rename to collects/typed-racket/typecheck/typechecker.rkt diff --git a/collects/typed-scheme/typed-scheme.rkt b/collects/typed-racket/typed-racket.rkt similarity index 78% rename from collects/typed-scheme/typed-scheme.rkt rename to collects/typed-racket/typed-racket.rkt index f0e8165d7a..0724da95e3 100644 --- a/collects/typed-scheme/typed-scheme.rkt +++ b/collects/typed-racket/typed-racket.rkt @@ -19,15 +19,15 @@ (define-for-syntax (do-standard-inits) (unless initialized (do-time "Starting initialization") - ((dynamic-require 'typed-scheme/base-env/base-structs 'initialize-structs)) + ((dynamic-require 'typed-racket/base-env/base-structs 'initialize-structs)) (do-time "Finshed base-structs") - ((dynamic-require 'typed-scheme/base-env/base-env-indexing 'initialize-indexing)) + ((dynamic-require 'typed-racket/base-env/base-env-indexing 'initialize-indexing)) (do-time "Finshed base-env-indexing") - ((dynamic-require 'typed-scheme/base-env/base-env 'init)) + ((dynamic-require 'typed-racket/base-env/base-env 'init)) (do-time "Finshed base-env") - ((dynamic-require 'typed-scheme/base-env/base-env-numeric 'init)) + ((dynamic-require 'typed-racket/base-env/base-env-numeric 'init)) (do-time "Finshed base-env-numeric") - ((dynamic-require 'typed-scheme/base-env/base-special-env 'initialize-special)) + ((dynamic-require 'typed-racket/base-env/base-special-env 'initialize-special)) (do-time "Finished base-special-env") (set! initialized #t))) @@ -36,7 +36,7 @@ (define-syntax (name stx) (do-time (format "Calling ~a driver" 'name)) (do-standard-inits) - (define f (dynamic-require 'typed-scheme/core 'sym)) + (define f (dynamic-require 'typed-racket/core 'sym)) (do-time (format "Loaded core ~a" 'sym)) (begin0 (f stx) (do-time "Finished, returning to Racket"))) diff --git a/collects/typed-scheme/typed-reader.rkt b/collects/typed-racket/typed-reader.rkt similarity index 100% rename from collects/typed-scheme/typed-reader.rkt rename to collects/typed-racket/typed-reader.rkt diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-racket/types/abbrev.rkt similarity index 100% rename from collects/typed-scheme/types/abbrev.rkt rename to collects/typed-racket/types/abbrev.rkt diff --git a/collects/typed-scheme/types/comparison.rkt b/collects/typed-racket/types/comparison.rkt similarity index 100% rename from collects/typed-scheme/types/comparison.rkt rename to collects/typed-racket/types/comparison.rkt diff --git a/collects/typed-scheme/types/convenience.rkt b/collects/typed-racket/types/convenience.rkt similarity index 100% rename from collects/typed-scheme/types/convenience.rkt rename to collects/typed-racket/types/convenience.rkt diff --git a/collects/typed-scheme/types/filter-ops.rkt b/collects/typed-racket/types/filter-ops.rkt similarity index 100% rename from collects/typed-scheme/types/filter-ops.rkt rename to collects/typed-racket/types/filter-ops.rkt diff --git a/collects/typed-scheme/types/numeric-predicates.rkt b/collects/typed-racket/types/numeric-predicates.rkt similarity index 100% rename from collects/typed-scheme/types/numeric-predicates.rkt rename to collects/typed-racket/types/numeric-predicates.rkt diff --git a/collects/typed-scheme/types/numeric-tower.rkt b/collects/typed-racket/types/numeric-tower.rkt similarity index 100% rename from collects/typed-scheme/types/numeric-tower.rkt rename to collects/typed-racket/types/numeric-tower.rkt diff --git a/collects/typed-scheme/types/printer.rkt b/collects/typed-racket/types/printer.rkt similarity index 100% rename from collects/typed-scheme/types/printer.rkt rename to collects/typed-racket/types/printer.rkt diff --git a/collects/typed-scheme/types/remove-intersect.rkt b/collects/typed-racket/types/remove-intersect.rkt similarity index 100% rename from collects/typed-scheme/types/remove-intersect.rkt rename to collects/typed-racket/types/remove-intersect.rkt diff --git a/collects/typed-scheme/types/resolve.rkt b/collects/typed-racket/types/resolve.rkt similarity index 100% rename from collects/typed-scheme/types/resolve.rkt rename to collects/typed-racket/types/resolve.rkt diff --git a/collects/typed-scheme/types/substitute.rkt b/collects/typed-racket/types/substitute.rkt similarity index 100% rename from collects/typed-scheme/types/substitute.rkt rename to collects/typed-racket/types/substitute.rkt diff --git a/collects/typed-scheme/types/subtype.rkt b/collects/typed-racket/types/subtype.rkt similarity index 100% rename from collects/typed-scheme/types/subtype.rkt rename to collects/typed-racket/types/subtype.rkt diff --git a/collects/typed-scheme/types/type-table.rkt b/collects/typed-racket/types/type-table.rkt similarity index 100% rename from collects/typed-scheme/types/type-table.rkt rename to collects/typed-racket/types/type-table.rkt diff --git a/collects/typed-scheme/types/union.rkt b/collects/typed-racket/types/union.rkt similarity index 100% rename from collects/typed-scheme/types/union.rkt rename to collects/typed-racket/types/union.rkt diff --git a/collects/typed-scheme/types/utils.rkt b/collects/typed-racket/types/utils.rkt similarity index 100% rename from collects/typed-scheme/types/utils.rkt rename to collects/typed-racket/types/utils.rkt diff --git a/collects/typed-scheme/utils/any-wrap.rkt b/collects/typed-racket/utils/any-wrap.rkt similarity index 100% rename from collects/typed-scheme/utils/any-wrap.rkt rename to collects/typed-racket/utils/any-wrap.rkt diff --git a/collects/typed-scheme/utils/arm.rkt b/collects/typed-racket/utils/arm.rkt similarity index 100% rename from collects/typed-scheme/utils/arm.rkt rename to collects/typed-racket/utils/arm.rkt diff --git a/collects/typed-scheme/utils/disarm.rkt b/collects/typed-racket/utils/disarm.rkt similarity index 100% rename from collects/typed-scheme/utils/disarm.rkt rename to collects/typed-racket/utils/disarm.rkt diff --git a/collects/typed-scheme/utils/require-contract.rkt b/collects/typed-racket/utils/require-contract.rkt similarity index 100% rename from collects/typed-scheme/utils/require-contract.rkt rename to collects/typed-racket/utils/require-contract.rkt diff --git a/collects/typed-scheme/utils/stxclass-util.rkt b/collects/typed-racket/utils/stxclass-util.rkt similarity index 100% rename from collects/typed-scheme/utils/stxclass-util.rkt rename to collects/typed-racket/utils/stxclass-util.rkt diff --git a/collects/typed-scheme/utils/syntax-traversal.rkt b/collects/typed-racket/utils/syntax-traversal.rkt similarity index 100% rename from collects/typed-scheme/utils/syntax-traversal.rkt rename to collects/typed-racket/utils/syntax-traversal.rkt diff --git a/collects/typed-scheme/utils/tc-utils.rkt b/collects/typed-racket/utils/tc-utils.rkt similarity index 100% rename from collects/typed-scheme/utils/tc-utils.rkt rename to collects/typed-racket/utils/tc-utils.rkt diff --git a/collects/typed-scheme/utils/utils.rkt b/collects/typed-racket/utils/utils.rkt similarity index 99% rename from collects/typed-scheme/utils/utils.rkt rename to collects/typed-racket/utils/utils.rkt index d1f078ad80..99d70f2a3e 100644 --- a/collects/typed-scheme/utils/utils.rkt +++ b/collects/typed-racket/utils/utils.rkt @@ -53,7 +53,7 @@ at least theoretically. ,(datum->syntax #f (string-join - (list "typed-scheme" + (list "typed-racket" (symbol->string (syntax-e #'nm)) (string-append (symbol->string (syntax-e id)) ".rkt")) "/") @@ -74,7 +74,7 @@ at least theoretically. ,(datum->syntax #f (string-join - (list "typed-scheme" + (list "typed-racket" (symbol->string (syntax-e #'nm)) (string-append (symbol->string (syntax-e id)) ".rkt")) "/") diff --git a/collects/typed-scheme/lang/reader.rkt b/collects/typed-scheme/lang/reader.rkt index b00d3a3b75..928ebc4cb8 100644 --- a/collects/typed-scheme/lang/reader.rkt +++ b/collects/typed-scheme/lang/reader.rkt @@ -6,11 +6,11 @@ typed-scheme #:read-syntax r:read-syntax #:info make-info -(require (prefix-in r: "../typed-reader.rkt")) +(require (prefix-in r: typed-racket/typed-reader)) (define (make-info key default use-default) (case key [(drscheme:toolbar-buttons) - (list (dynamic-require 'typed-scheme/optimizer/tool/tool + (list (dynamic-require 'typed-racket/optimizer/tool/tool 'performance-report-drracket-button))] [else (use-default key default)])) diff --git a/collects/typed-scheme/main.rkt b/collects/typed-scheme/main.rkt index b10050bb10..295e469d89 100644 --- a/collects/typed-scheme/main.rkt +++ b/collects/typed-scheme/main.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme/minimal +#lang typed-racket/minimal (require typed/scheme/base) (provide (all-from-out typed/scheme/base)) diff --git a/collects/typed-scheme/no-check.rkt b/collects/typed-scheme/no-check.rkt index 1d0f8486f4..52647ae4a1 100644 --- a/collects/typed-scheme/no-check.rkt +++ b/collects/typed-scheme/no-check.rkt @@ -1,13 +1,14 @@ #lang scheme/base (require - (except-in "base-env/prims.rkt" + (except-in typed-racket/base-env/prims require/typed require/opaque-type require-typed-struct) - "base-env/base-types-extra.rkt" + typed-racket/base-env/base-types-extra (for-syntax scheme/base syntax/parse syntax/struct)) (provide (all-from-out scheme/base) (all-defined-out) - (all-from-out "base-env/prims.rkt" "base-env/base-types-extra.rkt")) + (all-from-out typed-racket/base-env/prims + typed-racket/base-env/base-types-extra)) (define-syntax (require/typed stx) diff --git a/collects/typed-scheme/no-check/lang/reader.rkt b/collects/typed-scheme/no-check/lang/reader.rkt index 9448bbaf5b..744ec50d0c 100644 --- a/collects/typed-scheme/no-check/lang/reader.rkt +++ b/collects/typed-scheme/no-check/lang/reader.rkt @@ -5,4 +5,4 @@ typed-scheme/no-check #:read r:read #:read-syntax r:read-syntax -(require (prefix-in r: typed-scheme/typed-reader)) +(require (prefix-in r: typed-racket/typed-reader)) diff --git a/collects/typed/racket.rkt b/collects/typed/racket.rkt index f108282f35..85047c7bff 100644 --- a/collects/typed/racket.rkt +++ b/collects/typed/racket.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme/minimal +#lang typed-racket/minimal (require typed/racket/base racket/require (subtract-in racket typed/racket/base racket/contract) (for-syntax racket/base)) diff --git a/collects/typed/racket/base.rkt b/collects/typed/racket/base.rkt index 24926cc601..860ebfa9ac 100644 --- a/collects/typed/racket/base.rkt +++ b/collects/typed/racket/base.rkt @@ -1,18 +1,18 @@ -#lang typed-scheme/minimal +#lang typed-racket/minimal (providing (libs (except racket/base #%module-begin #%top-interaction with-handlers lambda #%app define-struct for for*)) (basics #%module-begin #%top-interaction lambda #%app)) -(require typed-scheme/base-env/extra-procs - (except-in typed-scheme/base-env/prims +(require typed-racket/base-env/extra-procs + (except-in typed-racket/base-env/prims require-typed-struct-legacy require/typed-legacy) - typed-scheme/base-env/base-types - typed-scheme/base-env/base-types-extra - (for-syntax typed-scheme/base-env/base-types-extra)) + typed-racket/base-env/base-types + typed-racket/base-env/base-types-extra + (for-syntax typed-racket/base-env/base-types-extra)) (provide (rename-out [define-type-alias define-type]) - (all-from-out typed-scheme/base-env/prims) - (all-from-out typed-scheme/base-env/base-types) - (all-from-out typed-scheme/base-env/base-types-extra) + (all-from-out typed-racket/base-env/prims) + (all-from-out typed-racket/base-env/base-types) + (all-from-out typed-racket/base-env/base-types-extra) assert defined? with-type for for* - (for-syntax (all-from-out typed-scheme/base-env/base-types-extra))) + (for-syntax (all-from-out typed-racket/base-env/base-types-extra))) diff --git a/collects/typed/racket/base/lang/reader.rkt b/collects/typed/racket/base/lang/reader.rkt index 956259de88..849ff945b1 100644 --- a/collects/typed/racket/base/lang/reader.rkt +++ b/collects/typed/racket/base/lang/reader.rkt @@ -12,7 +12,7 @@ typed/racket/base [else (use-default key default)])) (define make-language-info - `#(typed-scheme/language-info get-info ())) + `#(typed-racket/language-info get-info ())) -(require (prefix-in r: typed-scheme/typed-reader)) +(require (prefix-in r: typed-racket/typed-reader)) diff --git a/collects/typed/racket/lang/reader.rkt b/collects/typed/racket/lang/reader.rkt index bce2cd00e8..456c2a6340 100644 --- a/collects/typed/racket/lang/reader.rkt +++ b/collects/typed/racket/lang/reader.rkt @@ -10,12 +10,12 @@ typed/racket (define (make-info key default use-default) (case key [(drscheme:toolbar-buttons) - (list (dynamic-require 'typed-scheme/optimizer/tool/tool + (list (dynamic-require 'typed-racket/optimizer/tool/tool 'performance-report-drracket-button))] [else (use-default key default)])) (define make-language-info - `#(typed-scheme/language-info get-info ())) + `#(typed-racket/language-info get-info ())) -(require (prefix-in r: typed-scheme/typed-reader)) +(require (prefix-in r: typed-racket/typed-reader)) diff --git a/collects/typed/racket/no-check/lang/reader.rkt b/collects/typed/racket/no-check/lang/reader.rkt index 7d16e8048a..0f9a2271b8 100644 --- a/collects/typed/racket/no-check/lang/reader.rkt +++ b/collects/typed/racket/no-check/lang/reader.rkt @@ -5,4 +5,4 @@ typed/racket/no-check #:read r:read #:read-syntax r:read-syntax -(require (prefix-in r: typed-scheme/typed-reader)) +(require (prefix-in r: typed-racket/typed-reader)) diff --git a/collects/typed/rackunit/type-env-ext.rkt b/collects/typed/rackunit/type-env-ext.rkt index c73b6b4cd0..e65f6a8974 100644 --- a/collects/typed/rackunit/type-env-ext.rkt +++ b/collects/typed/rackunit/type-env-ext.rkt @@ -1,6 +1,6 @@ #lang scheme/base -(require typed-scheme/utils/utils +(require typed-racket/utils/utils (prefix-in ru: (combine-in rackunit rackunit/private/test-case rackunit/private/check)) (for-syntax scheme/base syntax/parse diff --git a/collects/typed/scheme.rkt b/collects/typed/scheme.rkt index aa4c4d9dd9..b300589a39 100644 --- a/collects/typed/scheme.rkt +++ b/collects/typed/scheme.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme/minimal +#lang typed-racket/minimal (require typed/scheme/base scheme/require (subtract-in scheme typed/scheme/base scheme/contract) (for-syntax scheme/base)) diff --git a/collects/typed/scheme/base.rkt b/collects/typed/scheme/base.rkt index 7fa96debd7..6dd51f2f5b 100644 --- a/collects/typed/scheme/base.rkt +++ b/collects/typed/scheme/base.rkt @@ -1,21 +1,21 @@ -#lang typed-scheme/minimal +#lang typed-racket/minimal (providing (libs (except scheme/base #%module-begin #%top-interaction with-handlers lambda #%app define-struct for for*)) (basics #%module-begin #%top-interaction lambda #%app)) -(require typed-scheme/base-env/extra-procs +(require typed-racket/base-env/extra-procs (rename-in - (except-in typed-scheme/base-env/prims + (except-in typed-racket/base-env/prims require-typed-struct require/typed) (require-typed-struct-legacy require-typed-struct) (require/typed-legacy require/typed)) - typed-scheme/base-env/base-types - typed-scheme/base-env/base-types-extra - (for-syntax typed-scheme/base-env/base-types-extra)) + typed-racket/base-env/base-types + typed-racket/base-env/base-types-extra + (for-syntax typed-racket/base-env/base-types-extra)) (provide (rename-out [define-type-alias define-type]) - (all-from-out typed-scheme/base-env/prims) - (all-from-out typed-scheme/base-env/base-types) - (all-from-out typed-scheme/base-env/base-types-extra) + (all-from-out typed-racket/base-env/prims) + (all-from-out typed-racket/base-env/base-types) + (all-from-out typed-racket/base-env/base-types-extra) assert defined? with-type for for* - (for-syntax (all-from-out typed-scheme/base-env/base-types-extra))) + (for-syntax (all-from-out typed-racket/base-env/base-types-extra))) diff --git a/collects/typed/scheme/base/lang/reader.rkt b/collects/typed/scheme/base/lang/reader.rkt index b098289086..6da86b0d5f 100644 --- a/collects/typed/scheme/base/lang/reader.rkt +++ b/collects/typed/scheme/base/lang/reader.rkt @@ -12,7 +12,7 @@ typed/scheme/base [else (use-default key default)])) (define make-language-info - `#(typed-scheme/language-info get-info ())) + `#(typed-racket/language-info get-info ())) -(require (prefix-in r: typed-scheme/typed-reader)) +(require (prefix-in r: typed-racket/typed-reader)) diff --git a/collects/typed/scheme/lang/reader.rkt b/collects/typed/scheme/lang/reader.rkt index 16197bc2a2..be96569bf3 100644 --- a/collects/typed/scheme/lang/reader.rkt +++ b/collects/typed/scheme/lang/reader.rkt @@ -10,12 +10,12 @@ typed/scheme (define (make-info key default use-default) (case key [(drscheme:toolbar-buttons) - (list (dynamic-require 'typed-scheme/optimizer/tool/tool + (list (dynamic-require 'typed-racket/optimizer/tool/tool 'performance-report-drracket-button))] [else (use-default key default)])) (define make-language-info - `#(typed-scheme/language-info get-info ())) + `#(typed-racket/language-info get-info ())) -(require (prefix-in r: typed-scheme/typed-reader)) +(require (prefix-in r: typed-racket/typed-reader)) diff --git a/collects/typed/test-engine/type-env-ext.rkt b/collects/typed/test-engine/type-env-ext.rkt index cff027a220..213468444a 100644 --- a/collects/typed/test-engine/type-env-ext.rkt +++ b/collects/typed/test-engine/type-env-ext.rkt @@ -1,9 +1,9 @@ -#lang scheme/base +#lang racket/base -(require typed-scheme/utils/utils +(require typed-racket/utils/utils (prefix-in ce: test-engine/racket-tests) (for-syntax - scheme/base syntax/parse + racket/base syntax/parse (utils tc-utils) (env init-envs) (except-in (rep filter-rep object-rep type-rep) make-arr) From a134ec73ed7f397eccc289f9163acd81c4553f0e Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 30 Aug 2011 18:00:48 -0400 Subject: [PATCH 113/235] Re-enable timing --- collects/typed-racket/utils/utils.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-racket/utils/utils.rkt b/collects/typed-racket/utils/utils.rkt index 99d70f2a3e..3ceb15facf 100644 --- a/collects/typed-racket/utils/utils.rkt +++ b/collects/typed-racket/utils/utils.rkt @@ -111,7 +111,7 @@ at least theoretically. #'(void))) ;; some macros to do some timing, only when `timing?' is #t -(define-for-syntax timing? #f) +(define-for-syntax timing? #t) (define last-time #f) (define initial-time #f) (define (set!-initial-time t) (set! initial-time t)) From ff1776e5224dfcb1d8c864d7d3e22f35deec53ad Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 3 Sep 2011 20:51:35 -0400 Subject: [PATCH 114/235] Revert "Re-enable timing" This reverts commit a134ec73ed7f397eccc289f9163acd81c4553f0e. --- collects/typed-racket/utils/utils.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-racket/utils/utils.rkt b/collects/typed-racket/utils/utils.rkt index 3ceb15facf..99d70f2a3e 100644 --- a/collects/typed-racket/utils/utils.rkt +++ b/collects/typed-racket/utils/utils.rkt @@ -111,7 +111,7 @@ at least theoretically. #'(void))) ;; some macros to do some timing, only when `timing?' is #t -(define-for-syntax timing? #t) +(define-for-syntax timing? #f) (define last-time #f) (define initial-time #f) (define (set!-initial-time t) (set! initial-time t)) From 4aeec8f0614b79ffd03173d60e8984b26f3a3ef0 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 3 Sep 2011 22:44:48 -0400 Subject: [PATCH 115/235] Update props for typed-scheme -> typed-racket conversion. --- collects/meta/props | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/collects/meta/props b/collects/meta/props index ba8a94c103..1e9b9d75a0 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1962,15 +1962,15 @@ path/s is either such a string or a list of them. "collects/tests/syntax-color/paren-tree.rktl" drdr:command-line (racket "-f" *) "collects/tests/syntax-color/token-tree.rktl" drdr:command-line (racket "-f" *) "collects/tests/test-engine" responsible (kathyg) -"collects/tests/typed-scheme" responsible (samth stamourv) -"collects/tests/typed-scheme/fail" drdr:command-line #f -"collects/tests/typed-scheme/fail/with-type3.rkt" responsible (sstrickl) -"collects/tests/typed-scheme/nightly-run.rkt" drdr:command-line #f -"collects/tests/typed-scheme/optimizer" responsible (stamourv) -"collects/tests/typed-scheme/optimizer/run.rkt" drdr:timeout 1200 -"collects/tests/typed-scheme/optimizer/transform.rkt" drdr:command-line #f -"collects/tests/typed-scheme/run.rkt" drdr:command-line (racket "-t" * "--" "--nightly") drdr:timeout 1800 -"collects/tests/typed-scheme/xfail" drdr:command-line #f +"collects/tests/typed-racket" responsible (samth stamourv) +"collects/tests/typed-racket/fail" drdr:command-line #f +"collects/tests/typed-racket/fail/with-type3.rkt" responsible (sstrickl) +"collects/tests/typed-racket/nightly-run.rkt" drdr:command-line #f +"collects/tests/typed-racket/optimizer" responsible (stamourv) +"collects/tests/typed-racket/optimizer/run.rkt" drdr:timeout 1200 +"collects/tests/typed-racket/optimizer/transform.rkt" drdr:command-line #f +"collects/tests/typed-racket/run.rkt" drdr:command-line (racket "-t" * "--" "--nightly") drdr:timeout 1800 +"collects/tests/typed-racket/xfail" drdr:command-line #f "collects/tests/units" responsible (sstrickl) "collects/tests/units/multi-mod-sigs.rktl" drdr:command-line (racket "-f" *) "collects/tests/units/test-cert.rktl" drdr:command-line (racket "-f" *) @@ -2024,9 +2024,10 @@ path/s is either such a string or a list of them. "collects/typed/mred/mred.rkt" drdr:command-line (gracket-text "-t" *) "collects/typed/rackunit" responsible (jay) "collects/typed/rackunit/gui.rkt" drdr:command-line (gracket "-t" *) +"collects/typed-racket" responsible (samth stamourv) +"collects/typed-racket/base-env/base-special-env.rkt" drdr:command-line (raco "make" *) +"collects/typed-racket/optimizer" responsible (stamourv) "collects/typed-scheme" responsible (samth stamourv) -"collects/typed-scheme/base-env/base-special-env.rkt" drdr:command-line (raco "make" *) -"collects/typed-scheme/optimizer" responsible (stamourv) "collects/unstable" responsible (jay samth cce ryanc) "collects/unstable/automata" responsible (jay) "collects/unstable/byte-counting-port.rkt" responsible (jay) From 3122e559cbd0f38e2dc1ed31010616e6d1f91a45 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 3 Sep 2011 22:46:35 -0400 Subject: [PATCH 116/235] Fix require analysis heuristics for TS -> TR. --- collects/macro-debugger/analysis/private/moduledb.rkt | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/macro-debugger/analysis/private/moduledb.rkt b/collects/macro-debugger/analysis/private/moduledb.rkt index 6ce302e7af..a15d84ac64 100644 --- a/collects/macro-debugger/analysis/private/moduledb.rkt +++ b/collects/macro-debugger/analysis/private/moduledb.rkt @@ -21,7 +21,7 @@ [racket/match no-bypass] ['#%builtin no-drop] - [typed-scheme/private/base-env no-drop] - [typed-scheme/private/base-special-env no-drop] - [typed-scheme/private/base-env-numeric no-drop] - [typed-scheme/private/base-env-indexing no-drop]))) + [typed-racket/private/base-env no-drop] + [typed-racket/private/base-special-env no-drop] + [typed-racket/private/base-env-numeric no-drop] + [typed-racket/private/base-env-indexing no-drop]))) From 0a9bc015dad87efcf66af7080b3400606268bfa3 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 4 Sep 2011 08:31:34 -0400 Subject: [PATCH 117/235] Fix one more `typed-scheme'. --- collects/typed/racket/base/no-check/lang/reader.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed/racket/base/no-check/lang/reader.rkt b/collects/typed/racket/base/no-check/lang/reader.rkt index af4b238de8..4af7c2e3be 100644 --- a/collects/typed/racket/base/no-check/lang/reader.rkt +++ b/collects/typed/racket/base/no-check/lang/reader.rkt @@ -5,4 +5,4 @@ typed/racket/base/no-check #:read r:read #:read-syntax r:read-syntax -(require (prefix-in r: typed-scheme/typed-reader)) +(require (prefix-in r: typed-racket/typed-reader)) From 1a35809ee62d5edcf2ee8cbbd7e4b9cda045f5d2 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 4 Sep 2011 08:33:44 -0400 Subject: [PATCH 118/235] Document `Nonnegative-Integer'. --- collects/typed-racket/scribblings/reference/types.scrbl | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/typed-racket/scribblings/reference/types.scrbl b/collects/typed-racket/scribblings/reference/types.scrbl index 5dce9655f1..e04658d251 100644 --- a/collects/typed-racket/scribblings/reference/types.scrbl +++ b/collects/typed-racket/scribblings/reference/types.scrbl @@ -68,6 +68,7 @@ Negative-Single-Flonum Nonnegative-Exact-Rational Nonnegative-Flonum Nonnegative-Inexact-Real +Nonnegative-Integer Nonnegative-Real Nonnegative-Single-Flonum Nonpositive-Exact-Rational From 09f515dff4f1b97eb4e80e161eb182b5fed105f9 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 4 Sep 2011 08:34:19 -0400 Subject: [PATCH 119/235] Add type for `make-reader-graph'. --- collects/typed-racket/base-env/base-env.rkt | 3 +++ 1 file changed, 3 insertions(+) diff --git a/collects/typed-racket/base-env/base-env.rkt b/collects/typed-racket/base-env/base-env.rkt index 42efb05ade..8c4d4a2ead 100644 --- a/collects/typed-racket/base-env/base-env.rkt +++ b/collects/typed-racket/base-env/base-env.rkt @@ -2473,3 +2473,6 @@ [will-register (-poly (a) (-> -Will-Executor a (-> a ManyUniv) -Void))] [will-execute (-> -Will-Executor ManyUniv)] [will-try-execute (-> -Will-Executor ManyUniv)] + +;; reader graphs +[make-reader-graph (-> Univ Univ)] \ No newline at end of file From e1c095e2fbea7743f1669b93ae193657710a6d9d Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 4 Sep 2011 08:25:24 -0400 Subject: [PATCH 120/235] Update dist-specs for "typed-scheme" -> "typed-racket". --- collects/meta/dist-specs.rkt | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/meta/dist-specs.rkt b/collects/meta/dist-specs.rkt index f2925f5953..556ba2ffd4 100644 --- a/collects/meta/dist-specs.rkt +++ b/collects/meta/dist-specs.rkt @@ -628,14 +628,14 @@ plt-extras :+= (collects: "texpict/") ;; -------------------- frtime plt-extras :+= (package: "frtime/") -;; -------------------- typed-scheme -dr-extras :+= (package: "typed-scheme/" ; used in drracket +;; -------------------- typed-racket +dr-extras :+= (package: "typed-racket/" ; used in drracket #:docs "ts-{reference|guide}/") - (package: "typed-racket") (- (collects: "typed/") (cond (not plt) => (collects: "typed/test-engine/") (collects: "typed/rackunit/") (srcfile: "typed/rackunit.rkt"))) + (collects: "typed-scheme") ; compatibility ;; -------------------- gui-debugger plt-extras :+= (collects: "gui-debugger/") From 49a89da81860e09955f1678bab6106ce8eae8376 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 4 Sep 2011 08:45:54 -0400 Subject: [PATCH 121/235] Abolish "typed-scheme". --- collects/drracket/private/auto-language.rkt | 6 +- collects/honu/core/main.rkt | 6 +- collects/honu/core/private/canonical.rkt | 2 +- ...typed-scheme.rkt => honu-typed-racket.rkt} | 2 +- collects/honu/core/private/macro.rkt | 4 +- collects/honu/core/private/more.rkt | 4 +- .../analysis/check-requires.rkt | 2 +- collects/tests/honu/test.rkt | 2 +- .../tests/macro-debugger/tests/collects.rkt | 112 +++++++++--------- .../tests/macro-debugger/tests/regression.rkt | 2 +- .../typed-racket/fail/all-bad-syntax.rkt | 2 +- .../tests/typed-racket/fail/ann-map-funcs.rkt | 2 +- .../tests/typed-racket/fail/apply-dots.rkt | 2 +- collects/tests/typed-racket/fail/bad-any.rkt | 2 +- .../tests/typed-racket/fail/bad-first.rkt | 2 +- .../tests/typed-racket/fail/set-tests.rkt | 3 +- .../typed-racket/succeed/dotted-identity2.rkt | 5 +- .../typed-racket/succeed/let-values-tests.rkt | 6 +- collects/typed-racket/scribblings/utils.rkt | 2 +- collects/typed/file/gif.rkt | 2 +- collects/typed/file/md5.rkt | 2 +- collects/typed/file/tar.rkt | 4 +- collects/typed/framework/framework.rkt | 2 +- collects/typed/net/base64.rkt | 2 +- collects/typed/net/cgi.rkt | 2 +- collects/typed/net/cookie.rkt | 2 +- collects/typed/net/dns.rkt | 3 +- collects/typed/net/ftp.rkt | 2 +- collects/typed/net/gifwrite.rkt | 2 +- collects/typed/net/head.rkt | 2 +- collects/typed/net/imap.rkt | 2 +- collects/typed/net/mime.rkt | 2 +- collects/typed/net/nntp.rkt | 2 +- collects/typed/net/pop3.rkt | 2 +- collects/typed/net/qp.rkt | 2 +- collects/typed/net/sendmail.rkt | 2 +- collects/typed/net/sendurl.rkt | 2 +- collects/typed/net/smtp.rkt | 2 +- collects/typed/net/uri-codec.rkt | 2 +- collects/typed/net/url.rkt | 2 +- collects/typed/private/utils.rkt | 2 +- collects/typed/racket/base/no-check.rkt | 5 +- collects/typed/racket/no-check.rkt | 5 +- collects/typed/srfi/14.rkt | 2 +- collects/typed/tests/test-docs-complete.rkt | 2 +- 45 files changed, 115 insertions(+), 114 deletions(-) rename collects/honu/core/private/{honu-typed-scheme.rkt => honu-typed-racket.rkt} (99%) diff --git a/collects/drracket/private/auto-language.rkt b/collects/drracket/private/auto-language.rkt index 35088ef977..2d887fa41c 100644 --- a/collects/drracket/private/auto-language.rkt +++ b/collects/drracket/private/auto-language.rkt @@ -1,7 +1,7 @@ -#lang typed-scheme +#lang typed-racket -(require typed/framework/framework - typed/mred/mred +(require typed/framework/framework + typed/mred/mred racket/class) (provide pick-new-language looks-like-module?) diff --git a/collects/honu/core/main.rkt b/collects/honu/core/main.rkt index 625f4a7a92..7ff950a1b9 100644 --- a/collects/honu/core/main.rkt +++ b/collects/honu/core/main.rkt @@ -1,6 +1,6 @@ #lang racket/base -(require "private/honu-typed-scheme.rkt" +(require "private/honu-typed-racket.rkt" "private/honu2.rkt" "private/macro2.rkt" (for-syntax (only-in "private/parse2.rkt" honu-expression)) @@ -51,10 +51,10 @@ (require (for-meta 2 racket/base)) (require racket/class) -(require "private/honu-typed-scheme.rkt" +(require "private/honu-typed-racket.rkt" "private/parse.rkt" (for-syntax "private/literals.rkt") - (for-syntax "private/honu-typed-scheme.rkt") + (for-syntax "private/honu-typed-racket.rkt") (for-syntax "private/parse.rkt") (for-syntax "private/canonical.rkt") syntax/parse diff --git a/collects/honu/core/private/canonical.rkt b/collects/honu/core/private/canonical.rkt index e06472e6f0..d13376021a 100644 --- a/collects/honu/core/private/canonical.rkt +++ b/collects/honu/core/private/canonical.rkt @@ -3,7 +3,7 @@ (provide (all-defined-out)) (require "literals.rkt" - (for-template "honu-typed-scheme.rkt") + (for-template "honu-typed-racket.rkt") syntax/parse) ;; syntax -> string diff --git a/collects/honu/core/private/honu-typed-scheme.rkt b/collects/honu/core/private/honu-typed-racket.rkt similarity index 99% rename from collects/honu/core/private/honu-typed-scheme.rkt rename to collects/honu/core/private/honu-typed-racket.rkt index 8e4b1fcb98..63e72eb4be 100644 --- a/collects/honu/core/private/honu-typed-scheme.rkt +++ b/collects/honu/core/private/honu-typed-racket.rkt @@ -1,6 +1,6 @@ #lang racket/base -(require (rename-in typed-scheme (#%module-begin #%module-begin-typed-scheme))) +(require (rename-in typed-racket (#%module-begin #%module-begin-typed-racket))) (require (for-syntax scheme/base syntax/stx syntax/name diff --git a/collects/honu/core/private/macro.rkt b/collects/honu/core/private/macro.rkt index ef621711e2..d26a8cf082 100644 --- a/collects/honu/core/private/macro.rkt +++ b/collects/honu/core/private/macro.rkt @@ -1,6 +1,6 @@ #lang racket/base -(require "honu-typed-scheme.rkt" +(require "honu-typed-racket.rkt" "literals.rkt" "parse.ss" "syntax.ss" @@ -16,7 +16,7 @@ "parse.rkt" "syntax.rkt" "literals.rkt" - "honu-typed-scheme.rkt" + "honu-typed-racket.rkt" racket/base syntax/parse syntax/stx diff --git a/collects/honu/core/private/more.rkt b/collects/honu/core/private/more.rkt index 4ef6f15779..5f6dd2a5dd 100644 --- a/collects/honu/core/private/more.rkt +++ b/collects/honu/core/private/more.rkt @@ -2,7 +2,7 @@ #| -(require "honu-typed-scheme.rkt" +(require "honu-typed-racket.rkt" "literals.rkt" syntax/parse mzlib/trace @@ -16,7 +16,7 @@ "syntax.rkt" (only-in racket (... scheme-ellipses)) "literals.rkt") - (for-template "honu-typed-scheme.rkt" + (for-template "honu-typed-racket.rkt" "literals.rkt" "syntax.rkt" (only-in racket ...) diff --git a/collects/macro-debugger/analysis/check-requires.rkt b/collects/macro-debugger/analysis/check-requires.rkt index 95d223299e..cfe2527a8f 100644 --- a/collects/macro-debugger/analysis/check-requires.rkt +++ b/collects/macro-debugger/analysis/check-requires.rkt @@ -26,7 +26,7 @@ Usage: Examples: - (check-requires 'typed-scheme) + (check-requires 'typed-racket) (check-requires 'unstable/markparam) (check-requires 'macro-debugger/syntax-browser/widget) diff --git a/collects/tests/honu/test.rkt b/collects/tests/honu/test.rkt index 0b53bd27ce..82440f6daa 100644 --- a/collects/tests/honu/test.rkt +++ b/collects/tests/honu/test.rkt @@ -12,7 +12,7 @@ (rename-in honu/core/private/literals [honu-= =] [semicolon |;|]) - (rename-in (only-in honu/core/private/honu-typed-scheme honu-var) + (rename-in (only-in honu/core/private/honu-typed-racket honu-var) [honu-var var]) (for-syntax racket/base honu/core/private/macro2 diff --git a/collects/tests/macro-debugger/tests/collects.rkt b/collects/tests/macro-debugger/tests/collects.rkt index ca882ecbac..a29701fd87 100644 --- a/collects/tests/macro-debugger/tests/collects.rkt +++ b/collects/tests/macro-debugger/tests/collects.rkt @@ -140,8 +140,8 @@ #:cache-keys? #t)))) (define modules-from-framework (trace-modules '(framework))) -(define modules-from-typed-scheme - #;(trace-modules '(typed-scheme)) +(define modules-from-typed-racket + #;(trace-modules '(typed-racket)) '(#| mzlib/contract mzlib/etc @@ -267,59 +267,59 @@ syntax/stx mzlib/trace |# - typed-scheme - typed-scheme/minimal - typed-scheme/private/base-env - typed-scheme/private/base-types - typed-scheme/private/check-subforms-unit - typed-scheme/private/def-binding - typed-scheme/private/effect-rep - typed-scheme/private/extra-procs - typed-scheme/private/free-variance - typed-scheme/private/infer - typed-scheme/private/infer-ops - typed-scheme/private/init-envs - typed-scheme/private/internal-forms - typed-scheme/private/interning - typed-scheme/private/lexical-env - typed-scheme/private/mutated-vars - typed-scheme/private/parse-type - typed-scheme/private/planet-requires - typed-scheme/private/prims - typed-scheme/private/provide-handling - typed-scheme/private/remove-intersect - typed-scheme/private/rep-utils - typed-scheme/private/require-contract - typed-scheme/private/resolve-type - typed-scheme/private/signatures - typed-scheme/private/subtype - typed-scheme/private/syntax-traversal - typed-scheme/private/tables - typed-scheme/private/tc-app-unit - typed-scheme/private/tc-expr-unit - typed-scheme/private/tc-if-unit - typed-scheme/private/tc-lambda-unit - typed-scheme/private/tc-let-unit - typed-scheme/private/tc-structs - typed-scheme/private/tc-toplevel - typed-scheme/private/tc-utils - typed-scheme/private/type-alias-env - typed-scheme/private/type-annotation - typed-scheme/private/type-comparison - typed-scheme/private/type-contract - typed-scheme/private/type-effect-convenience - typed-scheme/private/type-effect-printer - typed-scheme/private/type-env - typed-scheme/private/type-environments - typed-scheme/private/type-name-env - typed-scheme/private/type-rep - typed-scheme/private/type-utils - typed-scheme/private/typechecker - typed-scheme/private/unify - typed-scheme/private/union - typed-scheme/private/unit-utils - typed-scheme/private/utils - typed-scheme/typed-scheme)) + typed-racket + typed-racket/minimal + typed-racket/private/base-env + typed-racket/private/base-types + typed-racket/private/check-subforms-unit + typed-racket/private/def-binding + typed-racket/private/effect-rep + typed-racket/private/extra-procs + typed-racket/private/free-variance + typed-racket/private/infer + typed-racket/private/infer-ops + typed-racket/private/init-envs + typed-racket/private/internal-forms + typed-racket/private/interning + typed-racket/private/lexical-env + typed-racket/private/mutated-vars + typed-racket/private/parse-type + typed-racket/private/planet-requires + typed-racket/private/prims + typed-racket/private/provide-handling + typed-racket/private/remove-intersect + typed-racket/private/rep-utils + typed-racket/private/require-contract + typed-racket/private/resolve-type + typed-racket/private/signatures + typed-racket/private/subtype + typed-racket/private/syntax-traversal + typed-racket/private/tables + typed-racket/private/tc-app-unit + typed-racket/private/tc-expr-unit + typed-racket/private/tc-if-unit + typed-racket/private/tc-lambda-unit + typed-racket/private/tc-let-unit + typed-racket/private/tc-structs + typed-racket/private/tc-toplevel + typed-racket/private/tc-utils + typed-racket/private/type-alias-env + typed-racket/private/type-annotation + typed-racket/private/type-comparison + typed-racket/private/type-contract + typed-racket/private/type-effect-convenience + typed-racket/private/type-effect-printer + typed-racket/private/type-env + typed-racket/private/type-environments + typed-racket/private/type-name-env + typed-racket/private/type-rep + typed-racket/private/type-utils + typed-racket/private/typechecker + typed-racket/private/unify + typed-racket/private/union + typed-racket/private/unit-utils + typed-racket/private/utils + typed-racket/typed-racket)) (define big-libs-tests - (test-libs "Collections" modules-from-typed-scheme)) + (test-libs "Collections" modules-from-typed-racket)) diff --git a/collects/tests/macro-debugger/tests/regression.rkt b/collects/tests/macro-debugger/tests/regression.rkt index c74545951d..018936260c 100644 --- a/collects/tests/macro-debugger/tests/regression.rkt +++ b/collects/tests/macro-debugger/tests/regression.rkt @@ -144,7 +144,7 @@ (local [(define x 1)] x))))]) (check-pred list? rs))) - ;; Distilled from Sam/typed-scheme (8/24/2007) + ;; Distilled from Sam/typed-racket (8/24/2007) (test-case "transformer calls 'expand'" (check-pred deriv? (trace '(let-syntax ([m (lambda (stx) diff --git a/collects/tests/typed-racket/fail/all-bad-syntax.rkt b/collects/tests/typed-racket/fail/all-bad-syntax.rkt index daf10f545b..f07efdc753 100644 --- a/collects/tests/typed-racket/fail/all-bad-syntax.rkt +++ b/collects/tests/typed-racket/fail/all-bad-syntax.rkt @@ -1,6 +1,6 @@ #; (exn-pred 2) -#lang typed-scheme +#lang typed-racket (require scheme/list) diff --git a/collects/tests/typed-racket/fail/ann-map-funcs.rkt b/collects/tests/typed-racket/fail/ann-map-funcs.rkt index f8ba9fb486..a1598f70bc 100644 --- a/collects/tests/typed-racket/fail/ann-map-funcs.rkt +++ b/collects/tests/typed-racket/fail/ann-map-funcs.rkt @@ -1,6 +1,6 @@ #; (exn-pred 3) -#lang typed-scheme +#lang typed-racket (: map-with-funcs (All (b a ...) ((a ... a -> b) * -> (a ... a -> (Listof b))))) diff --git a/collects/tests/typed-racket/fail/apply-dots.rkt b/collects/tests/typed-racket/fail/apply-dots.rkt index fd2b031378..df0a2952e4 100644 --- a/collects/tests/typed-racket/fail/apply-dots.rkt +++ b/collects/tests/typed-racket/fail/apply-dots.rkt @@ -1,6 +1,6 @@ #; (exn-pred 2) -#lang typed-scheme +#lang typed-racket (plambda: (a ...) ([z : String] . [w : Number *]) (apply (case-lambda: (([x : Number] . [y : Number ... a]) x)) diff --git a/collects/tests/typed-racket/fail/bad-any.rkt b/collects/tests/typed-racket/fail/bad-any.rkt index 3fc5acc832..0625a5f8ab 100644 --- a/collects/tests/typed-racket/fail/bad-any.rkt +++ b/collects/tests/typed-racket/fail/bad-any.rkt @@ -2,7 +2,7 @@ (exn-pred exn:fail:contract?) #lang scheme/load -(module m typed-scheme +(module m typed-racket (: f Any) (define f (lambda: ([x : Number]) (add1 x))) (provide f)) diff --git a/collects/tests/typed-racket/fail/bad-first.rkt b/collects/tests/typed-racket/fail/bad-first.rkt index eb0fd623d3..223645b516 100644 --- a/collects/tests/typed-racket/fail/bad-first.rkt +++ b/collects/tests/typed-racket/fail/bad-first.rkt @@ -1,3 +1,3 @@ -#lang typed-scheme +#lang typed-racket (require scheme/list) (first (cons 1 2)) diff --git a/collects/tests/typed-racket/fail/set-tests.rkt b/collects/tests/typed-racket/fail/set-tests.rkt index fad4d5f408..45d022a1c4 100644 --- a/collects/tests/typed-racket/fail/set-tests.rkt +++ b/collects/tests/typed-racket/fail/set-tests.rkt @@ -1,8 +1,7 @@ ;; should FAIL! -#lang typed-scheme +#lang typed-racket (let*: ((x : Any 1) (f : (-> Void) (lambda () (set! x (quote foo))))) (if (number? x) (begin (f) (add1 x)) 12)) - diff --git a/collects/tests/typed-racket/succeed/dotted-identity2.rkt b/collects/tests/typed-racket/succeed/dotted-identity2.rkt index c00f16b91a..af5ca156cc 100644 --- a/collects/tests/typed-racket/succeed/dotted-identity2.rkt +++ b/collects/tests/typed-racket/succeed/dotted-identity2.rkt @@ -1,6 +1,7 @@ -#lang typed-scheme +#lang typed-racket -;; I don't believe the below should work, but it points out where that internal error is coming from. +;; I don't believe the below should work, but it points out where that +;; internal error is coming from. (: f (All (a ...) ((a ... a -> Integer) -> (a ... a -> Integer)))) (define (f x) x) diff --git a/collects/tests/typed-racket/succeed/let-values-tests.rkt b/collects/tests/typed-racket/succeed/let-values-tests.rkt index fe16662bc6..124619cded 100644 --- a/collects/tests/typed-racket/succeed/let-values-tests.rkt +++ b/collects/tests/typed-racket/succeed/let-values-tests.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed-racket (define-type-alias number Number) (define-type-alias boolean Boolean) (define-type-alias symbol Symbol) @@ -7,8 +7,8 @@ (let-values ([(#{x : number} #{y : number}) (values 3 4)] [(#{z : number}) (values 3)] #;[(#{fact : (number -> number)}) - (lambda: ([x : number]) - (if (zero? x) 1 (* x (fact (- x 1)))))] + (lambda: ([x : number]) + (if (zero? x) 1 (* x (fact (- x 1)))))] #;[(#{z : number}) (- x y)]) (+ x y)) diff --git a/collects/typed-racket/scribblings/utils.rkt b/collects/typed-racket/scribblings/utils.rkt index ab158a8c18..a807621488 100644 --- a/collects/typed-racket/scribblings/utils.rkt +++ b/collects/typed-racket/scribblings/utils.rkt @@ -4,7 +4,7 @@ (provide (all-defined-out)) (define (item* header . args) (apply item @bold[header]{: } args)) -(define-syntax-rule (tmod forms ...) (racketmod typed-scheme forms ...)) +(define-syntax-rule (tmod forms ...) (racketmod typed-racket forms ...)) (define (gtech . x) (apply tech x #:doc '(lib "scribblings/guide/guide.scrbl"))) (define (rtech . x) diff --git a/collects/typed/file/gif.rkt b/collects/typed/file/gif.rkt index 6f96c976d8..abbccbc840 100644 --- a/collects/typed/file/gif.rkt +++ b/collects/typed/file/gif.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed-racket (require typed/private/utils) diff --git a/collects/typed/file/md5.rkt b/collects/typed/file/md5.rkt index 0cab46d7ba..74dce83a3a 100644 --- a/collects/typed/file/md5.rkt +++ b/collects/typed/file/md5.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed-racket (require/typed file/md5 [md5 ((U Bytes Input-Port) -> Bytes)]) (provide md5) diff --git a/collects/typed/file/tar.rkt b/collects/typed/file/tar.rkt index 0497d8c9fc..5ec7086bde 100644 --- a/collects/typed/file/tar.rkt +++ b/collects/typed/file/tar.rkt @@ -1,5 +1,5 @@ -#lang typed-scheme -;; typed-scheme wrapper on file/tar +#lang typed-racket +;; typed-racket wrapper on file/tar ;; yc 2009/2/25 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/collects/typed/framework/framework.rkt b/collects/typed/framework/framework.rkt index 23f267e67b..fa7a2f9ac7 100644 --- a/collects/typed/framework/framework.rkt +++ b/collects/typed/framework/framework.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed-racket (require typed/private/utils typed/mred/mred) diff --git a/collects/typed/net/base64.rkt b/collects/typed/net/base64.rkt index 0745794516..c1090e1e18 100644 --- a/collects/typed/net/base64.rkt +++ b/collects/typed/net/base64.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed-racket (require typed/private/utils) diff --git a/collects/typed/net/cgi.rkt b/collects/typed/net/cgi.rkt index 80c3b0de55..c670549f7a 100644 --- a/collects/typed/net/cgi.rkt +++ b/collects/typed/net/cgi.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed-racket (require typed/private/utils) diff --git a/collects/typed/net/cookie.rkt b/collects/typed/net/cookie.rkt index 3eb8092adf..6eb59fe922 100644 --- a/collects/typed/net/cookie.rkt +++ b/collects/typed/net/cookie.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed-racket (require typed/private/utils) diff --git a/collects/typed/net/dns.rkt b/collects/typed/net/dns.rkt index 24ef679f81..d29ae084bd 100644 --- a/collects/typed/net/dns.rkt +++ b/collects/typed/net/dns.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed-racket (require typed/private/utils) @@ -7,4 +7,3 @@ [dns-get-name (String String -> String)] [dns-get-mail-exchanger (String String -> String )] [dns-find-nameserver (-> (Option String))]) - diff --git a/collects/typed/net/ftp.rkt b/collects/typed/net/ftp.rkt index 041befc0d5..d4e6e7e48f 100644 --- a/collects/typed/net/ftp.rkt +++ b/collects/typed/net/ftp.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed-racket (require typed/private/utils) diff --git a/collects/typed/net/gifwrite.rkt b/collects/typed/net/gifwrite.rkt index cfe9167c5b..ec4700abce 100644 --- a/collects/typed/net/gifwrite.rkt +++ b/collects/typed/net/gifwrite.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed-racket (require typed/file/gif) (provide (all-from-out typed/file/gif)) diff --git a/collects/typed/net/head.rkt b/collects/typed/net/head.rkt index ec6493dc69..0c2b2f0d24 100644 --- a/collects/typed/net/head.rkt +++ b/collects/typed/net/head.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed-racket (require typed/private/utils) diff --git a/collects/typed/net/imap.rkt b/collects/typed/net/imap.rkt index 0e347e4082..5951b03b15 100644 --- a/collects/typed/net/imap.rkt +++ b/collects/typed/net/imap.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed-racket (require typed/private/utils) diff --git a/collects/typed/net/mime.rkt b/collects/typed/net/mime.rkt index 82893b26e5..580737ff88 100644 --- a/collects/typed/net/mime.rkt +++ b/collects/typed/net/mime.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed-racket (require typed/private/utils) ;; -- basic mime structures -- diff --git a/collects/typed/net/nntp.rkt b/collects/typed/net/nntp.rkt index f2310c9350..af1ba2bf43 100644 --- a/collects/typed/net/nntp.rkt +++ b/collects/typed/net/nntp.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed-racket (require typed/private/utils) diff --git a/collects/typed/net/pop3.rkt b/collects/typed/net/pop3.rkt index 395b3a7be7..603e285591 100644 --- a/collects/typed/net/pop3.rkt +++ b/collects/typed/net/pop3.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed-racket (require typed/private/utils) diff --git a/collects/typed/net/qp.rkt b/collects/typed/net/qp.rkt index 9d0344a2e5..cd5d3a2ff1 100644 --- a/collects/typed/net/qp.rkt +++ b/collects/typed/net/qp.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed-racket (require typed/private/utils) diff --git a/collects/typed/net/sendmail.rkt b/collects/typed/net/sendmail.rkt index 113dc250d4..35ccd2b83a 100644 --- a/collects/typed/net/sendmail.rkt +++ b/collects/typed/net/sendmail.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed-racket (require typed/private/utils) diff --git a/collects/typed/net/sendurl.rkt b/collects/typed/net/sendurl.rkt index 2be923fc7b..1eb922754f 100644 --- a/collects/typed/net/sendurl.rkt +++ b/collects/typed/net/sendurl.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed-racket (require/typed net/sendurl [send-url (String -> Void)] [unix-browser-list (Listof Symbol)] diff --git a/collects/typed/net/smtp.rkt b/collects/typed/net/smtp.rkt index 78b02ff651..fddd3610cb 100644 --- a/collects/typed/net/smtp.rkt +++ b/collects/typed/net/smtp.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed-racket (require typed/private/utils) diff --git a/collects/typed/net/uri-codec.rkt b/collects/typed/net/uri-codec.rkt index 2089712c26..aec195db9f 100644 --- a/collects/typed/net/uri-codec.rkt +++ b/collects/typed/net/uri-codec.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed-racket (require typed/private/utils) diff --git a/collects/typed/net/url.rkt b/collects/typed/net/url.rkt index 20b4196e08..aab0da73cb 100644 --- a/collects/typed/net/url.rkt +++ b/collects/typed/net/url.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed-racket (require typed/private/utils) diff --git a/collects/typed/private/utils.rkt b/collects/typed/private/utils.rkt index 5abf5a87f2..9a31a42ed4 100644 --- a/collects/typed/private/utils.rkt +++ b/collects/typed/private/utils.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed-racket (define-syntax-rule (dt nm t) (begin (define-type-alias nm t) (provide nm))) diff --git a/collects/typed/racket/base/no-check.rkt b/collects/typed/racket/base/no-check.rkt index a5be88a158..9aab712beb 100644 --- a/collects/typed/racket/base/no-check.rkt +++ b/collects/typed/racket/base/no-check.rkt @@ -1,4 +1,5 @@ #lang racket/base -(require racket/require typed-scheme/no-check (subtract-in typed/racket/base typed-scheme/no-check)) -(provide (all-from-out typed/racket/base typed-scheme/no-check)) +(require racket/require typed-racket/no-check + (subtract-in typed/racket/base typed-racket/no-check)) +(provide (all-from-out typed/racket/base typed-racket/no-check)) diff --git a/collects/typed/racket/no-check.rkt b/collects/typed/racket/no-check.rkt index f4ee4b0923..1d7c68ee4c 100644 --- a/collects/typed/racket/no-check.rkt +++ b/collects/typed/racket/no-check.rkt @@ -1,4 +1,5 @@ #lang racket/base -(require racket/require typed-scheme/no-check (subtract-in typed/racket typed-scheme/no-check)) -(provide (all-from-out typed/racket typed-scheme/no-check)) +(require racket/require typed-racket/no-check + (subtract-in typed/racket typed-racket/no-check)) +(provide (all-from-out typed/racket typed-racket/no-check)) diff --git a/collects/typed/srfi/14.rkt b/collects/typed/srfi/14.rkt index 70b2866fb6..4b7c8fa3ea 100644 --- a/collects/typed/srfi/14.rkt +++ b/collects/typed/srfi/14.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed-racket (require/opaque-type Char-Set char-set? srfi/14) (define-type-alias Cursor (Pair 0 (Listof (Pair Integer Integer)))) diff --git a/collects/typed/tests/test-docs-complete.rkt b/collects/typed/tests/test-docs-complete.rkt index 9a26620f4a..ff72902957 100644 --- a/collects/typed/tests/test-docs-complete.rkt +++ b/collects/typed/tests/test-docs-complete.rkt @@ -7,7 +7,7 @@ place-sleep procedure-closure-contents-eq? processor-count)) -(check-docs (quote typed-scheme) #:skip exclude) +(check-docs (quote typed-racket) #:skip exclude) (check-docs (quote typed/scheme) #:skip exclude) (check-docs (quote typed/scheme/base) #:skip exclude) (check-docs (quote typed/racket) #:skip exclude) From 6ebf3ab32d666e9d1e56cd546fea29d18c42dfff Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 4 Sep 2011 10:27:58 -0400 Subject: [PATCH 122/235] Revert "Abolish "typed-scheme"." This reverts commit 49a89da81860e09955f1678bab6106ce8eae8376. (Will be redone later today.) --- collects/drracket/private/auto-language.rkt | 6 +- collects/honu/core/main.rkt | 6 +- collects/honu/core/private/canonical.rkt | 2 +- ...typed-racket.rkt => honu-typed-scheme.rkt} | 2 +- collects/honu/core/private/macro.rkt | 4 +- collects/honu/core/private/more.rkt | 4 +- .../analysis/check-requires.rkt | 2 +- collects/tests/honu/test.rkt | 2 +- .../tests/macro-debugger/tests/collects.rkt | 112 +++++++++--------- .../tests/macro-debugger/tests/regression.rkt | 2 +- .../typed-racket/fail/all-bad-syntax.rkt | 2 +- .../tests/typed-racket/fail/ann-map-funcs.rkt | 2 +- .../tests/typed-racket/fail/apply-dots.rkt | 2 +- collects/tests/typed-racket/fail/bad-any.rkt | 2 +- .../tests/typed-racket/fail/bad-first.rkt | 2 +- .../tests/typed-racket/fail/set-tests.rkt | 3 +- .../typed-racket/succeed/dotted-identity2.rkt | 5 +- .../typed-racket/succeed/let-values-tests.rkt | 6 +- collects/typed-racket/scribblings/utils.rkt | 2 +- collects/typed/file/gif.rkt | 2 +- collects/typed/file/md5.rkt | 2 +- collects/typed/file/tar.rkt | 4 +- collects/typed/framework/framework.rkt | 2 +- collects/typed/net/base64.rkt | 2 +- collects/typed/net/cgi.rkt | 2 +- collects/typed/net/cookie.rkt | 2 +- collects/typed/net/dns.rkt | 3 +- collects/typed/net/ftp.rkt | 2 +- collects/typed/net/gifwrite.rkt | 2 +- collects/typed/net/head.rkt | 2 +- collects/typed/net/imap.rkt | 2 +- collects/typed/net/mime.rkt | 2 +- collects/typed/net/nntp.rkt | 2 +- collects/typed/net/pop3.rkt | 2 +- collects/typed/net/qp.rkt | 2 +- collects/typed/net/sendmail.rkt | 2 +- collects/typed/net/sendurl.rkt | 2 +- collects/typed/net/smtp.rkt | 2 +- collects/typed/net/uri-codec.rkt | 2 +- collects/typed/net/url.rkt | 2 +- collects/typed/private/utils.rkt | 2 +- collects/typed/racket/base/no-check.rkt | 5 +- collects/typed/racket/no-check.rkt | 5 +- collects/typed/srfi/14.rkt | 2 +- collects/typed/tests/test-docs-complete.rkt | 2 +- 45 files changed, 114 insertions(+), 115 deletions(-) rename collects/honu/core/private/{honu-typed-racket.rkt => honu-typed-scheme.rkt} (99%) diff --git a/collects/drracket/private/auto-language.rkt b/collects/drracket/private/auto-language.rkt index 2d887fa41c..35088ef977 100644 --- a/collects/drracket/private/auto-language.rkt +++ b/collects/drracket/private/auto-language.rkt @@ -1,7 +1,7 @@ -#lang typed-racket +#lang typed-scheme -(require typed/framework/framework - typed/mred/mred +(require typed/framework/framework + typed/mred/mred racket/class) (provide pick-new-language looks-like-module?) diff --git a/collects/honu/core/main.rkt b/collects/honu/core/main.rkt index 7ff950a1b9..625f4a7a92 100644 --- a/collects/honu/core/main.rkt +++ b/collects/honu/core/main.rkt @@ -1,6 +1,6 @@ #lang racket/base -(require "private/honu-typed-racket.rkt" +(require "private/honu-typed-scheme.rkt" "private/honu2.rkt" "private/macro2.rkt" (for-syntax (only-in "private/parse2.rkt" honu-expression)) @@ -51,10 +51,10 @@ (require (for-meta 2 racket/base)) (require racket/class) -(require "private/honu-typed-racket.rkt" +(require "private/honu-typed-scheme.rkt" "private/parse.rkt" (for-syntax "private/literals.rkt") - (for-syntax "private/honu-typed-racket.rkt") + (for-syntax "private/honu-typed-scheme.rkt") (for-syntax "private/parse.rkt") (for-syntax "private/canonical.rkt") syntax/parse diff --git a/collects/honu/core/private/canonical.rkt b/collects/honu/core/private/canonical.rkt index d13376021a..e06472e6f0 100644 --- a/collects/honu/core/private/canonical.rkt +++ b/collects/honu/core/private/canonical.rkt @@ -3,7 +3,7 @@ (provide (all-defined-out)) (require "literals.rkt" - (for-template "honu-typed-racket.rkt") + (for-template "honu-typed-scheme.rkt") syntax/parse) ;; syntax -> string diff --git a/collects/honu/core/private/honu-typed-racket.rkt b/collects/honu/core/private/honu-typed-scheme.rkt similarity index 99% rename from collects/honu/core/private/honu-typed-racket.rkt rename to collects/honu/core/private/honu-typed-scheme.rkt index 63e72eb4be..8e4b1fcb98 100644 --- a/collects/honu/core/private/honu-typed-racket.rkt +++ b/collects/honu/core/private/honu-typed-scheme.rkt @@ -1,6 +1,6 @@ #lang racket/base -(require (rename-in typed-racket (#%module-begin #%module-begin-typed-racket))) +(require (rename-in typed-scheme (#%module-begin #%module-begin-typed-scheme))) (require (for-syntax scheme/base syntax/stx syntax/name diff --git a/collects/honu/core/private/macro.rkt b/collects/honu/core/private/macro.rkt index d26a8cf082..ef621711e2 100644 --- a/collects/honu/core/private/macro.rkt +++ b/collects/honu/core/private/macro.rkt @@ -1,6 +1,6 @@ #lang racket/base -(require "honu-typed-racket.rkt" +(require "honu-typed-scheme.rkt" "literals.rkt" "parse.ss" "syntax.ss" @@ -16,7 +16,7 @@ "parse.rkt" "syntax.rkt" "literals.rkt" - "honu-typed-racket.rkt" + "honu-typed-scheme.rkt" racket/base syntax/parse syntax/stx diff --git a/collects/honu/core/private/more.rkt b/collects/honu/core/private/more.rkt index 5f6dd2a5dd..4ef6f15779 100644 --- a/collects/honu/core/private/more.rkt +++ b/collects/honu/core/private/more.rkt @@ -2,7 +2,7 @@ #| -(require "honu-typed-racket.rkt" +(require "honu-typed-scheme.rkt" "literals.rkt" syntax/parse mzlib/trace @@ -16,7 +16,7 @@ "syntax.rkt" (only-in racket (... scheme-ellipses)) "literals.rkt") - (for-template "honu-typed-racket.rkt" + (for-template "honu-typed-scheme.rkt" "literals.rkt" "syntax.rkt" (only-in racket ...) diff --git a/collects/macro-debugger/analysis/check-requires.rkt b/collects/macro-debugger/analysis/check-requires.rkt index cfe2527a8f..95d223299e 100644 --- a/collects/macro-debugger/analysis/check-requires.rkt +++ b/collects/macro-debugger/analysis/check-requires.rkt @@ -26,7 +26,7 @@ Usage: Examples: - (check-requires 'typed-racket) + (check-requires 'typed-scheme) (check-requires 'unstable/markparam) (check-requires 'macro-debugger/syntax-browser/widget) diff --git a/collects/tests/honu/test.rkt b/collects/tests/honu/test.rkt index 82440f6daa..0b53bd27ce 100644 --- a/collects/tests/honu/test.rkt +++ b/collects/tests/honu/test.rkt @@ -12,7 +12,7 @@ (rename-in honu/core/private/literals [honu-= =] [semicolon |;|]) - (rename-in (only-in honu/core/private/honu-typed-racket honu-var) + (rename-in (only-in honu/core/private/honu-typed-scheme honu-var) [honu-var var]) (for-syntax racket/base honu/core/private/macro2 diff --git a/collects/tests/macro-debugger/tests/collects.rkt b/collects/tests/macro-debugger/tests/collects.rkt index a29701fd87..ca882ecbac 100644 --- a/collects/tests/macro-debugger/tests/collects.rkt +++ b/collects/tests/macro-debugger/tests/collects.rkt @@ -140,8 +140,8 @@ #:cache-keys? #t)))) (define modules-from-framework (trace-modules '(framework))) -(define modules-from-typed-racket - #;(trace-modules '(typed-racket)) +(define modules-from-typed-scheme + #;(trace-modules '(typed-scheme)) '(#| mzlib/contract mzlib/etc @@ -267,59 +267,59 @@ syntax/stx mzlib/trace |# - typed-racket - typed-racket/minimal - typed-racket/private/base-env - typed-racket/private/base-types - typed-racket/private/check-subforms-unit - typed-racket/private/def-binding - typed-racket/private/effect-rep - typed-racket/private/extra-procs - typed-racket/private/free-variance - typed-racket/private/infer - typed-racket/private/infer-ops - typed-racket/private/init-envs - typed-racket/private/internal-forms - typed-racket/private/interning - typed-racket/private/lexical-env - typed-racket/private/mutated-vars - typed-racket/private/parse-type - typed-racket/private/planet-requires - typed-racket/private/prims - typed-racket/private/provide-handling - typed-racket/private/remove-intersect - typed-racket/private/rep-utils - typed-racket/private/require-contract - typed-racket/private/resolve-type - typed-racket/private/signatures - typed-racket/private/subtype - typed-racket/private/syntax-traversal - typed-racket/private/tables - typed-racket/private/tc-app-unit - typed-racket/private/tc-expr-unit - typed-racket/private/tc-if-unit - typed-racket/private/tc-lambda-unit - typed-racket/private/tc-let-unit - typed-racket/private/tc-structs - typed-racket/private/tc-toplevel - typed-racket/private/tc-utils - typed-racket/private/type-alias-env - typed-racket/private/type-annotation - typed-racket/private/type-comparison - typed-racket/private/type-contract - typed-racket/private/type-effect-convenience - typed-racket/private/type-effect-printer - typed-racket/private/type-env - typed-racket/private/type-environments - typed-racket/private/type-name-env - typed-racket/private/type-rep - typed-racket/private/type-utils - typed-racket/private/typechecker - typed-racket/private/unify - typed-racket/private/union - typed-racket/private/unit-utils - typed-racket/private/utils - typed-racket/typed-racket)) + typed-scheme + typed-scheme/minimal + typed-scheme/private/base-env + typed-scheme/private/base-types + typed-scheme/private/check-subforms-unit + typed-scheme/private/def-binding + typed-scheme/private/effect-rep + typed-scheme/private/extra-procs + typed-scheme/private/free-variance + typed-scheme/private/infer + typed-scheme/private/infer-ops + typed-scheme/private/init-envs + typed-scheme/private/internal-forms + typed-scheme/private/interning + typed-scheme/private/lexical-env + typed-scheme/private/mutated-vars + typed-scheme/private/parse-type + typed-scheme/private/planet-requires + typed-scheme/private/prims + typed-scheme/private/provide-handling + typed-scheme/private/remove-intersect + typed-scheme/private/rep-utils + typed-scheme/private/require-contract + typed-scheme/private/resolve-type + typed-scheme/private/signatures + typed-scheme/private/subtype + typed-scheme/private/syntax-traversal + typed-scheme/private/tables + typed-scheme/private/tc-app-unit + typed-scheme/private/tc-expr-unit + typed-scheme/private/tc-if-unit + typed-scheme/private/tc-lambda-unit + typed-scheme/private/tc-let-unit + typed-scheme/private/tc-structs + typed-scheme/private/tc-toplevel + typed-scheme/private/tc-utils + typed-scheme/private/type-alias-env + typed-scheme/private/type-annotation + typed-scheme/private/type-comparison + typed-scheme/private/type-contract + typed-scheme/private/type-effect-convenience + typed-scheme/private/type-effect-printer + typed-scheme/private/type-env + typed-scheme/private/type-environments + typed-scheme/private/type-name-env + typed-scheme/private/type-rep + typed-scheme/private/type-utils + typed-scheme/private/typechecker + typed-scheme/private/unify + typed-scheme/private/union + typed-scheme/private/unit-utils + typed-scheme/private/utils + typed-scheme/typed-scheme)) (define big-libs-tests - (test-libs "Collections" modules-from-typed-racket)) + (test-libs "Collections" modules-from-typed-scheme)) diff --git a/collects/tests/macro-debugger/tests/regression.rkt b/collects/tests/macro-debugger/tests/regression.rkt index 018936260c..c74545951d 100644 --- a/collects/tests/macro-debugger/tests/regression.rkt +++ b/collects/tests/macro-debugger/tests/regression.rkt @@ -144,7 +144,7 @@ (local [(define x 1)] x))))]) (check-pred list? rs))) - ;; Distilled from Sam/typed-racket (8/24/2007) + ;; Distilled from Sam/typed-scheme (8/24/2007) (test-case "transformer calls 'expand'" (check-pred deriv? (trace '(let-syntax ([m (lambda (stx) diff --git a/collects/tests/typed-racket/fail/all-bad-syntax.rkt b/collects/tests/typed-racket/fail/all-bad-syntax.rkt index f07efdc753..daf10f545b 100644 --- a/collects/tests/typed-racket/fail/all-bad-syntax.rkt +++ b/collects/tests/typed-racket/fail/all-bad-syntax.rkt @@ -1,6 +1,6 @@ #; (exn-pred 2) -#lang typed-racket +#lang typed-scheme (require scheme/list) diff --git a/collects/tests/typed-racket/fail/ann-map-funcs.rkt b/collects/tests/typed-racket/fail/ann-map-funcs.rkt index a1598f70bc..f8ba9fb486 100644 --- a/collects/tests/typed-racket/fail/ann-map-funcs.rkt +++ b/collects/tests/typed-racket/fail/ann-map-funcs.rkt @@ -1,6 +1,6 @@ #; (exn-pred 3) -#lang typed-racket +#lang typed-scheme (: map-with-funcs (All (b a ...) ((a ... a -> b) * -> (a ... a -> (Listof b))))) diff --git a/collects/tests/typed-racket/fail/apply-dots.rkt b/collects/tests/typed-racket/fail/apply-dots.rkt index df0a2952e4..fd2b031378 100644 --- a/collects/tests/typed-racket/fail/apply-dots.rkt +++ b/collects/tests/typed-racket/fail/apply-dots.rkt @@ -1,6 +1,6 @@ #; (exn-pred 2) -#lang typed-racket +#lang typed-scheme (plambda: (a ...) ([z : String] . [w : Number *]) (apply (case-lambda: (([x : Number] . [y : Number ... a]) x)) diff --git a/collects/tests/typed-racket/fail/bad-any.rkt b/collects/tests/typed-racket/fail/bad-any.rkt index 0625a5f8ab..3fc5acc832 100644 --- a/collects/tests/typed-racket/fail/bad-any.rkt +++ b/collects/tests/typed-racket/fail/bad-any.rkt @@ -2,7 +2,7 @@ (exn-pred exn:fail:contract?) #lang scheme/load -(module m typed-racket +(module m typed-scheme (: f Any) (define f (lambda: ([x : Number]) (add1 x))) (provide f)) diff --git a/collects/tests/typed-racket/fail/bad-first.rkt b/collects/tests/typed-racket/fail/bad-first.rkt index 223645b516..eb0fd623d3 100644 --- a/collects/tests/typed-racket/fail/bad-first.rkt +++ b/collects/tests/typed-racket/fail/bad-first.rkt @@ -1,3 +1,3 @@ -#lang typed-racket +#lang typed-scheme (require scheme/list) (first (cons 1 2)) diff --git a/collects/tests/typed-racket/fail/set-tests.rkt b/collects/tests/typed-racket/fail/set-tests.rkt index 45d022a1c4..fad4d5f408 100644 --- a/collects/tests/typed-racket/fail/set-tests.rkt +++ b/collects/tests/typed-racket/fail/set-tests.rkt @@ -1,7 +1,8 @@ ;; should FAIL! -#lang typed-racket +#lang typed-scheme (let*: ((x : Any 1) (f : (-> Void) (lambda () (set! x (quote foo))))) (if (number? x) (begin (f) (add1 x)) 12)) + diff --git a/collects/tests/typed-racket/succeed/dotted-identity2.rkt b/collects/tests/typed-racket/succeed/dotted-identity2.rkt index af5ca156cc..c00f16b91a 100644 --- a/collects/tests/typed-racket/succeed/dotted-identity2.rkt +++ b/collects/tests/typed-racket/succeed/dotted-identity2.rkt @@ -1,7 +1,6 @@ -#lang typed-racket +#lang typed-scheme -;; I don't believe the below should work, but it points out where that -;; internal error is coming from. +;; I don't believe the below should work, but it points out where that internal error is coming from. (: f (All (a ...) ((a ... a -> Integer) -> (a ... a -> Integer)))) (define (f x) x) diff --git a/collects/tests/typed-racket/succeed/let-values-tests.rkt b/collects/tests/typed-racket/succeed/let-values-tests.rkt index 124619cded..fe16662bc6 100644 --- a/collects/tests/typed-racket/succeed/let-values-tests.rkt +++ b/collects/tests/typed-racket/succeed/let-values-tests.rkt @@ -1,4 +1,4 @@ -#lang typed-racket +#lang typed-scheme (define-type-alias number Number) (define-type-alias boolean Boolean) (define-type-alias symbol Symbol) @@ -7,8 +7,8 @@ (let-values ([(#{x : number} #{y : number}) (values 3 4)] [(#{z : number}) (values 3)] #;[(#{fact : (number -> number)}) - (lambda: ([x : number]) - (if (zero? x) 1 (* x (fact (- x 1)))))] + (lambda: ([x : number]) + (if (zero? x) 1 (* x (fact (- x 1)))))] #;[(#{z : number}) (- x y)]) (+ x y)) diff --git a/collects/typed-racket/scribblings/utils.rkt b/collects/typed-racket/scribblings/utils.rkt index a807621488..ab158a8c18 100644 --- a/collects/typed-racket/scribblings/utils.rkt +++ b/collects/typed-racket/scribblings/utils.rkt @@ -4,7 +4,7 @@ (provide (all-defined-out)) (define (item* header . args) (apply item @bold[header]{: } args)) -(define-syntax-rule (tmod forms ...) (racketmod typed-racket forms ...)) +(define-syntax-rule (tmod forms ...) (racketmod typed-scheme forms ...)) (define (gtech . x) (apply tech x #:doc '(lib "scribblings/guide/guide.scrbl"))) (define (rtech . x) diff --git a/collects/typed/file/gif.rkt b/collects/typed/file/gif.rkt index abbccbc840..6f96c976d8 100644 --- a/collects/typed/file/gif.rkt +++ b/collects/typed/file/gif.rkt @@ -1,4 +1,4 @@ -#lang typed-racket +#lang typed-scheme (require typed/private/utils) diff --git a/collects/typed/file/md5.rkt b/collects/typed/file/md5.rkt index 74dce83a3a..0cab46d7ba 100644 --- a/collects/typed/file/md5.rkt +++ b/collects/typed/file/md5.rkt @@ -1,4 +1,4 @@ -#lang typed-racket +#lang typed-scheme (require/typed file/md5 [md5 ((U Bytes Input-Port) -> Bytes)]) (provide md5) diff --git a/collects/typed/file/tar.rkt b/collects/typed/file/tar.rkt index 5ec7086bde..0497d8c9fc 100644 --- a/collects/typed/file/tar.rkt +++ b/collects/typed/file/tar.rkt @@ -1,5 +1,5 @@ -#lang typed-racket -;; typed-racket wrapper on file/tar +#lang typed-scheme +;; typed-scheme wrapper on file/tar ;; yc 2009/2/25 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/collects/typed/framework/framework.rkt b/collects/typed/framework/framework.rkt index fa7a2f9ac7..23f267e67b 100644 --- a/collects/typed/framework/framework.rkt +++ b/collects/typed/framework/framework.rkt @@ -1,4 +1,4 @@ -#lang typed-racket +#lang typed-scheme (require typed/private/utils typed/mred/mred) diff --git a/collects/typed/net/base64.rkt b/collects/typed/net/base64.rkt index c1090e1e18..0745794516 100644 --- a/collects/typed/net/base64.rkt +++ b/collects/typed/net/base64.rkt @@ -1,4 +1,4 @@ -#lang typed-racket +#lang typed-scheme (require typed/private/utils) diff --git a/collects/typed/net/cgi.rkt b/collects/typed/net/cgi.rkt index c670549f7a..80c3b0de55 100644 --- a/collects/typed/net/cgi.rkt +++ b/collects/typed/net/cgi.rkt @@ -1,4 +1,4 @@ -#lang typed-racket +#lang typed-scheme (require typed/private/utils) diff --git a/collects/typed/net/cookie.rkt b/collects/typed/net/cookie.rkt index 6eb59fe922..3eb8092adf 100644 --- a/collects/typed/net/cookie.rkt +++ b/collects/typed/net/cookie.rkt @@ -1,4 +1,4 @@ -#lang typed-racket +#lang typed-scheme (require typed/private/utils) diff --git a/collects/typed/net/dns.rkt b/collects/typed/net/dns.rkt index d29ae084bd..24ef679f81 100644 --- a/collects/typed/net/dns.rkt +++ b/collects/typed/net/dns.rkt @@ -1,4 +1,4 @@ -#lang typed-racket +#lang typed-scheme (require typed/private/utils) @@ -7,3 +7,4 @@ [dns-get-name (String String -> String)] [dns-get-mail-exchanger (String String -> String )] [dns-find-nameserver (-> (Option String))]) + diff --git a/collects/typed/net/ftp.rkt b/collects/typed/net/ftp.rkt index d4e6e7e48f..041befc0d5 100644 --- a/collects/typed/net/ftp.rkt +++ b/collects/typed/net/ftp.rkt @@ -1,4 +1,4 @@ -#lang typed-racket +#lang typed-scheme (require typed/private/utils) diff --git a/collects/typed/net/gifwrite.rkt b/collects/typed/net/gifwrite.rkt index ec4700abce..cfe9167c5b 100644 --- a/collects/typed/net/gifwrite.rkt +++ b/collects/typed/net/gifwrite.rkt @@ -1,4 +1,4 @@ -#lang typed-racket +#lang typed-scheme (require typed/file/gif) (provide (all-from-out typed/file/gif)) diff --git a/collects/typed/net/head.rkt b/collects/typed/net/head.rkt index 0c2b2f0d24..ec6493dc69 100644 --- a/collects/typed/net/head.rkt +++ b/collects/typed/net/head.rkt @@ -1,4 +1,4 @@ -#lang typed-racket +#lang typed-scheme (require typed/private/utils) diff --git a/collects/typed/net/imap.rkt b/collects/typed/net/imap.rkt index 5951b03b15..0e347e4082 100644 --- a/collects/typed/net/imap.rkt +++ b/collects/typed/net/imap.rkt @@ -1,4 +1,4 @@ -#lang typed-racket +#lang typed-scheme (require typed/private/utils) diff --git a/collects/typed/net/mime.rkt b/collects/typed/net/mime.rkt index 580737ff88..82893b26e5 100644 --- a/collects/typed/net/mime.rkt +++ b/collects/typed/net/mime.rkt @@ -1,4 +1,4 @@ -#lang typed-racket +#lang typed-scheme (require typed/private/utils) ;; -- basic mime structures -- diff --git a/collects/typed/net/nntp.rkt b/collects/typed/net/nntp.rkt index af1ba2bf43..f2310c9350 100644 --- a/collects/typed/net/nntp.rkt +++ b/collects/typed/net/nntp.rkt @@ -1,4 +1,4 @@ -#lang typed-racket +#lang typed-scheme (require typed/private/utils) diff --git a/collects/typed/net/pop3.rkt b/collects/typed/net/pop3.rkt index 603e285591..395b3a7be7 100644 --- a/collects/typed/net/pop3.rkt +++ b/collects/typed/net/pop3.rkt @@ -1,4 +1,4 @@ -#lang typed-racket +#lang typed-scheme (require typed/private/utils) diff --git a/collects/typed/net/qp.rkt b/collects/typed/net/qp.rkt index cd5d3a2ff1..9d0344a2e5 100644 --- a/collects/typed/net/qp.rkt +++ b/collects/typed/net/qp.rkt @@ -1,4 +1,4 @@ -#lang typed-racket +#lang typed-scheme (require typed/private/utils) diff --git a/collects/typed/net/sendmail.rkt b/collects/typed/net/sendmail.rkt index 35ccd2b83a..113dc250d4 100644 --- a/collects/typed/net/sendmail.rkt +++ b/collects/typed/net/sendmail.rkt @@ -1,4 +1,4 @@ -#lang typed-racket +#lang typed-scheme (require typed/private/utils) diff --git a/collects/typed/net/sendurl.rkt b/collects/typed/net/sendurl.rkt index 1eb922754f..2be923fc7b 100644 --- a/collects/typed/net/sendurl.rkt +++ b/collects/typed/net/sendurl.rkt @@ -1,4 +1,4 @@ -#lang typed-racket +#lang typed-scheme (require/typed net/sendurl [send-url (String -> Void)] [unix-browser-list (Listof Symbol)] diff --git a/collects/typed/net/smtp.rkt b/collects/typed/net/smtp.rkt index fddd3610cb..78b02ff651 100644 --- a/collects/typed/net/smtp.rkt +++ b/collects/typed/net/smtp.rkt @@ -1,4 +1,4 @@ -#lang typed-racket +#lang typed-scheme (require typed/private/utils) diff --git a/collects/typed/net/uri-codec.rkt b/collects/typed/net/uri-codec.rkt index aec195db9f..2089712c26 100644 --- a/collects/typed/net/uri-codec.rkt +++ b/collects/typed/net/uri-codec.rkt @@ -1,4 +1,4 @@ -#lang typed-racket +#lang typed-scheme (require typed/private/utils) diff --git a/collects/typed/net/url.rkt b/collects/typed/net/url.rkt index aab0da73cb..20b4196e08 100644 --- a/collects/typed/net/url.rkt +++ b/collects/typed/net/url.rkt @@ -1,4 +1,4 @@ -#lang typed-racket +#lang typed-scheme (require typed/private/utils) diff --git a/collects/typed/private/utils.rkt b/collects/typed/private/utils.rkt index 9a31a42ed4..5abf5a87f2 100644 --- a/collects/typed/private/utils.rkt +++ b/collects/typed/private/utils.rkt @@ -1,4 +1,4 @@ -#lang typed-racket +#lang typed-scheme (define-syntax-rule (dt nm t) (begin (define-type-alias nm t) (provide nm))) diff --git a/collects/typed/racket/base/no-check.rkt b/collects/typed/racket/base/no-check.rkt index 9aab712beb..a5be88a158 100644 --- a/collects/typed/racket/base/no-check.rkt +++ b/collects/typed/racket/base/no-check.rkt @@ -1,5 +1,4 @@ #lang racket/base -(require racket/require typed-racket/no-check - (subtract-in typed/racket/base typed-racket/no-check)) -(provide (all-from-out typed/racket/base typed-racket/no-check)) +(require racket/require typed-scheme/no-check (subtract-in typed/racket/base typed-scheme/no-check)) +(provide (all-from-out typed/racket/base typed-scheme/no-check)) diff --git a/collects/typed/racket/no-check.rkt b/collects/typed/racket/no-check.rkt index 1d7c68ee4c..f4ee4b0923 100644 --- a/collects/typed/racket/no-check.rkt +++ b/collects/typed/racket/no-check.rkt @@ -1,5 +1,4 @@ #lang racket/base -(require racket/require typed-racket/no-check - (subtract-in typed/racket typed-racket/no-check)) -(provide (all-from-out typed/racket typed-racket/no-check)) +(require racket/require typed-scheme/no-check (subtract-in typed/racket typed-scheme/no-check)) +(provide (all-from-out typed/racket typed-scheme/no-check)) diff --git a/collects/typed/srfi/14.rkt b/collects/typed/srfi/14.rkt index 4b7c8fa3ea..70b2866fb6 100644 --- a/collects/typed/srfi/14.rkt +++ b/collects/typed/srfi/14.rkt @@ -1,4 +1,4 @@ -#lang typed-racket +#lang typed-scheme (require/opaque-type Char-Set char-set? srfi/14) (define-type-alias Cursor (Pair 0 (Listof (Pair Integer Integer)))) diff --git a/collects/typed/tests/test-docs-complete.rkt b/collects/typed/tests/test-docs-complete.rkt index ff72902957..9a26620f4a 100644 --- a/collects/typed/tests/test-docs-complete.rkt +++ b/collects/typed/tests/test-docs-complete.rkt @@ -7,7 +7,7 @@ place-sleep procedure-closure-contents-eq? processor-count)) -(check-docs (quote typed-racket) #:skip exclude) +(check-docs (quote typed-scheme) #:skip exclude) (check-docs (quote typed/scheme) #:skip exclude) (check-docs (quote typed/scheme/base) #:skip exclude) (check-docs (quote typed/racket) #:skip exclude) From 5de2ea954740743301894e88d9ebe5620ab519aa Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 4 Sep 2011 09:47:19 -0600 Subject: [PATCH 123/235] fix absolute paths in cross-reference info The absolute paths were introduced by support for parallel build, which piggy-backs information in "in.sxref" to communicate among processes. Since the information is persistent beyond that cooperation, the information needs to be in relative form. [Sorry for the reformatting noise, but the file's indentation was especially mangled.] --- collects/setup/scribble.rkt | 652 +++++++++++++++++++----------------- 1 file changed, 340 insertions(+), 312 deletions(-) diff --git a/collects/setup/scribble.rkt b/collects/setup/scribble.rkt index 3ca3bb241d..cc76f5be36 100644 --- a/collects/setup/scribble.rkt +++ b/collects/setup/scribble.rkt @@ -48,16 +48,16 @@ (define (filter-user-docs docs make-user?) (cond ;; Specifically disabled user stuff, filter - [(not make-user?) (filter main-doc? docs)] - ;; If we've built user-specific before, keep building - [(file-exists? (build-path (find-user-doc-dir) "index.html")) docs] - ;; Otherwise, see if we need it: - [(ormap (lambda (doc) - (not (or (doc-under-main? doc) - (memq 'no-depend-on (doc-flags doc))))) - docs) - docs] - [else (filter main-doc? docs)])) ; Don't need them, so drop them + [(not make-user?) (filter main-doc? docs)] + ;; If we've built user-specific before, keep building + [(file-exists? (build-path (find-user-doc-dir) "index.html")) docs] + ;; Otherwise, see if we need it: + [(ormap (lambda (doc) + (not (or (doc-under-main? doc) + (memq 'no-depend-on (doc-flags doc))))) + docs) + docs] + [else (filter main-doc? docs)])) ; Don't need them, so drop them (define (parallel-do-error-handler setup-printf doc errmsg outstr errstr) (setup-printf "error running" (module-path-prefix->string (doc-src-spec doc))) @@ -69,13 +69,13 @@ only-dirs ; limits doc builds latex-dest ; if not #f, generate Latex output auto-start-doc? ; if #t, expands `only-dir' with [user-]start to - ; catch new docs + ; catch new docs make-user? ; are we making user stuff? with-record-error ; catch & record exceptions setup-printf) (define (scribblings-flag? sym) (memq sym '(main-doc main-doc-root user-doc-root user-doc multi-page - depends-all depends-all-main no-depend-on always-run))) + depends-all depends-all-main no-depend-on always-run))) (define (validate-scribblings-infos infos) (define (validate path [flags '()] [cat '(library)] [name #f]) (and (string? path) (relative-path? path) @@ -99,32 +99,32 @@ (let ([s (validate-scribblings-infos (i 'scribblings))] [dir (directory-record-path rec)]) (if s - (map (lambda (d) - (let* ([flags (cadr d)] - [under-main? - (and (not (memq 'main-doc-root flags)) - (not (memq 'user-doc-root flags)) - (not (memq 'user-doc flags)) - (or (memq 'main-doc flags) - (hash-ref main-dirs dir #f) - (pair? (path->main-collects-relative dir))))]) - (make-doc dir - (let ([spec (directory-record-spec rec)]) - (list* (car spec) - (car d) - (if (eq? 'planet (car spec)) - (list (append (cdr spec) - (list (directory-record-maj rec) - (list '= (directory-record-min rec))))) - (cdr spec)))) - (simplify-path (build-path dir (car d)) #f) - (doc-path dir (cadddr d) flags under-main?) - flags under-main? (caddr d)))) - s) - (begin (setup-printf - "WARNING" - "bad 'scribblings info: ~e from: ~e" (i 'scribblings) dir) - null)))) + (map (lambda (d) + (let* ([flags (cadr d)] + [under-main? + (and (not (memq 'main-doc-root flags)) + (not (memq 'user-doc-root flags)) + (not (memq 'user-doc flags)) + (or (memq 'main-doc flags) + (hash-ref main-dirs dir #f) + (pair? (path->main-collects-relative dir))))]) + (make-doc dir + (let ([spec (directory-record-spec rec)]) + (list* (car spec) + (car d) + (if (eq? 'planet (car spec)) + (list (append (cdr spec) + (list (directory-record-maj rec) + (list '= (directory-record-min rec))))) + (cdr spec)))) + (simplify-path (build-path dir (car d)) #f) + (doc-path dir (cadddr d) flags under-main?) + flags under-main? (caddr d)))) + s) + (begin (setup-printf + "WARNING" + "bad 'scribblings info: ~e from: ~e" (i 'scribblings) dir) + null)))) (define docs (let* ([recs (find-relevant-directory-records '(scribblings) 'all-available)] [main-dirs (parameterize ([current-library-collection-paths @@ -141,22 +141,22 @@ (and (ormap can-build*? docs) (filter values (if (not (worker-count . > . 1)) - (map (get-doc-info only-dirs latex-dest auto-main? auto-user? - with-record-error setup-printf #f) - docs) - (parallel-do + (map (get-doc-info only-dirs latex-dest auto-main? auto-user? + with-record-error setup-printf #f) + docs) + (parallel-do worker-count (lambda (workerid) (list workerid program-name (verbose) only-dirs latex-dest auto-main? auto-user?)) (list-queue - docs - (lambda (x workerid) (s-exp->fasl (serialize x))) - (lambda (work r outstr errstr) - (printf "~a" outstr) - (printf "~a" errstr) - (deserialize (fasl->s-exp r))) - (lambda (work errmsg outstr errstr) - (parallel-do-error-handler setup-printf work errmsg outstr errstr))) + docs + (lambda (x workerid) (s-exp->fasl (serialize x))) + (lambda (work r outstr errstr) + (printf "~a" outstr) + (printf "~a" errstr) + (deserialize (fasl->s-exp r))) + (lambda (work errmsg outstr errstr) + (parallel-do-error-handler setup-printf work errmsg outstr errstr))) (define-worker (get-doc-info-worker workerid program-name verbosev only-dirs latex-dest auto-main? auto-user?) (define ((get-doc-info-local program-name only-dirs latex-dest auto-main? auto-user?) @@ -169,8 +169,8 @@ (define (with-record-error cc go fail-k) (with-handlers ([exn:fail? (lambda (exn) - (eprintf "~a\n" (exn-message exn)) - (raise exn))]) + (eprintf "~a\n" (exn-message exn)) + (raise exn))]) (go))) (s-exp->fasl (serialize ((get-doc-info only-dirs latex-dest auto-main? auto-user? @@ -179,9 +179,9 @@ (verbose verbosev) (match-message-loop - [doc (send/success - ((get-doc-info-local program-name only-dirs latex-dest auto-main? auto-user?) - doc))]))))))) + [doc (send/success + ((get-doc-info-local program-name only-dirs latex-dest auto-main? auto-user?) + doc))]))))))) (define (make-loop first? iter) (let ([ht (make-hash)] @@ -310,12 +310,12 @@ (let ([need-rerun (filter-map (lambda (i) (and (info-need-run? i) (begin - (when (info-need-in-write? i) - (write-in/info latex-dest i) - (set-info-need-in-write?! i #f)) - (set-info-deps! i (filter info? (info-deps i))) - (set-info-need-run?! i #f) - i))) + (when (info-need-in-write? i) + (write-in/info latex-dest i) + (set-info-need-in-write?! i #f)) + (set-info-deps! i (filter info? (info-deps i))) + (set-info-need-run?! i #f) + i))) infos)]) (define (say-rendering i workerid) (setup-printf (string-append @@ -327,46 +327,46 @@ (match response [#f (set-info-failed?! info #t)] [(list in-delta? out-delta? defs undef) - (set-info-rendered?! info #t) - (set-info-provides! info defs) - (set-info-undef! info undef) - (when out-delta? - (set-info-out-time! info (/ (current-inexact-milliseconds) 1000))) - (when in-delta? - ;; Reset expected dependencies to known dependencies, and recompute later: - (set-info-deps! info (info-known-deps info)) - (set-info-need-in-write?! info #t)) - (set-info-time! info (/ (current-inexact-milliseconds) 1000))])) - (if (not (worker-count . > . 1)) + (set-info-rendered?! info #t) + (set-info-provides! info defs) + (set-info-undef! info undef) + (when out-delta? + (set-info-out-time! info (/ (current-inexact-milliseconds) 1000))) + (when in-delta? + ;; Reset expected dependencies to known dependencies, and recompute later: + (set-info-deps! info (info-known-deps info)) + (set-info-need-in-write?! info #t)) + (set-info-time! info (/ (current-inexact-milliseconds) 1000))])) + (if (not (worker-count . > . 1)) (map (lambda (i) - (say-rendering i #f) - (update-info i (build-again! latex-dest i with-record-error))) need-rerun) + (say-rendering i #f) + (update-info i (build-again! latex-dest i with-record-error))) need-rerun) (parallel-do - worker-count - (lambda (workerid) (list workerid (verbose) latex-dest)) - (list-queue - need-rerun - (lambda (i workerid) - (say-rendering i workerid) - (s-exp->fasl (serialize (info-doc i)))) - (lambda (i r outstr errstr) - (printf "~a" outstr) - (printf "~a" errstr) - (update-info i (deserialize (fasl->s-exp r)))) - (lambda (i errmsg outstr errstr) - (parallel-do-error-handler setup-printf (info-doc i) errmsg outstr errstr))) - (define-worker (build-again!-worker2 workerid verbosev latex-dest) - (define (with-record-error cc go fail-k) - (with-handlers ([exn:fail? - (lambda (x) - (eprintf "~a\n" (exn-message x)) - (raise x))]) - (go))) - (verbose verbosev) - (match-message-loop - [info - (send/success - (s-exp->fasl (serialize (build-again! latex-dest (deserialize (fasl->s-exp info)) with-record-error))))]))))) + worker-count + (lambda (workerid) (list workerid (verbose) latex-dest)) + (list-queue + need-rerun + (lambda (i workerid) + (say-rendering i workerid) + (s-exp->fasl (serialize (info-doc i)))) + (lambda (i r outstr errstr) + (printf "~a" outstr) + (printf "~a" errstr) + (update-info i (deserialize (fasl->s-exp r)))) + (lambda (i errmsg outstr errstr) + (parallel-do-error-handler setup-printf (info-doc i) errmsg outstr errstr))) + (define-worker (build-again!-worker2 workerid verbosev latex-dest) + (define (with-record-error cc go fail-k) + (with-handlers ([exn:fail? + (lambda (x) + (eprintf "~a\n" (exn-message x)) + (raise x))]) + (go))) + (verbose verbosev) + (match-message-loop + [info + (send/success + (s-exp->fasl (serialize (build-again! latex-dest (deserialize (fasl->s-exp info)) with-record-error))))]))))) ;; If we only build 1, then it reaches it own fixpoint ;; even if the info doesn't seem to converge immediately. ;; This is a useful shortcut when re-building a single @@ -383,44 +383,44 @@ (define (make-renderer latex-dest doc) (if latex-dest - (new (latex:render-mixin render%) - [dest-dir latex-dest] - ;; Use PLT manual style: - [prefix-file (collection-file-path "manual-prefix.tex" "scribble")] - [style-file (collection-file-path "manual-style.tex" "scribble")] - ;; All .tex files go to the same directory, so prefix - ;; generated/copied file names to keep them separate: - [helper-file-prefix (let-values ([(base name dir?) (split-path - (doc-dest-dir doc))]) - (path-element->string name))]) - (let* ([flags (doc-flags doc)] - [multi? (memq 'multi-page flags)] - [main? (doc-under-main? doc)] - [ddir (doc-dest-dir doc)] - [root? (or (memq 'main-doc-root flags) - (memq 'user-doc-root flags))]) - (new ((if multi? html:render-multi-mixin values) - (html:render-mixin render%)) - [dest-dir (if multi? - (let-values ([(base name dir?) (split-path ddir)]) base) - ddir)] - [alt-paths (if main? - (let ([std-path (lambda (s) - (cons (collection-file-path s "scribble") - (format "../~a" s)))]) - (list (std-path "scribble.css") - (std-path "scribble-style.css") - (std-path "racket.css") - (std-path "scribble-common.js"))) - null)] - ;; For main-directory, non-start files, up-path is #t, which makes the - ;; "up" link go to the (user's) start page using cookies. For other files, - ;; - [up-path (and (not root?) - (if main? - #t - (build-path (find-user-doc-dir) "index.html")))] - [search-box? #t])))) + (new (latex:render-mixin render%) + [dest-dir latex-dest] + ;; Use PLT manual style: + [prefix-file (collection-file-path "manual-prefix.tex" "scribble")] + [style-file (collection-file-path "manual-style.tex" "scribble")] + ;; All .tex files go to the same directory, so prefix + ;; generated/copied file names to keep them separate: + [helper-file-prefix (let-values ([(base name dir?) (split-path + (doc-dest-dir doc))]) + (path-element->string name))]) + (let* ([flags (doc-flags doc)] + [multi? (memq 'multi-page flags)] + [main? (doc-under-main? doc)] + [ddir (doc-dest-dir doc)] + [root? (or (memq 'main-doc-root flags) + (memq 'user-doc-root flags))]) + (new ((if multi? html:render-multi-mixin values) + (html:render-mixin render%)) + [dest-dir (if multi? + (let-values ([(base name dir?) (split-path ddir)]) base) + ddir)] + [alt-paths (if main? + (let ([std-path (lambda (s) + (cons (collection-file-path s "scribble") + (format "../~a" s)))]) + (list (std-path "scribble.css") + (std-path "scribble-style.css") + (std-path "racket.css") + (std-path "scribble-common.js"))) + null)] + ;; For main-directory, non-start files, up-path is #t, which makes the + ;; "up" link go to the (user's) start page using cookies. For other files, + ;; + [up-path (and (not root?) + (if main? + #t + (build-path (find-user-doc-dir) "index.html")))] + [search-box? #t])))) (define (pick-dest latex-dest doc) (cond [latex-dest @@ -457,8 +457,8 @@ p)) (let ([tag-prefix p] [tags (if (member '(part "top") (part-tags v)) - (part-tags v) - (cons '(part "top") (part-tags v)))] + (part-tags v) + (cons '(part "top") (part-tags v)))] [style (part-style v)]) (make-part tag-prefix @@ -478,8 +478,8 @@ (part-blocks v) (part-parts v))))) (ensure-doc-prefix - (dynamic-require-doc (doc-src-spec doc)) - (doc-src-spec doc))) + (dynamic-require-doc (doc-src-spec doc)) + (doc-src-spec doc))) (define (omit? cat) (or (eq? cat 'omit) @@ -573,116 +573,116 @@ (path->relative-string/setup (doc-src-file doc)))) (if up-to-date? - ;; Load previously calculated info: - (render-time - "use" - (with-handlers ([exn:fail? (lambda (exn) - (log-error (format "get-doc-info error: ~a" - (exn-message exn))) - (delete-file info-out-file) - (delete-file info-in-file) - ((get-doc-info only-dirs latex-dest auto-main? - auto-user? with-record-error - setup-printf workerid) - doc))]) - (let* ([v-in (load-sxref info-in-file)] - [v-out (load-sxref info-out-file)]) - (unless (and (equal? (car v-in) (list vers (doc-flags doc))) - (equal? (car v-out) (list vers (doc-flags doc)))) - (error "old info has wrong version or flags")) - (make-info - doc - (let ([v (list-ref v-out 2)]) ; provides - (with-my-namespace - (lambda () - (deserialize v)))) - (let ([v (list-ref v-in 1)]) ; undef - (with-my-namespace - (lambda () - (deserialize v)))) - (let ([v (list-ref v-in 3)]) ; searches - (with-my-namespace - (lambda () - (deserialize v)))) - (map rel->path (list-ref v-in 2)) ; expected deps, in case we don't need to build... - null ; known deps (none at this point) - can-run? - my-time info-out-time - (and can-run? (memq 'always-run (doc-flags doc))) - #f - #f - vers - #f - #f)))) - (if can-run? - ;; Run the doc once: - (with-record-error - (doc-src-file doc) - (lambda () - (parameterize ([current-directory (doc-src-dir doc)]) - (let* ([v (load-doc/ensure-prefix doc)] - [dest-dir (pick-dest latex-dest doc)] - [fp (send renderer traverse (list v) (list dest-dir))] - [ci (send renderer collect (list v) (list dest-dir) fp)] - [ri (send renderer resolve (list v) (list dest-dir) ci)] - [out-v (and info-out-time - (info-out-time . >= . src-time) - (with-handlers ([exn:fail? (lambda (exn) #f)]) - (let ([v (load-sxref info-out-file)]) - (unless (equal? (car v) (list vers (doc-flags doc))) - (error "old info has wrong version or flags")) - v)))] - [sci (send renderer serialize-info ri)] - [defs (send renderer get-defined ci)] - [undef (send renderer get-external ri)] - [searches (resolve-info-searches ri)] - [need-out-write? - (or (not out-v) - (not (equal? (list vers (doc-flags doc)) - (car out-v))) - (not (serialized=? sci (cadr out-v))) - (not (equal? (any-order defs) (any-order (deserialize (caddr out-v))))) - (info-out-time . > . (current-seconds)))]) - (when (and (verbose) need-out-write?) - (fprintf (current-error-port) " [New out ~a]\n" (doc-src-file doc))) - (gc-point) - (let ([info - (make-info doc - defs ; provides - undef - searches - null ; no deps, yet - null ; no known deps, yet - can-run? - -inf.0 - (if need-out-write? - (/ (current-inexact-milliseconds) 1000) - info-out-time) - #t - can-run? - need-out-write? - vers - #f - #f)]) - (when need-out-write? - (render-time "xref-out" (write-out/info latex-dest info sci)) - (set-info-need-out-write?! info #f)) - (when (info-need-in-write? info) - (render-time "xref-in" (write-in/info latex-dest info)) - (set-info-need-in-write?! info #f)) + ;; Load previously calculated info: + (render-time + "use" + (with-handlers ([exn:fail? (lambda (exn) + (log-error (format "get-doc-info error: ~a" + (exn-message exn))) + (delete-file info-out-file) + (delete-file info-in-file) + ((get-doc-info only-dirs latex-dest auto-main? + auto-user? with-record-error + setup-printf workerid) + doc))]) + (let* ([v-in (load-sxref info-in-file)] + [v-out (load-sxref info-out-file)]) + (unless (and (equal? (car v-in) (list vers (doc-flags doc))) + (equal? (car v-out) (list vers (doc-flags doc)))) + (error "old info has wrong version or flags")) + (make-info + doc + (let ([v (list-ref v-out 2)]) ; provides + (with-my-namespace + (lambda () + (deserialize v)))) + (let ([v (list-ref v-in 1)]) ; undef + (with-my-namespace + (lambda () + (deserialize v)))) + (let ([v (list-ref v-in 3)]) ; searches + (with-my-namespace + (lambda () + (deserialize v)))) + (map rel->path (list-ref v-in 2)) ; expected deps, in case we don't need to build... + null ; known deps (none at this point) + can-run? + my-time info-out-time + (and can-run? (memq 'always-run (doc-flags doc))) + #f + #f + vers + #f + #f)))) + (if can-run? + ;; Run the doc once: + (with-record-error + (doc-src-file doc) + (lambda () + (parameterize ([current-directory (doc-src-dir doc)]) + (let* ([v (load-doc/ensure-prefix doc)] + [dest-dir (pick-dest latex-dest doc)] + [fp (send renderer traverse (list v) (list dest-dir))] + [ci (send renderer collect (list v) (list dest-dir) fp)] + [ri (send renderer resolve (list v) (list dest-dir) ci)] + [out-v (and info-out-time + (info-out-time . >= . src-time) + (with-handlers ([exn:fail? (lambda (exn) #f)]) + (let ([v (load-sxref info-out-file)]) + (unless (equal? (car v) (list vers (doc-flags doc))) + (error "old info has wrong version or flags")) + v)))] + [sci (send renderer serialize-info ri)] + [defs (send renderer get-defined ci)] + [undef (send renderer get-external ri)] + [searches (resolve-info-searches ri)] + [need-out-write? + (or (not out-v) + (not (equal? (list vers (doc-flags doc)) + (car out-v))) + (not (serialized=? sci (cadr out-v))) + (not (equal? (any-order defs) (any-order (deserialize (caddr out-v))))) + (info-out-time . > . (current-seconds)))]) + (when (and (verbose) need-out-write?) + (fprintf (current-error-port) " [New out ~a]\n" (doc-src-file doc))) + (gc-point) + (let ([info + (make-info doc + defs ; provides + undef + searches + null ; no deps, yet + null ; no known deps, yet + can-run? + -inf.0 + (if need-out-write? + (/ (current-inexact-milliseconds) 1000) + info-out-time) + #t + can-run? + need-out-write? + vers + #f + #f)]) + (when need-out-write? + (render-time "xref-out" (write-out/info latex-dest info sci)) + (set-info-need-out-write?! info #f)) + (when (info-need-in-write? info) + (render-time "xref-in" (write-in/info latex-dest info)) + (set-info-need-in-write?! info #f)) - (when (or (stamp-time . < . aux-time) - (stamp-time . < . src-time)) - (let ([data (list (get-compiled-file-sha1 src-zo) - (get-compiled-file-sha1 renderer-path) - (get-file-sha1 css-path))]) - (with-compile-output stamp-file (lambda (out tmp-filename) (write data out))) - (let ([m (max aux-time src-time)]) - (unless (equal? m +inf.0) - (file-or-directory-modify-seconds stamp-file m))))) - info)))) - (lambda () #f)) - #f)))) + (when (or (stamp-time . < . aux-time) + (stamp-time . < . src-time)) + (let ([data (list (get-compiled-file-sha1 src-zo) + (get-compiled-file-sha1 renderer-path) + (get-file-sha1 css-path))]) + (with-compile-output stamp-file (lambda (out tmp-filename) (write data out))) + (let ([m (max aux-time src-time)]) + (unless (equal? m +inf.0) + (file-or-directory-modify-seconds stamp-file m))))) + info)))) + (lambda () #f)) + #f)))) (define (make-prod-thread) ;; periodically dumps a stack trace, which can give us some idea of @@ -701,62 +701,69 @@ expr #; (begin - (printf "For ~a\n" what) - (time expr)) + (printf "For ~a\n" what) + (time expr)) #; (begin - (collect-garbage) (collect-garbage) (printf "pre: ~a ~s\n" what (current-memory-use)) - (begin0 - (time expr) - (collect-garbage) (collect-garbage) (printf "post ~a ~s\n" what (current-memory-use))))) + (collect-garbage) (collect-garbage) (printf "pre: ~a ~s\n" what (current-memory-use)) + (begin0 + (time expr) + (collect-garbage) (collect-garbage) (printf "post ~a ~s\n" what (current-memory-use))))) (define (load-sxrefs latex-dest doc vers) (match (list (load-sxref (sxref-path latex-dest doc "in.sxref")) (load-sxref (sxref-path latex-dest doc "out.sxref"))) [(list (list in-version undef deps-rel searches dep-docs) (list out-version sci provides)) - (unless (and (equal? in-version (list vers (doc-flags doc))) - (equal? out-version (list vers (doc-flags doc)))) - (error "old info has wrong version or flags")) - (with-my-namespace* - (values (deserialize undef) deps-rel (deserialize searches) (deserialize dep-docs) sci (deserialize provides)))])) + (unless (and (equal? in-version (list vers (doc-flags doc))) + (equal? out-version (list vers (doc-flags doc)))) + (error "old info has wrong version or flags")) + (with-my-namespace* + (values (deserialize undef) + deps-rel + (deserialize searches) + (map rel-doc->doc (deserialize dep-docs)) + sci + (deserialize provides)))])) (define (build-again! latex-dest info with-record-error) (define (cleanup-dest-dir doc) (unless latex-dest (let ([dir (doc-dest-dir doc)]) (if (not (directory-exists? dir)) - (make-directory*/ignore-exists-exn dir) - (for ([f (directory-list dir)] - #:when - (and (file-exists? f) - (not (regexp-match? #"[.]sxref$" - (path-element->bytes f))))) - (delete-file (build-path dir f))))))) + (make-directory*/ignore-exists-exn dir) + (for ([f (directory-list dir)] + #:when + (and (file-exists? f) + (not (regexp-match? #"[.]sxref$" + (path-element->bytes f))))) + (delete-file (build-path dir f))))))) (define (load-doc-sci doc) (cadr (load-sxref (sxref-path latex-dest doc "out.sxref")))) (define doc (if (info? info ) (info-doc info) info)) (define renderer (make-renderer latex-dest doc)) (with-record-error - (doc-src-file doc) - (lambda () - (define vers (send renderer get-serialize-version)) - (define-values (ff-undef ff-deps-rel ff-searches ff-dep-docs ff-sci ff-provides) - (if (info? info) - (values (info-undef info) - (info-deps->rel-doc-src-file info) - (info-searches info) - (info-deps->doc info) - (load-doc-sci doc) - (info-provides info)) - (load-sxrefs latex-dest doc vers))) - - (parameterize ([current-directory (doc-src-dir doc)]) - (let* ([v (render-time "load" (load-doc/ensure-prefix doc))] + (doc-src-file doc) + (lambda () + (define vers (send renderer get-serialize-version)) + (define-values (ff-undef ff-deps-rel ff-searches ff-dep-docs ff-sci ff-provides) + (if (info? info) + (values (info-undef info) + (info-deps->rel-doc-src-file info) + (info-searches info) + (info-deps->doc info) + (load-doc-sci doc) + (info-provides info)) + (load-sxrefs latex-dest doc vers))) + + (parameterize ([current-directory (doc-src-dir doc)]) + (let* ([v (render-time "load" (load-doc/ensure-prefix doc))] [dest-dir (pick-dest latex-dest doc)] [fp (render-time "traverse" (send renderer traverse (list v) (list dest-dir)))] [ci (render-time "collect" (send renderer collect (list v) (list dest-dir) fp))] [ri (begin - (render-time "deserialize" (with-my-namespace* (for ([dep-doc ff-dep-docs]) - (send renderer deserialize-info (load-doc-sci dep-doc) ci)))) + (render-time "deserialize" + (with-my-namespace* + (for ([dep-doc ff-dep-docs]) + (send renderer deserialize-info (load-doc-sci dep-doc) ci)))) (render-time "resolve" (send renderer resolve (list v) (list dest-dir) ci)))] [sci (render-time "serialize" (send renderer serialize-info ri))] [defs (render-time "defined" (send renderer get-defined ci))] @@ -764,28 +771,28 @@ [in-delta? (not (equal? (any-order undef) (any-order ff-undef)))] [out-delta? (or (not (serialized=? sci ff-sci)) (not (equal? (any-order defs) (any-order ff-provides))))]) - (when (verbose) - (printf " [~a~afor ~a]\n" - (if in-delta? "New in " "") - (cond [out-delta? "New out "] - [in-delta? ""] - [else "No change "]) - (doc-src-file doc))) + (when (verbose) + (printf " [~a~afor ~a]\n" + (if in-delta? "New in " "") + (cond [out-delta? "New out "] + [in-delta? ""] + [else "No change "]) + (doc-src-file doc))) - (when in-delta? - (render-time "xref-in" (write-in latex-dest vers doc undef ff-deps-rel ff-searches ff-dep-docs))) - (when out-delta? - (render-time "xref-out" (write-out latex-dest vers doc sci defs))) + (when in-delta? + (render-time "xref-in" (write-in latex-dest vers doc undef ff-deps-rel ff-searches ff-dep-docs))) + (when out-delta? + (render-time "xref-out" (write-out latex-dest vers doc sci defs))) - (cleanup-dest-dir doc) - (render-time - "render" - (with-record-error - (doc-src-file doc) - (lambda () (send renderer render (list v) (list dest-dir) ri)) - void)) - (gc-point) - (list in-delta? out-delta? defs undef)))) + (cleanup-dest-dir doc) + (render-time + "render" + (with-record-error + (doc-src-file doc) + (lambda () (send renderer render (list v) (list dest-dir) ri)) + void)) + (gc-point) + (list in-delta? out-delta? defs undef)))) (lambda () #f))) (define (gc-point) @@ -825,8 +832,8 @@ (when (verbose) (printf " [Caching to disk ~a]\n" filename)) (make-directory*/ignore-exists-exn (doc-dest-dir doc)) (with-compile-output filename - (lambda (out tmp-filename) - (write-bytes (s-exp->fasl (append (list (list vers (doc-flags doc))) data)) out))))) + (lambda (out tmp-filename) + (write-bytes (s-exp->fasl (append (list (list vers (doc-flags doc))) data)) out))))) (define (write-out latex-dest vers doc sci provides) (write- latex-dest vers doc "out.sxref" @@ -835,13 +842,20 @@ (define (write-out/info latex-dest info sci) (write-out latex-dest (info-vers info) (info-doc info) sci (info-provides info))) - + (define (write-in latex-dest vers doc undef rels searches dep-docs) (write- latex-dest vers doc "in.sxref" - (list (serialize undef) - rels - (serialize searches) - (serialize dep-docs)))) + (list (serialize undef) + rels + (serialize searches) + ;; The following last element is used only by the parallel build. + ;; It's redundant in the sense that the same information + ;; is in `rels' --- the docs that this one depends on --- + ;; but putting the whole `doc' record here makes it easier + ;; for a place to reconstruct a suitable `doc' record. + ;; It probably would be better to reconstruct the `doc' + ;; record in a place from the path. + (serialize (map doc->rel-doc dep-docs))))) (define (write-in/info latex-dest info) (write-in latex-dest @@ -863,6 +877,20 @@ (path->bytes r) r))) +(define (doc->rel-doc d) + (struct-copy doc + d + [src-dir (path->main-collects-relative (doc-src-dir d))] + [src-file (path->main-collects-relative (doc-src-file d))] + [dest-dir (path->main-doc-relative (doc-dest-dir d))])) + +(define (rel-doc->doc d) + (struct-copy doc + d + [src-dir (main-collects-relative->path (doc-src-dir d))] + [src-file (main-collects-relative->path (doc-src-file d))] + [dest-dir (main-doc-relative->path (doc-dest-dir d))])) + (define (info-deps->rel-doc-src-file info) (filter-map (lambda (i) (and (info? i) (path->rel (doc-src-file (info-doc i))))) From 437fc45ce466b04f615c7c31982aa782c26dab56 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 4 Sep 2011 12:12:29 -0400 Subject: [PATCH 124/235] Up timeouts for htdp-lang tests. --- collects/meta/props | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/meta/props b/collects/meta/props index 1e9b9d75a0..41cd5fcde5 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1504,7 +1504,7 @@ path/s is either such a string or a list of them. "collects/tests/gracket/wxme.rkt" drdr:command-line (gracket-text "-t" *) "collects/tests/honu" responsible (rafkind) "collects/tests/htdp-lang" responsible (robby mflatt matthias) -"collects/tests/htdp-lang/advanced.rktl" drdr:command-line (racket "-f" *) drdr:timeout 180 +"collects/tests/htdp-lang/advanced.rktl" drdr:command-line (racket "-f" *) drdr:timeout 360 "collects/tests/htdp-lang/basic.rktl" drdr:command-line #f "collects/tests/htdp-lang/beg-adv.rktl" drdr:command-line #f "collects/tests/htdp-lang/beg-bega.rktl" drdr:command-line #f @@ -1516,8 +1516,8 @@ path/s is either such a string or a list of them. "collects/tests/htdp-lang/htdp-image.rktl" responsible (robby) drdr:command-line (gracket "-f" *) "collects/tests/htdp-lang/htdp-test.rktl" drdr:command-line (racket "-f" *) "collects/tests/htdp-lang/htdp.rktl" drdr:command-line #f -"collects/tests/htdp-lang/intermediate-lambda.rktl" drdr:command-line (racket "-f" *) -"collects/tests/htdp-lang/intermediate.rktl" drdr:command-line (racket "-f" *) +"collects/tests/htdp-lang/intermediate-lambda.rktl" drdr:command-line (racket "-f" *) drdr:timeout 360 +"collects/tests/htdp-lang/intermediate.rktl" drdr:command-line (racket "-f" *) drdr:timeout 360 "collects/tests/htdp-lang/intm-adv.rktl" drdr:command-line #f "collects/tests/htdp-lang/intm-intml.rktl" drdr:command-line #f "collects/tests/htdp-lang/intmlam-adv.rktl" drdr:command-line #f From c0b4743b407f6ddf09a7c7bf78b7b66f6c311d81 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 4 Sep 2011 12:58:13 -0400 Subject: [PATCH 125/235] Tests for all Typed Racket languages, and add missing ones. --- .../tests/typed-racket/succeed/standard-features-base.rkt | 7 +++++++ .../succeed/standard-features-no-check-base.rkt | 7 +++++++ .../succeed/standard-features-no-check-scheme-base.rkt | 7 +++++++ .../succeed/standard-features-no-check-scheme.rkt | 7 +++++++ .../succeed/standard-features-no-check-ts.rkt | 7 +++++++ .../typed-racket/succeed/standard-features-no-check.rkt | 7 +++++++ .../succeed/standard-features-scheme-base.rkt | 7 +++++++ .../typed-racket/succeed/standard-features-scheme.rkt | 7 +++++++ .../tests/typed-racket/succeed/standard-features-ts.rkt | 7 +++++++ collects/tests/typed-racket/succeed/standard-features.rkt | 7 +++++++ collects/typed/scheme/base/no-check.rkt | 4 ++++ collects/typed/scheme/base/no-check/lang/reader.rkt | 8 ++++++++ collects/typed/scheme/no-check.rkt | 4 ++++ collects/typed/scheme/no-check/lang/reader.rkt | 8 ++++++++ 14 files changed, 94 insertions(+) create mode 100644 collects/tests/typed-racket/succeed/standard-features-base.rkt create mode 100644 collects/tests/typed-racket/succeed/standard-features-no-check-base.rkt create mode 100644 collects/tests/typed-racket/succeed/standard-features-no-check-scheme-base.rkt create mode 100644 collects/tests/typed-racket/succeed/standard-features-no-check-scheme.rkt create mode 100644 collects/tests/typed-racket/succeed/standard-features-no-check-ts.rkt create mode 100644 collects/tests/typed-racket/succeed/standard-features-no-check.rkt create mode 100644 collects/tests/typed-racket/succeed/standard-features-scheme-base.rkt create mode 100644 collects/tests/typed-racket/succeed/standard-features-scheme.rkt create mode 100644 collects/tests/typed-racket/succeed/standard-features-ts.rkt create mode 100644 collects/tests/typed-racket/succeed/standard-features.rkt create mode 100644 collects/typed/scheme/base/no-check.rkt create mode 100644 collects/typed/scheme/base/no-check/lang/reader.rkt create mode 100644 collects/typed/scheme/no-check.rkt create mode 100644 collects/typed/scheme/no-check/lang/reader.rkt diff --git a/collects/tests/typed-racket/succeed/standard-features-base.rkt b/collects/tests/typed-racket/succeed/standard-features-base.rkt new file mode 100644 index 0000000000..f3e6d4ceeb --- /dev/null +++ b/collects/tests/typed-racket/succeed/standard-features-base.rkt @@ -0,0 +1,7 @@ +#lang typed/racket/base + +(: f (Integer -> Any)) +(define (f x) (add1 x)) + +(lambda (#{x : String}) (string-append " " x)) + diff --git a/collects/tests/typed-racket/succeed/standard-features-no-check-base.rkt b/collects/tests/typed-racket/succeed/standard-features-no-check-base.rkt new file mode 100644 index 0000000000..8323187a68 --- /dev/null +++ b/collects/tests/typed-racket/succeed/standard-features-no-check-base.rkt @@ -0,0 +1,7 @@ +#lang typed/racket/base/no-check + +(: f (Integer -> Any)) +(define (f x) (add1 "")) + +(lambda (#{x : String}) (string-append " " x)) + diff --git a/collects/tests/typed-racket/succeed/standard-features-no-check-scheme-base.rkt b/collects/tests/typed-racket/succeed/standard-features-no-check-scheme-base.rkt new file mode 100644 index 0000000000..2c95d8cc2d --- /dev/null +++ b/collects/tests/typed-racket/succeed/standard-features-no-check-scheme-base.rkt @@ -0,0 +1,7 @@ +#lang typed/scheme/base/no-check + +(: f (Integer -> Any)) +(define (f x) (add1 "")) + +(lambda (#{x : String}) (string-append " " x)) + diff --git a/collects/tests/typed-racket/succeed/standard-features-no-check-scheme.rkt b/collects/tests/typed-racket/succeed/standard-features-no-check-scheme.rkt new file mode 100644 index 0000000000..d94b0ffb00 --- /dev/null +++ b/collects/tests/typed-racket/succeed/standard-features-no-check-scheme.rkt @@ -0,0 +1,7 @@ +#lang typed/scheme/no-check + +(: f (Integer -> Any)) +(define (f x) (add1 "")) + +(lambda (#{x : String}) (string-append " " x)) + diff --git a/collects/tests/typed-racket/succeed/standard-features-no-check-ts.rkt b/collects/tests/typed-racket/succeed/standard-features-no-check-ts.rkt new file mode 100644 index 0000000000..5c13b257ca --- /dev/null +++ b/collects/tests/typed-racket/succeed/standard-features-no-check-ts.rkt @@ -0,0 +1,7 @@ +#lang typed-scheme/no-check + +(: f (Integer -> Any)) +(define (f x) (add1 "")) + +(lambda (#{x : String}) (string-append " " x)) + diff --git a/collects/tests/typed-racket/succeed/standard-features-no-check.rkt b/collects/tests/typed-racket/succeed/standard-features-no-check.rkt new file mode 100644 index 0000000000..df409d2c7e --- /dev/null +++ b/collects/tests/typed-racket/succeed/standard-features-no-check.rkt @@ -0,0 +1,7 @@ +#lang typed/racket/no-check + +(: f (Integer -> Any)) +(define (f x) (add1 "")) + +(lambda (#{x : String}) (string-append " " x)) + diff --git a/collects/tests/typed-racket/succeed/standard-features-scheme-base.rkt b/collects/tests/typed-racket/succeed/standard-features-scheme-base.rkt new file mode 100644 index 0000000000..498f1dad7b --- /dev/null +++ b/collects/tests/typed-racket/succeed/standard-features-scheme-base.rkt @@ -0,0 +1,7 @@ +#lang typed/scheme/base + +(: f (Integer -> Any)) +(define (f x) (add1 x)) + +(lambda (#{x : String}) (string-append " " x)) + diff --git a/collects/tests/typed-racket/succeed/standard-features-scheme.rkt b/collects/tests/typed-racket/succeed/standard-features-scheme.rkt new file mode 100644 index 0000000000..f6f3ff2d38 --- /dev/null +++ b/collects/tests/typed-racket/succeed/standard-features-scheme.rkt @@ -0,0 +1,7 @@ +#lang typed/scheme + +(: f (Integer -> Any)) +(define (f x) (add1 x)) + +(lambda (#{x : String}) (string-append " " x)) + diff --git a/collects/tests/typed-racket/succeed/standard-features-ts.rkt b/collects/tests/typed-racket/succeed/standard-features-ts.rkt new file mode 100644 index 0000000000..00782c87f9 --- /dev/null +++ b/collects/tests/typed-racket/succeed/standard-features-ts.rkt @@ -0,0 +1,7 @@ +#lang typed-scheme + +(: f (Integer -> Any)) +(define (f x) (add1 x)) + +(lambda (#{x : String}) (string-append " " x)) + diff --git a/collects/tests/typed-racket/succeed/standard-features.rkt b/collects/tests/typed-racket/succeed/standard-features.rkt new file mode 100644 index 0000000000..d99f5b89ec --- /dev/null +++ b/collects/tests/typed-racket/succeed/standard-features.rkt @@ -0,0 +1,7 @@ +#lang typed/racket + +(: f (Integer -> Any)) +(define (f x) (add1 x)) + +(lambda (#{x : String}) (string-append " " x)) + diff --git a/collects/typed/scheme/base/no-check.rkt b/collects/typed/scheme/base/no-check.rkt new file mode 100644 index 0000000000..d8d95d096f --- /dev/null +++ b/collects/typed/scheme/base/no-check.rkt @@ -0,0 +1,4 @@ +#lang typed-racket/minimal + +(require racket/require typed-scheme/no-check (subtract-in typed/scheme/base typed-scheme/no-check)) +(provide (all-from-out typed/scheme/base typed-scheme/no-check)) diff --git a/collects/typed/scheme/base/no-check/lang/reader.rkt b/collects/typed/scheme/base/no-check/lang/reader.rkt new file mode 100644 index 0000000000..579a3f8f20 --- /dev/null +++ b/collects/typed/scheme/base/no-check/lang/reader.rkt @@ -0,0 +1,8 @@ +#lang s-exp syntax/module-reader + +typed/scheme/base/no-check + +#:read r:read +#:read-syntax r:read-syntax + +(require (prefix-in r: typed-racket/typed-reader)) diff --git a/collects/typed/scheme/no-check.rkt b/collects/typed/scheme/no-check.rkt new file mode 100644 index 0000000000..0f74ed198e --- /dev/null +++ b/collects/typed/scheme/no-check.rkt @@ -0,0 +1,4 @@ +#lang typed-racket/minimal + +(require racket/require typed-scheme/no-check (subtract-in typed/scheme typed-scheme/no-check)) +(provide (all-from-out typed/scheme typed-scheme/no-check)) diff --git a/collects/typed/scheme/no-check/lang/reader.rkt b/collects/typed/scheme/no-check/lang/reader.rkt new file mode 100644 index 0000000000..1084e9350a --- /dev/null +++ b/collects/typed/scheme/no-check/lang/reader.rkt @@ -0,0 +1,8 @@ +#lang s-exp syntax/module-reader + +typed/scheme/no-check + +#:read r:read +#:read-syntax r:read-syntax + +(require (prefix-in r: typed-racket/typed-reader)) From fd0a2e98798073ba9baf8d805ce31923f1468b1c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 4 Sep 2011 15:32:37 -0600 Subject: [PATCH 126/235] avoid an internal error Closes PR 12138 --- collects/scribble/private/manual-vars.rkt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/scribble/private/manual-vars.rkt b/collects/scribble/private/manual-vars.rkt index 1d4bea712f..e37357ba91 100644 --- a/collects/scribble/private/manual-vars.rkt +++ b/collects/scribble/private/manual-vars.rkt @@ -73,7 +73,9 @@ (let loop ([form (case (syntax-e kind) [(form) (if (identifier? s-exp) null - (cdr (syntax-e s-exp)))] + (if (pair? (syntax-e s-exp)) + (cdr (syntax-e s-exp)) + null))] [(form/none) s-exp] [(form/maybe) (syntax-case s-exp () From ee6104b4fc1c0ee5acf8866adbda9ab227ba6624 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 4 Sep 2011 15:40:15 -0600 Subject: [PATCH 127/235] fix `subprocess-status' when places are enabled Closes PR 12158 --- collects/tests/racket/subprocess.rktl | 23 ++++++++++++++--------- src/racket/src/place.c | 4 ++-- src/racket/src/port.c | 23 +++++++++++++++-------- src/racket/src/schpriv.h | 1 + 4 files changed, 32 insertions(+), 19 deletions(-) diff --git a/collects/tests/racket/subprocess.rktl b/collects/tests/racket/subprocess.rktl index 87ee144ac3..4ef1d5e63c 100644 --- a/collects/tests/racket/subprocess.rktl +++ b/collects/tests/racket/subprocess.rktl @@ -413,15 +413,13 @@ "-e" "(let loop () (loop))"))] [running? (lambda (sub-pid) - (equal? - (list (number->string sub-pid)) - (regexp-match - (format "(?m:^ *~a(?=[^0-9]))" sub-pid) - (let ([s (open-output-string)]) - (parameterize ([current-output-port s] - [current-input-port (open-input-string "")]) - (system (format "ps x"))) - (get-output-string s)))))]) + (regexp-match? + (format "(?m:^ *~a(?=[^0-9]))" sub-pid) + (let ([s (open-output-string)]) + (parameterize ([current-output-port s] + [current-input-port (open-input-string "")]) + (system (format "ps x"))) + (get-output-string s))))]) (let ([sub-pid (read (car l))]) (test 'running (list-ref l 4) 'status) (test #t running? sub-pid) @@ -436,6 +434,13 @@ (try #f))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Check status result + +(unless (eq? (system-type) 'windows) + (parameterize ([current-input-port (open-input-string "")]) + (test 3 system/exit-code "exit 3"))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/src/racket/src/place.c b/src/racket/src/place.c index 3567402f2d..ef59c6cfc5 100644 --- a/src/racket/src/place.c +++ b/src/racket/src/place.c @@ -517,7 +517,7 @@ int scheme_get_child_status(int pid, int is_group, int *status) { } while ((pid2 == -1) && (errno == EINTR)); if (pid2 > 0) - add_child_status(pid, status); + add_child_status(pid, scheme_extract_child_status(status)); } mzrt_mutex_lock(child_status_lock); @@ -631,7 +631,7 @@ static void *mz_proc_thread_signal_worker(void *data) { free(unused_status); unused_status = next; } else - add_child_status(pid, status); + add_child_status(pid, scheme_extract_child_status(status)); } else { if (is_group) { prev_unused = unused_status; diff --git a/src/racket/src/port.c b/src/racket/src/port.c index 46924d65c1..357b12d7e0 100644 --- a/src/racket/src/port.c +++ b/src/racket/src/port.c @@ -7448,14 +7448,7 @@ static void check_child_done(pid_t pid) unused = (void **)next; } - START_XFORM_SKIP; - if (WIFEXITED(status)) - status = WEXITSTATUS(status); - else if (WIFSIGNALED(status)) - status = WTERMSIG(status) + 128; - else - status = MZ_FAILURE_STATUS; - END_XFORM_SKIP; + status = scheme_extract_child_status(status); prev = NULL; for (sc = scheme_system_children; sc; prev = sc, sc = sc->next) { @@ -7489,6 +7482,20 @@ void scheme_check_child_done(void) #endif +#if defined(UNIX_PROCESSES) +int scheme_extract_child_status(int status) XFORM_SKIP_PROC +{ + if (WIFEXITED(status)) + status = WEXITSTATUS(status); + else if (WIFSIGNALED(status)) + status = WTERMSIG(status) + 128; + else + status = MZ_FAILURE_STATUS; + + return status; +} +#endif + /*========================================================================*/ /* null output ports */ /*========================================================================*/ diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index 0f6cc2429c..bb804c6193 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -514,6 +514,7 @@ void scheme_kickoff_green_thread_time_slice_timer(intptr_t usec); #ifdef UNIX_PROCESSES void scheme_block_child_signals(int block); void scheme_check_child_done(void); +int scheme_extract_child_status(int status); #endif void scheme_prepare_this_thread_for_GC(Scheme_Thread *t); From b77a841dd8925414eadb904b408cb1571be585d5 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 4 Sep 2011 22:08:56 -0400 Subject: [PATCH 128/235] Switch to `typed/racket/base', and remove unused definition. --- collects/drracket/private/auto-language.rkt | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/collects/drracket/private/auto-language.rkt b/collects/drracket/private/auto-language.rkt index 35088ef977..44ec5a5d5e 100644 --- a/collects/drracket/private/auto-language.rkt +++ b/collects/drracket/private/auto-language.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed/racket/base (require typed/framework/framework typed/mred/mred @@ -6,9 +6,6 @@ (provide pick-new-language looks-like-module?) -(: reader-tag String) -(define reader-tag "#reader") - (define-type-alias (Language:Language% Settings) (Class () () ([get-reader-module (-> Sexp)] [get-metadata-lines (-> Number)] From 746aea002420c8abb7c281720fac22aedc497352 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 5 Sep 2011 00:08:17 -0400 Subject: [PATCH 129/235] "typed-scheme" -> "typed-racket". --- collects/typed/srfi/14.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed/srfi/14.rkt b/collects/typed/srfi/14.rkt index 70b2866fb6..44e9f2c74b 100644 --- a/collects/typed/srfi/14.rkt +++ b/collects/typed/srfi/14.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed/racket/base (require/opaque-type Char-Set char-set? srfi/14) (define-type-alias Cursor (Pair 0 (Listof (Pair Integer Integer)))) From fde857e0cbb5a1099eba0f8c88d1570f59d39746 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 5 Sep 2011 00:34:05 -0400 Subject: [PATCH 130/235] Some more "typed-scheme" -> "typed-racket". --- collects/typed/file/gif.rkt | 2 +- collects/typed/file/md5.rkt | 2 +- collects/typed/file/tar.rkt | 4 ++-- collects/typed/framework/framework.rkt | 2 +- collects/typed/net/base64.rkt | 2 +- collects/typed/net/cgi.rkt | 2 +- collects/typed/net/cookie.rkt | 2 +- collects/typed/net/dns.rkt | 3 +-- collects/typed/net/ftp.rkt | 2 +- collects/typed/net/gifwrite.rkt | 2 +- collects/typed/net/head.rkt | 2 +- collects/typed/net/imap.rkt | 2 +- collects/typed/net/mime.rkt | 2 +- collects/typed/net/nntp.rkt | 2 +- collects/typed/net/pop3.rkt | 2 +- collects/typed/net/qp.rkt | 2 +- collects/typed/net/sendmail.rkt | 2 +- collects/typed/net/sendurl.rkt | 10 +++++----- collects/typed/net/smtp.rkt | 2 +- collects/typed/net/uri-codec.rkt | 2 +- collects/typed/net/url.rkt | 2 +- collects/typed/private/utils.rkt | 2 +- 22 files changed, 27 insertions(+), 28 deletions(-) diff --git a/collects/typed/file/gif.rkt b/collects/typed/file/gif.rkt index 6f96c976d8..1c18644afe 100644 --- a/collects/typed/file/gif.rkt +++ b/collects/typed/file/gif.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed/racket/base (require typed/private/utils) diff --git a/collects/typed/file/md5.rkt b/collects/typed/file/md5.rkt index 0cab46d7ba..44ca600b78 100644 --- a/collects/typed/file/md5.rkt +++ b/collects/typed/file/md5.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed/racket/base (require/typed file/md5 [md5 ((U Bytes Input-Port) -> Bytes)]) (provide md5) diff --git a/collects/typed/file/tar.rkt b/collects/typed/file/tar.rkt index 0497d8c9fc..4d34a624b5 100644 --- a/collects/typed/file/tar.rkt +++ b/collects/typed/file/tar.rkt @@ -1,5 +1,5 @@ -#lang typed-scheme -;; typed-scheme wrapper on file/tar +#lang typed/racket/base +;; typed-racket wrapper on file/tar ;; yc 2009/2/25 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/collects/typed/framework/framework.rkt b/collects/typed/framework/framework.rkt index 23f267e67b..84094c24e5 100644 --- a/collects/typed/framework/framework.rkt +++ b/collects/typed/framework/framework.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed/racket/base (require typed/private/utils typed/mred/mred) diff --git a/collects/typed/net/base64.rkt b/collects/typed/net/base64.rkt index 0745794516..10f4392fdb 100644 --- a/collects/typed/net/base64.rkt +++ b/collects/typed/net/base64.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed/racket/base (require typed/private/utils) diff --git a/collects/typed/net/cgi.rkt b/collects/typed/net/cgi.rkt index 80c3b0de55..364a4325c3 100644 --- a/collects/typed/net/cgi.rkt +++ b/collects/typed/net/cgi.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed/racket/base (require typed/private/utils) diff --git a/collects/typed/net/cookie.rkt b/collects/typed/net/cookie.rkt index 3eb8092adf..bf78fc0000 100644 --- a/collects/typed/net/cookie.rkt +++ b/collects/typed/net/cookie.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed/racket/base (require typed/private/utils) diff --git a/collects/typed/net/dns.rkt b/collects/typed/net/dns.rkt index 24ef679f81..db33203cad 100644 --- a/collects/typed/net/dns.rkt +++ b/collects/typed/net/dns.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed/racket/base (require typed/private/utils) @@ -7,4 +7,3 @@ [dns-get-name (String String -> String)] [dns-get-mail-exchanger (String String -> String )] [dns-find-nameserver (-> (Option String))]) - diff --git a/collects/typed/net/ftp.rkt b/collects/typed/net/ftp.rkt index 041befc0d5..3299ab67e8 100644 --- a/collects/typed/net/ftp.rkt +++ b/collects/typed/net/ftp.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed/racket/base (require typed/private/utils) diff --git a/collects/typed/net/gifwrite.rkt b/collects/typed/net/gifwrite.rkt index cfe9167c5b..a2e550b734 100644 --- a/collects/typed/net/gifwrite.rkt +++ b/collects/typed/net/gifwrite.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed/racket/base (require typed/file/gif) (provide (all-from-out typed/file/gif)) diff --git a/collects/typed/net/head.rkt b/collects/typed/net/head.rkt index ec6493dc69..66c7530bee 100644 --- a/collects/typed/net/head.rkt +++ b/collects/typed/net/head.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed/racket/base (require typed/private/utils) diff --git a/collects/typed/net/imap.rkt b/collects/typed/net/imap.rkt index 0e347e4082..ce2bd631dc 100644 --- a/collects/typed/net/imap.rkt +++ b/collects/typed/net/imap.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed/racket/base (require typed/private/utils) diff --git a/collects/typed/net/mime.rkt b/collects/typed/net/mime.rkt index 82893b26e5..f65294e99c 100644 --- a/collects/typed/net/mime.rkt +++ b/collects/typed/net/mime.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed/racket/base (require typed/private/utils) ;; -- basic mime structures -- diff --git a/collects/typed/net/nntp.rkt b/collects/typed/net/nntp.rkt index f2310c9350..cb540e0ac9 100644 --- a/collects/typed/net/nntp.rkt +++ b/collects/typed/net/nntp.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed/racket/base (require typed/private/utils) diff --git a/collects/typed/net/pop3.rkt b/collects/typed/net/pop3.rkt index 395b3a7be7..0190ceef9e 100644 --- a/collects/typed/net/pop3.rkt +++ b/collects/typed/net/pop3.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed/racket/base (require typed/private/utils) diff --git a/collects/typed/net/qp.rkt b/collects/typed/net/qp.rkt index 9d0344a2e5..814161cac7 100644 --- a/collects/typed/net/qp.rkt +++ b/collects/typed/net/qp.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed/racket/base (require typed/private/utils) diff --git a/collects/typed/net/sendmail.rkt b/collects/typed/net/sendmail.rkt index 113dc250d4..958d75df1a 100644 --- a/collects/typed/net/sendmail.rkt +++ b/collects/typed/net/sendmail.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed/racket/base (require typed/private/utils) diff --git a/collects/typed/net/sendurl.rkt b/collects/typed/net/sendurl.rkt index 2be923fc7b..84d90af1e7 100644 --- a/collects/typed/net/sendurl.rkt +++ b/collects/typed/net/sendurl.rkt @@ -1,8 +1,8 @@ -#lang typed-scheme +#lang typed/racket/base (require/typed net/sendurl - [send-url (String -> Void)] - [unix-browser-list (Listof Symbol)] - [browser-preference? (String -> Boolean)] - [external-browser (-> (U Symbol #f (Pair String String)))]) + [send-url (String -> Void)] + [unix-browser-list (Listof Symbol)] + [browser-preference? (String -> Boolean)] + [external-browser (-> (U Symbol #f (Pair String String)))]) (provide send-url unix-browser-list browser-preference? external-browser) diff --git a/collects/typed/net/smtp.rkt b/collects/typed/net/smtp.rkt index 78b02ff651..18791c9847 100644 --- a/collects/typed/net/smtp.rkt +++ b/collects/typed/net/smtp.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed/racket/base (require typed/private/utils) diff --git a/collects/typed/net/uri-codec.rkt b/collects/typed/net/uri-codec.rkt index 2089712c26..ed89cf33ec 100644 --- a/collects/typed/net/uri-codec.rkt +++ b/collects/typed/net/uri-codec.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed/racket/base (require typed/private/utils) diff --git a/collects/typed/net/url.rkt b/collects/typed/net/url.rkt index 20b4196e08..f435cb0f3e 100644 --- a/collects/typed/net/url.rkt +++ b/collects/typed/net/url.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed/racket/base (require typed/private/utils) diff --git a/collects/typed/private/utils.rkt b/collects/typed/private/utils.rkt index 5abf5a87f2..46ef552449 100644 --- a/collects/typed/private/utils.rkt +++ b/collects/typed/private/utils.rkt @@ -1,4 +1,4 @@ -#lang typed-scheme +#lang typed/racket/base (define-syntax-rule (dt nm t) (begin (define-type-alias nm t) (provide nm))) From 8c9404642b4ed99d79f785e502cd2f361875569b Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 5 Sep 2011 00:34:16 -0400 Subject: [PATCH 131/235] Remove uses of `scheme' in db docs. --- collects/db/scribblings/sql-types.scrbl | 140 ++++++++++++------------ collects/db/scribblings/util.scrbl | 2 +- 2 files changed, 71 insertions(+), 71 deletions(-) diff --git a/collects/db/scribblings/sql-types.scrbl b/collects/db/scribblings/sql-types.scrbl index bc2e666250..eb8066f28b 100644 --- a/collects/db/scribblings/sql-types.scrbl +++ b/collects/db/scribblings/sql-types.scrbl @@ -2,7 +2,7 @@ @(require scribble/manual scribble/eval scribble/struct - scheme/sandbox + racket/sandbox "config.rkt" "tabbing.rkt" (for-label (prefix-in srfi: srfi/19) @@ -57,33 +57,33 @@ along with their corresponding Racket representations. @centered{ @tabbing{ @bold{PostgreSQL type} @& @bold{pg_type.typname} @& @bold{Racket type} @// - @racket['boolean] @& @tt{bool} @& @scheme[boolean?] @// - @racket['char1] @& @tt{char} @& @scheme[char?] @// - @racket['smallint] @& @tt{int2} @& @scheme[exact-integer?] @// - @racket['integer] @& @tt{int4} @& @scheme[exact-integer?] @// - @racket['bigint] @& @tt{int8} @& @scheme[exact-integer?] @// - @racket['real] @& @tt{float4} @& @scheme[real?] @// - @racket['double] @& @tt{float8} @& @scheme[real?] @// - @racket['decimal] @& @tt{numeric} @& @scheme[number?] @// - @racket['character] @& @tt{bpchar} @& @scheme[string?] @// - @racket['varchar] @& @tt{varchar} @& @scheme[string?] @// - @racket['text] @& @tt{text} @& @scheme[string?] @// - @racket['bytea] @& @tt{bytea} @& @scheme[bytes?] @// - @racket['date] @& @tt{date} @& @scheme[sql-date?] @// - @racket['time] @& @tt{time} @& @scheme[sql-time?] @// - @racket['timetz] @& @tt{timetz} @& @scheme[sql-time?] @// - @racket['timestamp] @& @tt{timestamp} @& @scheme[sql-timestamp?] @// - @racket['timestamptz] @& @tt{timestamptz} @& @scheme[sql-timestamp?] @// - @racket['interval] @& @tt{interval} @& @scheme[sql-interval?] @// - @racket['bit] @& @tt{bit} @& @scheme[sql-bits?] @// - @racket['varbit] @& @tt{varbit} @& @scheme[sql-bits?] @// + @racket['boolean] @& @tt{bool} @& @racket[boolean?] @// + @racket['char1] @& @tt{char} @& @racket[char?] @// + @racket['smallint] @& @tt{int2} @& @racket[exact-integer?] @// + @racket['integer] @& @tt{int4} @& @racket[exact-integer?] @// + @racket['bigint] @& @tt{int8} @& @racket[exact-integer?] @// + @racket['real] @& @tt{float4} @& @racket[real?] @// + @racket['double] @& @tt{float8} @& @racket[real?] @// + @racket['decimal] @& @tt{numeric} @& @racket[number?] @// + @racket['character] @& @tt{bpchar} @& @racket[string?] @// + @racket['varchar] @& @tt{varchar} @& @racket[string?] @// + @racket['text] @& @tt{text} @& @racket[string?] @// + @racket['bytea] @& @tt{bytea} @& @racket[bytes?] @// + @racket['date] @& @tt{date} @& @racket[sql-date?] @// + @racket['time] @& @tt{time} @& @racket[sql-time?] @// + @racket['timetz] @& @tt{timetz} @& @racket[sql-time?] @// + @racket['timestamp] @& @tt{timestamp} @& @racket[sql-timestamp?] @// + @racket['timestamptz] @& @tt{timestamptz} @& @racket[sql-timestamp?] @// + @racket['interval] @& @tt{interval} @& @racket[sql-interval?] @// + @racket['bit] @& @tt{bit} @& @racket[sql-bits?] @// + @racket['varbit] @& @tt{varbit} @& @racket[sql-bits?] @// - @racket['point] @& @tt{point} @& @scheme[point?] @// - @racket['lseg] @& @tt{lseg} @& @scheme[line?] @// - @racket['path] @& @tt{path} @& @scheme[pg-path?] @// - @racket['box] @& @tt{box} @& @scheme[pg-box?] @// - @racket['polygon] @& @tt{polygon} @& @scheme[polygon?] @// - @racket['circle] @& @tt{circle} @& @scheme[pg-circle?] + @racket['point] @& @tt{point} @& @racket[point?] @// + @racket['lseg] @& @tt{lseg} @& @racket[line?] @// + @racket['path] @& @tt{path} @& @racket[pg-path?] @// + @racket['box] @& @tt{box} @& @racket[pg-box?] @// + @racket['polygon] @& @tt{polygon} @& @racket[polygon?] @// + @racket['circle] @& @tt{circle} @& @racket[pg-circle?] } } @@ -92,7 +92,7 @@ syntax (the quotation marks are significant), is one byte, essentially a tiny integer written as a character. A SQL value of type @tt{decimal} is converted to either an exact -rational or @scheme[+nan.0]. When converting Racket values to SQL +rational or @racket[+nan.0]. When converting Racket values to SQL @tt{decimal}, exact rational values representable by finite decimal strings are converted without loss of precision. (Precision may be lost, of course, if the value is then stored in a database field of @@ -136,19 +136,19 @@ with their corresponding Racket representations. @centered{ @tabbing[#:spacing 8]{ @bold{MySQL type} @& @bold{Racket type} @// - @racket['integer] @& @scheme[exact-integer?] @// - @racket['tinyint] @& @scheme[exact-integer?] @// - @racket['smallint] @& @scheme[exact-integer?] @// - @racket['mediumint] @& @scheme[exact-integer?] @// - @racket['bigint] @& @scheme[exact-integer?] @// - @racket['real] @& @scheme[real?] @// - @racket['double] @& @scheme[real?] @// - @racket['decimal] @& @scheme[exact?] @// - @racket['varchar] @& @scheme[string?] @// - @racket['var-string] @& @scheme[string?] or @scheme[bytes?], but see below @// - @racket['date] @& @scheme[sql-date?] @// - @racket['time] @& @scheme[sql-time?] or @racket[sql-day-time-interval?] @// - @racket['datetime] @& @scheme[sql-timestamp?] @// + @racket['integer] @& @racket[exact-integer?] @// + @racket['tinyint] @& @racket[exact-integer?] @// + @racket['smallint] @& @racket[exact-integer?] @// + @racket['mediumint] @& @racket[exact-integer?] @// + @racket['bigint] @& @racket[exact-integer?] @// + @racket['real] @& @racket[real?] @// + @racket['double] @& @racket[real?] @// + @racket['decimal] @& @racket[exact?] @// + @racket['varchar] @& @racket[string?] @// + @racket['var-string] @& @racket[string?] or @racket[bytes?], but see below @// + @racket['date] @& @racket[sql-date?] @// + @racket['time] @& @racket[sql-time?] or @racket[sql-day-time-interval?] @// + @racket['datetime] @& @racket[sql-timestamp?] @// @racket['blob] @& @racket[bytes?] @// @racket['tinyblob] @& @racket[bytes?] @// @@ -195,10 +195,10 @@ constraints (with the exception of @tt{integer primary key}) on @centered{ @tabbing{ @bold{SQLite storage class} @& @bold{Racket type} @// - @tt{integer} @& @scheme[exact-integer?] @// - @tt{real} @& @scheme[real?] @// - @tt{text} @& @scheme[string?] @// - @tt{blob} @& @scheme[bytes?] + @tt{integer} @& @racket[exact-integer?] @// + @tt{real} @& @racket[real?] @// + @tt{text} @& @racket[string?] @// + @tt{blob} @& @racket[bytes?] } } @@ -229,26 +229,26 @@ along with their corresponding Racket representations. @centered{ @tabbing[#:spacing 8]{ @bold{ODBC type} @& @bold{Racket type} @// - @racket['character] @& @scheme[string?] @// - @racket['varchar] @& @scheme[string?] @// - @racket['longvarchar] @& @scheme[string?] @// - @racket['numeric] @& @scheme[rational?] @// - @racket['decimal] @& @scheme[rational?] @// - @racket['integer] @& @scheme[exact-integer?] @// - @racket['tinyint] @& @scheme[exact-integer?] @// - @racket['smallint] @& @scheme[exact-integer?] @// - @racket['bigint] @& @scheme[exact-integer?] @// - @racket['float] @& @scheme[real?] @// - @racket['real] @& @scheme[real?] @// - @racket['double] @& @scheme[real?] @// - @racket['date] @& @scheme[sql-date?] @// - @racket['time] @& @scheme[sql-time?] @// - @racket['datetime] @& @scheme[sql-timestamp?] @// - @racket['timestamp] @& @scheme[sql-timestamp?] @// - @racket['binary] @& @scheme[bytes?] @// - @racket['varbinary] @& @scheme[bytes?] @// - @racket['longvarbinary] @& @scheme[bytes?] @// - @racket['bit1] @& @scheme[boolean?] + @racket['character] @& @racket[string?] @// + @racket['varchar] @& @racket[string?] @// + @racket['longvarchar] @& @racket[string?] @// + @racket['numeric] @& @racket[rational?] @// + @racket['decimal] @& @racket[rational?] @// + @racket['integer] @& @racket[exact-integer?] @// + @racket['tinyint] @& @racket[exact-integer?] @// + @racket['smallint] @& @racket[exact-integer?] @// + @racket['bigint] @& @racket[exact-integer?] @// + @racket['float] @& @racket[real?] @// + @racket['real] @& @racket[real?] @// + @racket['double] @& @racket[real?] @// + @racket['date] @& @racket[sql-date?] @// + @racket['time] @& @racket[sql-time?] @// + @racket['datetime] @& @racket[sql-timestamp?] @// + @racket['timestamp] @& @racket[sql-timestamp?] @// + @racket['binary] @& @racket[bytes?] @// + @racket['varbinary] @& @racket[bytes?] @// + @racket['longvarbinary] @& @racket[bytes?] @// + @racket['bit1] @& @racket[boolean?] } } @@ -281,13 +281,13 @@ that have no existing appropriate counterpart in Racket. @subsection{SQL NULL} -SQL @tt{NULL} is translated into the unique @scheme[sql-null] value. +SQL @tt{NULL} is translated into the unique @racket[sql-null] value. @defthing[sql-null sql-null?]{ A special value used to represent @tt{NULL} values in query - results. The @scheme[sql-null] value may be recognized using - @scheme[eq?]. + results. The @racket[sql-null] value may be recognized using + @racket[eq?]. @(examples/results [(query-value c "select NULL") @@ -362,12 +362,12 @@ values. Represents SQL times and timestamps. - The @scheme[tz] field indicates the time zone offset as the number + The @racket[tz] field indicates the time zone offset as the number of seconds east of GMT (as in SRFI 19). If @racket[tz] is @racket[#f], the time or timestamp does not carry time zone information. - The @scheme[sql-time] and @scheme[sql-timestamp] structures store + The @racket[sql-time] and @racket[sql-timestamp] structures store fractional seconds to nanosecond precision for compatibility with SRFI 19. Note, however, that database systems generally do not support nanosecond precision; PostgreSQL, for example, only supports diff --git a/collects/db/scribblings/util.scrbl b/collects/db/scribblings/util.scrbl index 75650bf970..ddaf4d041e 100644 --- a/collects/db/scribblings/util.scrbl +++ b/collects/db/scribblings/util.scrbl @@ -2,7 +2,7 @@ @(require scribble/manual scribble/eval scribble/struct - scheme/sandbox + racket/sandbox "config.rkt" (for-label db db/util/datetime db/util/geometry db/util/postgresql)) From 80c9e3c5d5f19ef870f784d8005b4045efda3ff7 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 3 Sep 2011 10:45:02 -0500 Subject: [PATCH 132/235] added a note about the blue dot --- .../scribblings/drracket/interface-essentials.scrbl | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/collects/scribblings/drracket/interface-essentials.scrbl b/collects/scribblings/drracket/interface-essentials.scrbl index 75a9bc4921..ed628c7728 100644 --- a/collects/scribblings/drracket/interface-essentials.scrbl +++ b/collects/scribblings/drracket/interface-essentials.scrbl @@ -142,6 +142,16 @@ annotations: ] +Check Syntax also runs interactively and the bottom, rightmost corner of the DrRacket window +shows its status. A blue or green dot indicates that Check Syntax is running in the background +(the green dot indicates that the check syntax information has been computed and is +now being put into the DrRacket window proper). A red dot means that something has gone wrong; +move your mouse over the dot to find out what is wrong. Mis-matched parentheses indicates +that the buffer's parens are also mismatched; mouse over the parens for details. + +Also, right-clicking in that area yields a menu that lets you disable +(or re-eneable) online Check Syntax. + The @as-index{@onscreen{Run} button} evaluates the program in the @tech{definitions window} and resets the @tech{interactions window}. From 415868f914bb1c58b7c8645311d2ade8eae2a58b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 3 Sep 2011 17:18:31 -0500 Subject: [PATCH 133/235] added a #:dialog-mixin argument to get-file, put-file, get-file-list, and get-directory Also, Rackety --- collects/mred/private/filedialog.rkt | 175 ++++++++++---------- collects/scribblings/gui/dialog-funcs.scrbl | 26 ++- 2 files changed, 105 insertions(+), 96 deletions(-) diff --git a/collects/mred/private/filedialog.rkt b/collects/mred/private/filedialog.rkt index 8e74c0d481..cd5a92bbe6 100644 --- a/collects/mred/private/filedialog.rkt +++ b/collects/mred/private/filedialog.rkt @@ -1,97 +1,94 @@ -(module filedialog mzscheme - (require mzlib/class - mzlib/etc - mzlib/list - (prefix wx: "kernel.rkt") - (prefix wx: racket/snip) - (rename "wxme/cycle.rkt" wx:set-editor-get-file! set-editor-get-file!) - (rename "wxme/cycle.rkt" wx:set-editor-put-file! set-editor-put-file!) - "lock.rkt" - "wx.rkt" - "cycle.rkt" - "check.rkt" - "mrtop.rkt" - "path-dialog.rkt") +#lang racket/base +(require racket/class + (prefix-in wx: "kernel.rkt") + (rename-in "wxme/cycle.rkt" + [set-editor-get-file! wx:set-editor-get-file!] + [set-editor-put-file! wx:set-editor-put-file!]) + "lock.rkt" + "wx.rkt" + "cycle.rkt" + "check.rkt" + "mrtop.rkt" + "path-dialog.rkt") - (provide get-file - get-file-list - put-file - get-directory) +(provide get-file + get-file-list + put-file + get-directory) - (define (mk-file-selector who put? multi? dir?) - (lambda (message parent directory filename extension style filters) - ;; Calls from C++ have wrong kind of window: - (when (is-a? parent wx:window%) - (set! parent (as-entry (lambda () (wx->mred parent))))) +(define ((mk-file-selector who put? multi? dir?) + message parent directory filename extension style filters dialog-mixin) + ;; Calls from C++ have wrong kind of window: + (when (is-a? parent wx:window%) + (set! parent (as-entry (λ () (wx->mred parent))))) + + (check-label-string/false who message) + (check-top-level-parent/false who parent) + (check-path/false who directory) + (check-path/false who filename) + (check-string/false who extension) + (check-style who #f (cond + [dir? '(common enter-packages)] + [else '(common packages enter-packages)]) style) + (unless (and (list? filters) + (andmap (λ (p) + (and (list? p) + (= (length p) 2) + (string? (car p)) + (string? (cadr p)))) + filters)) + (raise-type-error who "list of 2-string lists" filters)) + (let* ([std? (memq 'common style)] + [style (if std? (remq 'common style) style)]) + (if std? + (send (new (dialog-mixin path-dialog%) + [put? put?] + [dir? dir?] + [multi? multi?] + [message message] + [parent parent] + [directory directory] + [filename filename] + [filters + (cond [(eq? filters default-filters) #t] ; its own defaults + [dir? #f] + [else filters])]) + run) + (wx:file-selector + message directory filename extension + ;; file types: + filters + ;; style: + (cons (cond [dir? 'dir] + [put? 'put] + [multi? 'multi] + [else 'get]) + style) + ;; parent: + (and parent (mred->wx parent)))))) - (check-label-string/false who message) - (check-top-level-parent/false who parent) - (check-path/false who directory) - (check-path/false who filename) - (check-string/false who extension) - (check-style who #f (cond - [dir? '(common enter-packages)] - [else '(common packages enter-packages)]) style) - (unless (and (list? filters) - (andmap (lambda (p) - (and (list? p) - (= (length p) 2) - (string? (car p)) - (string? (cadr p)))) - filters)) - (raise-type-error who "list of 2-string lists" filters)) - (let* ([std? (memq 'common style)] - [style (if std? (remq 'common style) style)]) - (if std? - (send (new path-dialog% - [put? put?] - [dir? dir?] - [multi? multi?] - [message message] - [parent parent] - [directory directory] - [filename filename] - [filters - (cond [(eq? filters default-filters) #t] ; its own defaults - [dir? #f] - [else filters])]) - run) - (wx:file-selector - message directory filename extension - ;; file types: - filters - ;; style: - (cons (cond [dir? 'dir] - [put? 'put] - [multi? 'multi] - [else 'get]) - style) - ;; parent: - (and parent (mred->wx parent))))))) +(define default-filters '(("Any" "*.*"))) - (define default-filters '(("Any" "*.*"))) +;; We duplicate the definition for `get-file', `get-file-list', and +;; `put-file' so that they have the right arities and names - ;; We duplicate the case-lambda for `get-file', `get-file-list', and - ;; `put-file' so that they have the right arities and names +(define-syntax define-file-selector + (syntax-rules () + [(_ name put? multi?) + (define (name [message #f] [parent #f] [directory #f] [filename #f] + [extension #f] [style null] [filters default-filters] + #:dialog-mixin [dialog-mixin values]) + ((mk-file-selector 'name put? multi? #f) + message parent directory filename extension style filters dialog-mixin))])) - (define-syntax define-file-selector - (syntax-rules () - [(_ name put? multi?) - (define name - (opt-lambda ([message #f] [parent #f] [directory #f] [filename #f] - [extension #f] [style null] [filters default-filters]) - ((mk-file-selector 'name put? multi? #f) - message parent directory filename extension style filters)))])) +(define-file-selector get-file #f #f) +(define-file-selector get-file-list #f #t) +(define-file-selector put-file #t #f) - (define-file-selector get-file #f #f) - (define-file-selector get-file-list #f #t) - (define-file-selector put-file #t #f) +(define (get-directory [message #f] [parent #f] [directory #f] [style null] #:dialog-mixin [dialog-mixin values]) + ((mk-file-selector 'get-directory #f #f #t) + message parent directory #f #f style null dialog-mixin)) - (define get-directory - (opt-lambda ([message #f] [parent #f] [directory #f] [style null]) - ((mk-file-selector 'get-directory #f #f #t) - message parent directory #f #f style null))) - - (set-get-file! get-file) - (wx:set-editor-get-file! get-file) - (wx:set-editor-put-file! put-file)) +(set-get-file! get-file) +(wx:set-editor-get-file! get-file) +(wx:set-editor-put-file! put-file) diff --git a/collects/scribblings/gui/dialog-funcs.scrbl b/collects/scribblings/gui/dialog-funcs.scrbl index 73f6ebe6b0..cc744dfc48 100644 --- a/collects/scribblings/gui/dialog-funcs.scrbl +++ b/collects/scribblings/gui/dialog-funcs.scrbl @@ -15,7 +15,8 @@ These functions get input from the user and/or display [filename (or/c path-string? #f) #f] [extension (or/c string? #f) #f] [style (listof (or/c 'packages 'enter-packages 'common)) null] - [filters (listof (list/c string? string?)) '(("Any" "*.*"))]) + [filters (listof (list/c string? string?)) '(("Any" "*.*"))] + [#:dialog-mixin dialog-mixin (make-mixin-contract path-dialog%) (λ (x) x)]) (or/c path? #f)]{ Obtains a file pathname from the user via the platform-specific @@ -65,8 +66,10 @@ On Windows and Unix, @racket[filters] determines a set of filters from that have any of these suffixes in any filter are selectable; a @racket["*.*"] glob makes all files available for selection. -See also @racket[path-dialog%]. +The @racket[dialog-mixin] is applied to @racket[path-dialog%] before +creating an instance of the class for this dialog. +See also @racket[path-dialog%] for a richer interface. } @@ -76,7 +79,8 @@ See also @racket[path-dialog%]. [filename (or/c path-string? #f) #f] [extension (or/c string? #f) #f] [style (listof (or/c 'packages 'enter-packages 'common)) null] - [filters (listof (list/c string? string?)) '(("Any" "*.*"))]) + [filters (listof (list/c string? string?)) '(("Any" "*.*"))] + [#:dialog-mixin dialog-mixin (make-mixin-contract path-dialog%) (λ (x) x)]) (or/c (listof path?) #f)]{ Like @racket[get-file], except that the user can select multiple files, and the @@ -90,7 +94,8 @@ Like [filename (or/c path-string? #f) #f] [extension (or/c string? #f) #f] [style (listof (or/c 'packages 'enter-packages 'common)) null] - [filters (listof (list/c string? string?)) '(("Any" "*.*"))]) + [filters (listof (list/c string? string?)) '(("Any" "*.*"))] + [#:dialog-mixin dialog-mixin (make-mixin-contract path-dialog%) (λ (x) x)]) (or/c path? #f)]{ Obtains a file pathname from the user via the platform-specific @@ -149,14 +154,17 @@ On Unix, @racket[extension] is ignored, and @racket[filters] is used The @racket[style] list is treated as for @racket[get-file]. -See also @racket[path-dialog%]. +The @racket[dialog-mixin] is applied to @racket[path-dialog%] before +creating an instance of the class for this dialog. +See also @racket[path-dialog%] for a richer interface. } @defproc[(get-directory [message (or/c string? #f) #f] [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f) #f] [directory (or/c path? #f) #f] - [style (listof (or/c 'enter-packages 'common)) null]) + [style (listof (or/c 'enter-packages 'common)) null] + [#:dialog-mixin dialog-mixin (make-mixin-contract path-dialog%) (λ (x) x)]) (or/c path #f)]{ Obtains a directory pathname from the user via the platform-specific @@ -178,7 +186,11 @@ specified. The latter package. A package is a directory with a special suffix (e.g., ``.app'') that the Finder normally displays like a file. -See also @racket[path-dialog%]. +The @racket[dialog-mixin] is applied to @racket[path-dialog%] before +creating an instance of the class for this dialog. + +See also @racket[path-dialog%] for a richer interface. + } @defproc[(message-box [title label-string?] From 92537076211b5b2c111ad8f8482c8354a8335029 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 3 Sep 2011 21:41:22 -0500 Subject: [PATCH 134/235] added a #:dialog-mixin argument to message-box and related functions Also minor rackety (just enough to get keyword arguments) --- collects/mred/private/messagebox.rkt | 137 ++++++++++---------- collects/scribblings/gui/dialog-funcs.scrbl | 32 +++-- 2 files changed, 92 insertions(+), 77 deletions(-) diff --git a/collects/mred/private/messagebox.rkt b/collects/mred/private/messagebox.rkt index a9eb6d09a5..56b9c430c1 100644 --- a/collects/mred/private/messagebox.rkt +++ b/collects/mred/private/messagebox.rkt @@ -1,9 +1,8 @@ -(module messagebox mzscheme +#lang racket/base (require mzlib/class mzlib/class100 - mzlib/etc mzlib/string - (prefix wx: "kernel.rkt") + (prefix-in wx: "kernel.rkt") "const.rkt" "check.rkt" "helper.rkt" @@ -24,7 +23,8 @@ (lambda (who title message button1 button2 button3 parent style close-result - check? two-results? check-message) + check? two-results? check-message + dialog-mixin) (check-label-string who title) (check-string/false who message) (when check? @@ -46,7 +46,8 @@ who title message button1 button2 button3 parent style close-result - check? two-results? check-message))] + check? two-results? check-message + dialog-mixin))] [es (if parent (send parent get-eventspace) (wx:current-eventspace))]) @@ -65,51 +66,53 @@ (lambda (who title message button1 button2 button3 parent style close-result - check? two-results? check-message) + check? two-results? check-message + dialog-mixin) (let* ([strings (regexp-split #rx"\n" message)] [single? (and (< (length strings) 10) (andmap (lambda (s) (< (string-length s) 60)) strings))] - [f (make-object (class100 dialog% () - (public - [get-message - (lambda () message)]) - (augment - [can-close? (lambda () - (if (memq 'disallow-close style) - (begin - (wx:bell) - #f) - #t))]) - (override - [on-subwindow-event - (lambda (w e) - (if (send e button-down?) - (if (is-a? w button%) - #f - (if (or (is-a? w message%) - (and - (is-a? w editor-canvas%) - (let-values ([(w h) (send w get-client-size)]) - (< (send e get-x) w)))) - (begin - (send w popup-menu - (let ([m (make-object popup-menu%)]) - (make-object menu-item% - "Copy Message" - m - (lambda (i e) - (send (wx:get-the-clipboard) - set-clipboard-string - message - (send e get-time-stamp)))) - m) - (send e get-x) - (send e get-y)) - #t) - #f)) - #f))]) - (sequence - (super-init title parent box-width))))] + [f (make-object (dialog-mixin + (class100 dialog% () + (public + [get-message + (lambda () message)]) + (augment + [can-close? (lambda () + (if (memq 'disallow-close style) + (begin + (wx:bell) + #f) + #t))]) + (override + [on-subwindow-event + (lambda (w e) + (if (send e button-down?) + (if (is-a? w button%) + #f + (if (or (is-a? w message%) + (and + (is-a? w editor-canvas%) + (let-values ([(w h) (send w get-client-size)]) + (< (send e get-x) w)))) + (begin + (send w popup-menu + (let ([m (make-object popup-menu%)]) + (make-object menu-item% + "Copy Message" + m + (lambda (i e) + (send (wx:get-the-clipboard) + set-clipboard-string + message + (send e get-time-stamp)))) + m) + (send e get-x) + (send e get-y)) + #t) + #f)) + #f))]) + (sequence + (super-init title parent box-width)))))] [result close-result] [icon-id (cond [(memq 'stop style) 'stop] @@ -224,20 +227,21 @@ result)))))) (define message-box/custom - (opt-lambda (title message - button1 - button2 - button3 - [parent #f] - [style '(no-default)] - [close-result #f]) + (lambda (title message + button1 + button2 + button3 + [parent #f] + [style '(no-default)] + [close-result #f] + #:dialog-mixin [dialog-mixin values]) (do-message-box/custom 'message-box/custom title message button1 button2 button3 parent style close-result - #f #f #f))) + #f #f #f dialog-mixin))) (define do-message-box - (lambda (who title message parent style check? check-message) + (lambda (who title message parent style check? check-message dialog-mixin) (check-label-string who title) (check-string/false who message) (when check? @@ -276,7 +280,8 @@ (list default) (list default 'disallow-close))) close-val - check? #t check-message)]) + check? #t check-message + dialog-mixin)]) (let ([result (case result [(1) one-v] [(2) two-v])]) @@ -285,23 +290,25 @@ result)))))) (define message-box - (opt-lambda (title message [parent #f] [style '(ok)]) - (do-message-box 'message-box title message parent style #f #f))) + (lambda (title message [parent #f] [style '(ok)] #:dialog-mixin [dialog-mixin values]) + (do-message-box 'message-box title message parent style #f #f dialog-mixin))) (define message+check-box/custom - (opt-lambda (title message + (lambda (title message checkbox-message button1 button2 button3 [parent #f] [style '(no-default)] - [close-result #f]) + [close-result #f] + #:dialog-mixin [dialog-mixin values]) (do-message-box/custom 'message+check-box/custom title message button1 button2 button3 - parent style close-result - #t #t checkbox-message))) + parent style close-result + #t #t checkbox-message + dialog-mixin))) (define message+check-box - (opt-lambda (title message check-message [parent #f] [style '(ok)]) - (do-message-box 'message-box title message parent style #t check-message)))) + (lambda (title message check-message [parent #f] [style '(ok)] #:dialog-mixin [dialog-mixin values]) + (do-message-box 'message-box title message parent style #t check-message dialog-mixin))) diff --git a/collects/scribblings/gui/dialog-funcs.scrbl b/collects/scribblings/gui/dialog-funcs.scrbl index cc744dfc48..4299af6f19 100644 --- a/collects/scribblings/gui/dialog-funcs.scrbl +++ b/collects/scribblings/gui/dialog-funcs.scrbl @@ -196,7 +196,8 @@ See also @racket[path-dialog%] for a richer interface. @defproc[(message-box [title label-string?] [message string?] [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f) #f] - [style (listof (or/c 'ok 'ok-cancel 'yes-no 'caution 'stop)) '(ok)]) + [style (listof (or/c 'ok 'ok-cancel 'yes-no 'caution 'stop)) '(ok)] + [#:dialog-mixin dialog-mixin (make-mixin-contract dialog%) values]) (or/c 'ok 'cancel 'yes 'no)]{ See also @racket[message-box/custom]. @@ -239,10 +240,14 @@ The class that implements the dialog provides a @racket[get-message] a string. (The dialog is accessible through the @racket[get-top-level-windows] function.) -The @racket[message-box] function can be called int a thread other +The @racket[message-box] function can be called in a thread other than the handler thread of the relevant eventspace (i.e., the eventspace of @racket[parent], or the current eventspace if @racket[parent] is @racket[#f]), in which case the - current thread blocks while the dialog runs on the handler thread.} + current thread blocks while the dialog runs on the handler thread. + +The @racket[dialog-mixin] argument is applied to the class that implements the dialog +before the dialog is created. +} @defproc[(message-box/custom [title label-string?] [message string] @@ -254,7 +259,8 @@ The @racket[message-box] function can be called int a thread other 'disallow-close 'no-default 'default=1 'default=2 'default=3)) '(no-default)] - [close-result any/c #f]) + [close-result any/c #f] + [#:dialog-mixin dialog-mixin (make-mixin-contract dialog%) values]) (or/c 1 2 3 close-result)]{ Displays a message to the user in a (modal) dialog, using @@ -324,10 +330,14 @@ The class that implements the dialog provides a @racket[get-message] a string. (The dialog is accessible through the @racket[get-top-level-windows] function.) -The @racket[message-box/custom] function can be called int a thread +The @racket[message-box/custom] function can be called in a thread other than the handler thread of the relevant eventspace (i.e., the eventspace of @racket[parent], or the current eventspace if @racket[parent] is @racket[#f]), in which case the - current thread blocks while the dialog runs on the handler thread.} + current thread blocks while the dialog runs on the handler thread. + +The @racket[dialog-mixin] argument is applied to the class that implements the dialog +before the dialog is created. +} @defproc[(message+check-box [title label-string?] [message string?] @@ -335,7 +345,8 @@ The @racket[message-box/custom] function can be called int a thread [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f) #f] [style (listof (or/c 'ok 'ok-cancel 'yes-no 'caution 'stop 'checked)) - '(ok)]) + '(ok)] + [#:dialog-mixin dialog-mixin (make-mixin-contract dialog%) values]) (values (or/c 'ok 'cancel 'yes 'no) boolean?)]{ See also @racket[message+check-box/custom]. @@ -361,7 +372,8 @@ Like @racket[message-box], except that 'disallow-close 'no-default 'default=1 'default=2 'default=3)) '(no-default)] - [close-result any/c #f]) + [close-result any/c #f] + [#:dialog-mixin dialog-mixin (make-mixin-contract dialog%) values]) (or/c 1 2 3 (λ (x) (eq? x close-result)))]{ Like @racket[message-box/custom], except that @@ -372,10 +384,6 @@ Like @racket[message-box/custom], except that @item{@racket[style] can contain @racket['checked] to indicate that the check box should be initially checked.} ] - - - - } @defproc[(get-text-from-user [title string?] From e4ddd0718ac0f0bf02c8d079a6c940d2fdb7f979 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 4 Sep 2011 17:21:15 -0500 Subject: [PATCH 135/235] break lines better --- collects/scribblings/framework/frame.scrbl | 48 +++++++++++++++++----- 1 file changed, 38 insertions(+), 10 deletions(-) diff --git a/collects/scribblings/framework/frame.scrbl b/collects/scribblings/framework/frame.scrbl index 85c9b1b14b..571909cbbf 100644 --- a/collects/scribblings/framework/frame.scrbl +++ b/collects/scribblings/framework/frame.scrbl @@ -28,7 +28,9 @@ Return @racket[menu-bar%]. } - @defmethod*[(((make-root-area-container (class (implementation?/c area-container<%>)) (parent (is-a?/c area-container<%>))) (is-a?/c area-container<%>)))]{ + @defmethod*[(((make-root-area-container (class (implementation?/c area-container<%>)) + (parent (is-a?/c area-container<%>))) + (is-a?/c area-container<%>)))]{ Override this method to insert a panel in between the panel used by the clients of this frame and the frame itself. For example, to insert a status line panel override this method with something like this: @@ -264,7 +266,9 @@ } @defmixin[frame:status-line-mixin (frame:basic<%>) (frame:status-line<%>)]{ - @defmethod*[#:mode override (((make-root-area-container (class (subclass?/c panel%)) (parent (is-a?/c panel%))) (is-a?/c panel%)))]{ + @defmethod*[#:mode override (((make-root-area-container (class (subclass?/c panel%)) + (parent (is-a?/c panel%))) + (is-a?/c panel%)))]{ Adds a panel at the bottom of the frame to hold the status lines. @@ -344,7 +348,9 @@ The result of this mixin uses the same initialization arguments as the mixin's argument. - @defmethod*[#:mode override (((make-root-area-container (class (subclass?/c area-container<%>)) (parent (is-a?/c area-container<%>))) (is-a?/c area-container<%>)))]{ + @defmethod*[#:mode override (((make-root-area-container (class (subclass?/c area-container<%>)) + (parent (is-a?/c area-container<%>))) + (is-a?/c area-container<%>)))]{ Builds an extra panel for displaying various information. } @@ -526,7 +532,16 @@ (height (or/c (integer-in 0 10000) false/c) #f) (x (or/c (integer-in -10000 10000) false/c) #f) (y (or/c (integer-in -10000 10000) false/c) #f) - (style (listof (or/c 'no-resize-border 'no-caption 'no-system-menu 'hide-menu-bar 'mdi-parent 'mdi-child 'toolbar-button 'float 'metal)) null) + (style (listof (or/c 'no-resize-border + 'no-caption + 'no-system-menu + 'hide-menu-bar + 'mdi-parent + 'mdi-child + 'toolbar-button + 'float + 'metal)) + null) (enabled any/c #t) (border (integer-in 0 1000) 0) (spacing (integer-in 0 1000) 0) @@ -590,7 +605,9 @@ returns @racket[#t]. } - @defmethod*[#:mode override (((file-menu:save-as-callback (item (is-a?/c menu-item%)) (evt (is-a?/c control-event%))) void?))]{ + @defmethod*[#:mode override (((file-menu:save-as-callback (item (is-a?/c menu-item%)) + (evt (is-a?/c control-event%))) + void?))]{ Prompts the user for a file name and uses that filename to save the buffer. Calls @method[frame:editor<%> save-as] with no arguments. } @@ -599,7 +616,9 @@ returns @racket[#t]. } - @defmethod*[#:mode override (((file-menu:print-callback (item (is-a?/c menu-item%)) (evt (is-a?/c control-event%))) void?))]{ + @defmethod*[#:mode override (((file-menu:print-callback (item (is-a?/c menu-item%)) + (evt (is-a?/c control-event%))) + void?))]{ Calls the @method[editor<%> print] method of @racket[editor<%>] with the default arguments, except that the @racket[output-mode] argument is the result of calling @racket[preferences:get] with @@ -619,7 +638,9 @@ text. } - @defmethod*[#:mode override (((help-menu:about-callback (item (is-a?/c menu-item%)) (evt (is-a?/c control-event%))) void?))]{ + @defmethod*[#:mode override (((help-menu:about-callback (item (is-a?/c menu-item%)) + (evt (is-a?/c control-event%))) + void?))]{ Calls @racket[message-box] with a message welcoming the user to the application named by @racket[application:current-app-name] } @@ -663,7 +684,9 @@ @racket['framework:open-here?] is set. } - @defmethod*[#:mode override (((file-menu:new-callback (item (is-a?/c menu-item%)) (evt (is-a?/c control-event%))) void?))]{ + @defmethod*[#:mode override (((file-menu:new-callback (item (is-a?/c menu-item%)) + (evt (is-a?/c control-event%))) + void?))]{ When the preference @racket['framework:open-here?] preference is set, this method prompts the user, asking if they would like to create a new frame, or just clear out this one. If they clear it out and the file hasn't been @@ -766,7 +789,9 @@ Adds support for a 20,000-feet view via @racket[text:delegate<%>] and @racket[text:delegate-mixin]. - @defmethod*[#:mode override (((make-root-area-container (class (subclass?/c panel%)) (parent (is-a?/c panel%))) (is-a?/c panel%)))]{ + @defmethod*[#:mode override (((make-root-area-container (class (subclass?/c panel%)) + (parent (is-a?/c panel%))) + (is-a?/c panel%)))]{ Adds a panel outside to hold the delegate @racket[editor-canvas%] and @racket[text%]. } @@ -867,7 +892,10 @@ returns @racket[#t]. } - @defmethod*[#:mode override (((edit-menu:find-again-backwards-callback (item (is-a?/c menu-item%)) (evt (is-a?/c control-event%))) void?))]{ + @defmethod*[#:mode override (((edit-menu:find-again-backwards-callback + (item (is-a?/c menu-item%)) + (evt (is-a?/c control-event%))) + void?))]{ Calls @method[frame:searchable unhide-search] and then @method[frame:searchable<%> search]. } From bb71539233dcb28f641b5537d61797bee4eabcaa Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 4 Sep 2011 23:53:13 -0500 Subject: [PATCH 136/235] remove extraneous path->string conversion --- collects/compiler/commands/make.rkt | 2 +- collects/compiler/main.rkt | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/compiler/commands/make.rkt b/collects/compiler/commands/make.rkt index fc237ce2b8..127b521795 100644 --- a/collects/compiler/commands/make.rkt +++ b/collects/compiler/commands/make.rkt @@ -66,7 +66,7 @@ (lambda (p) (set! did-one? #t) (when (verbose) - (printf " making ~s\n" (path->string p))))]) + (printf " making ~s\n" p)))]) (for ([file source-files]) (unless (file-exists? file) (error mzc-symbol "file does not exist: ~a" file)) diff --git a/collects/compiler/main.rkt b/collects/compiler/main.rkt index f8df28abf7..e224a99385 100644 --- a/collects/compiler/main.rkt +++ b/collects/compiler/main.rkt @@ -510,7 +510,7 @@ (parameterize ([compile-notify-handler (lambda (path) (when (compiler:option:somewhat-verbose) - (printf " making ~s\n" (path->string path))))]) + (printf " making ~s\n" path)))]) (apply compile-collection-zos source-files))] [(cc) (for ([file source-files]) From a67f509f90359203463c943e4de90eb5e8a91656 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 4 Sep 2011 23:59:42 -0500 Subject: [PATCH 137/235] add frame:focus-table-mixin & related things to be able to make drracket test suites that don't depend on the OS giving any focus messages --- collects/drracket/private/debug.rkt | 12 ++- collects/drracket/private/frame.rkt | 9 +- collects/drracket/private/init.rkt | 5 +- .../private/language-configuration.rkt | 13 ++- collects/drracket/private/language.rkt | 15 ++- collects/drracket/private/rep.rkt | 8 +- collects/drracket/private/syncheck/gui.rkt | 3 +- collects/drracket/private/unit.rkt | 29 ++++-- collects/framework/main.rkt | 26 ++++- collects/framework/private/finder.rkt | 12 ++- collects/framework/private/frame.rkt | 34 +++++-- collects/framework/private/sig.rkt | 2 + collects/framework/test.rkt | 98 ++++++++++++------- collects/scribblings/framework/frame.scrbl | 29 ++++++ .../scribblings/framework/main-extracts.rkt | 2 +- .../drracket/no-write-and-frame-leak.rkt | 10 +- .../drracket/private/drracket-test-util.rkt | 31 +++--- collects/tests/drracket/repl-test.rkt | 9 +- collects/tests/drracket/stepper-test.rkt | 2 +- .../drracket/teaching-lang-save-file.rkt | 4 +- 20 files changed, 243 insertions(+), 110 deletions(-) diff --git a/collects/drracket/private/debug.rkt b/collects/drracket/private/debug.rkt index 40cc97f4a9..4e8728c243 100644 --- a/collects/drracket/private/debug.rkt +++ b/collects/drracket/private/debug.rkt @@ -900,7 +900,8 @@ profile todo: (message-box (string-constant drscheme) (string-constant editor-changed-since-srcloc-recorded) frame - '(ok caution)))) + '(ok caution) + #:dialog-mixin frame:focus-table-mixin))) (when (and rep editor) (when (is-a? editor text:basic<%>) (send rep highlight-errors same-src-srclocs '()) @@ -1007,7 +1008,8 @@ profile todo: (string-constant test-coverage-clear-and-do-not-ask-again) (send (get-canvas) get-top-level-window) '(default=1) - 2)]) + 2 + #:dialog-mixin frame:focus-table-mixin)]) (case msg-box-result [(1) #t] [(2) #f] @@ -1419,7 +1421,8 @@ profile todo: (eq? (message-box (string-constant drscheme) (string-constant profiling-clear?) frame - '(yes-no)) + '(yes-no) + #:dialog-mixin frame:focus-table-mixin) 'yes)))))) (define/private (do-reset-profile) @@ -1561,7 +1564,8 @@ profile todo: (send (get-current-tab) refresh-profile)] [else (message-box (string-constant drscheme) - (string-constant profiling-no-information-available))])) + (string-constant profiling-no-information-available) + #:dialog-mixin frame:focus-table-mixin)])) (define/public (hide-profile-gui) (when profile-gui-constructed? diff --git a/collects/drracket/private/frame.rkt b/collects/drracket/private/frame.rkt index a13e60daa7..590e225b4d 100644 --- a/collects/drracket/private/frame.rkt +++ b/collects/drracket/private/frame.rkt @@ -295,7 +295,8 @@ [else (message-box (string-constant drscheme) (format (string-constant keybindings-planet-malformed-spec) - planet-spec))])))))) + planet-spec) + #:dialog-mixin frame:focus-table-mixin)])))))) (let ([ud (preferences:get 'drracket:user-defined-keybindings)]) (unless (null? ud) (new separator-menu-item% (parent keybindings-menu)) @@ -343,7 +344,8 @@ (if (path? item) (path->string item) (format "~s" item)) - (exn-message x))) + (exn-message x)) + #:dialog-mixin frame:focus-table-mixin) #f)]) (keymap:add-user-keybindings-file item) #t)) @@ -459,7 +461,8 @@ (message-box (string-constant drscheme) (if (exn? exn) (format "~a" (exn-message exn)) - (format "~s" exn))))]) + (format "~s" exn)) + #:dialog-mixin frame:focus-table-mixin))]) (let* ([url (string->url s-url)] [tmp-filename (make-temporary-file "tmp~a.plt")] [port (get-impure-port url)] diff --git a/collects/drracket/private/init.rkt b/collects/drracket/private/init.rkt index eb331b133f..8bee64b9ab 100644 --- a/collects/drracket/private/init.rkt +++ b/collects/drracket/private/init.rkt @@ -1,7 +1,8 @@ #lang racket/unit (require string-constants "drsig.rkt" - racket/gui/base) + racket/gui/base + framework) (import) @@ -50,4 +51,4 @@ (parameterize ([current-custodian system-custodian]) (parameterize ([current-eventspace error-display-eventspace]) - (message-box title text #f '(stop ok)))))))) + (message-box title text #f '(stop ok) #:dialog-mixin frame:focus-table-mixin))))))) diff --git a/collects/drracket/private/language-configuration.rkt b/collects/drracket/private/language-configuration.rkt index 1370d7259f..67a6a00177 100644 --- a/collects/drracket/private/language-configuration.rkt +++ b/collects/drracket/private/language-configuration.rkt @@ -162,7 +162,7 @@ (define language-dialog (λ (show-welcome? language-settings-to-show [parent #f]) (define ret-dialog% - (class dialog% + (class (frame:focus-table-mixin dialog%) (define/override (on-subwindow-char receiver evt) (case (send evt get-key-code) [(escape) (cancel-callback)] @@ -170,7 +170,7 @@ [else (or (key-pressed receiver evt) (super on-subwindow-char receiver evt))])) - (super-instantiate ()))) + (super-new))) (define dialog (instantiate ret-dialog% () (label (if show-welcome? @@ -214,7 +214,8 @@ (define (ok-callback) (unless (enter-callback) (message-box (string-constant drscheme) - (string-constant please-select-a-language)))) + (string-constant please-select-a-language) + #:dialog-mixin frame:focus-table-mixin))) ;; cancel-callback : -> void (define (cancel-callback) @@ -1285,7 +1286,8 @@ (message-box (string-constant drscheme) (if (exn? x) (exn-message x) - (format "uncaught exception: ~s" x))) + (format "uncaught exception: ~s" x)) + #:dialog-mixin frame:focus-table-mixin) read-syntax/namespace-introduce)]) (contract (->* () @@ -1335,7 +1337,8 @@ numberss summaries urls - reader-specs))]))))) + reader-specs) + #:dialog-mixin frame:focus-table-mixin)]))))) (define (platform-independent-string->path str) (apply diff --git a/collects/drracket/private/language.rkt b/collects/drracket/private/language.rkt index ccf7aedb4b..b662354dcd 100644 --- a/collects/drracket/private/language.rkt +++ b/collects/drracket/private/language.rkt @@ -783,7 +783,8 @@ [(string=? "" filename-str) (message-box (string-constant drscheme) (string-constant please-specify-a-filename) - dlg) + dlg + #:dialog-mixin frame:focus-table-mixin) #f] [(not (users-name-ok? mode extension dlg (string->path filename-str))) #f] @@ -797,7 +798,8 @@ (eq? (message-box (string-constant drscheme) (format (string-constant are-you-sure-delete?) filename) dlg - '(yes-no)) + '(yes-no) + #:dialog-mixin frame:focus-table-mixin) 'yes)) (define cancelled? #t) @@ -904,7 +906,8 @@ [(distribution) (string-constant distribution)]) name extension) - parent) + parent + #:dialog-mixin frame:focus-table-mixin) #f))))) ;; default-executable-filename : path symbol boolean -> path @@ -940,7 +943,8 @@ (λ (x) (message-box (string-constant drscheme) - (format "~a" (exn-message x))) + (format "~a" (exn-message x)) + #:dialog-mixin frame:focus-table-mixin) (void))]) (define init-code-tmp-filename (make-temporary-file "drs-standalone-exectable-init~a")) (define bootstrap-tmp-filename (make-temporary-file "drs-standalone-exectable-bootstrap~a")) @@ -1163,7 +1167,8 @@ (λ (x) (message-box (string-constant drscheme) - (format "~a" (exn-message x))) + (format "~a" (exn-message x)) + #:dialog-mixin frame:focus-table-mixin) (void))]) ((if gui? make-mred-launcher make-mzscheme-launcher) diff --git a/collects/drracket/private/rep.rkt b/collects/drracket/private/rep.rkt index bd41e6afd1..975a0e6b2c 100644 --- a/collects/drracket/private/rep.rkt +++ b/collects/drracket/private/rep.rkt @@ -903,7 +903,7 @@ TODO (floor (/ new-limit 1024 1024)))) frame '(default=1 stop) - )]) + #:dialog-mixin frame:focus-table-mixin)]) (when (equal? ans 3) (set-custodian-limit new-limit) (preferences:set 'drracket:child-only-memory-limit new-limit)) @@ -1369,7 +1369,8 @@ TODO #f (or (get-top-level-window) (get-can-close-parent)) '(default=1 caution) - 2) + 2 + #:dialog-mixin frame:focus-table-mixin) 1)] [(let ([user-eventspace (get-user-eventspace)]) (and user-eventspace @@ -1383,7 +1384,8 @@ TODO #f (or (get-top-level-window) (get-can-close-parent)) '(default=1 caution) - 2) + 2 + #:dialog-mixin frame:focus-table-mixin) 1)] [else #t]) (inner #t can-close?))) diff --git a/collects/drracket/private/syncheck/gui.rkt b/collects/drracket/private/syncheck/gui.rkt index e617784dc5..94fcacf337 100644 --- a/collects/drracket/private/syncheck/gui.rkt +++ b/collects/drracket/private/syncheck/gui.rkt @@ -612,7 +612,8 @@ If the namespace does not, they are colored the unbound color. (string-constant cancel) #f parent - '(stop default=2)) + '(stop default=2) + #:dialog-mixin frame:focus-table-mixin) 1))) (when do-renaming? diff --git a/collects/drracket/private/unit.rkt b/collects/drracket/private/unit.rkt index 4e0c5e5fa0..8c83dbc0f5 100644 --- a/collects/drracket/private/unit.rkt +++ b/collects/drracket/private/unit.rkt @@ -150,7 +150,8 @@ module browser threading seems wrong. [else (message-box (string-constant drscheme) - "Must choose a filename that ends with either .png, .jpg, .xbm, or .xpm")])))))])))))) + "Must choose a filename that ends with either .png, .jpg, .xbm, or .xpm" + #:dialog-mixin frame:focus-table-mixin)])))))])))))) (void)))))) @@ -338,7 +339,8 @@ module browser threading seems wrong. (message-box (string-constant drscheme) v - dlg)])))] + dlg + #:dialog-mixin frame:focus-table-mixin)])))] [cancel-callback (λ () (send dlg show #f))]) (let-values ([(ok cancel) @@ -364,7 +366,8 @@ module browser threading seems wrong. [(not program-filename) (message-box (string-constant create-executable-title) (string-constant must-save-before-executable) - frame)] + frame + #:dialog-mixin frame:focus-table-mixin)] [else (when (or (not (send definitions-text is-modified?)) (gui-utils:get-choice @@ -1667,7 +1670,8 @@ module browser threading seems wrong. (gui-utils:format-literal-label (string-constant erase-log-directory-contents) transcript-directory) this - '(yes-no))]) + '(yes-no) + #:dialog-mixin frame:focus-table-mixin)]) (cond [(eq? query 'no) #f] @@ -1680,7 +1684,8 @@ module browser threading seems wrong. (if (exn? exn) (format "~a" (exn-message exn)) (format "~s" exn))) - this) + this + #:dialog-mixin frame:focus-table-mixin) #f)]) (for-each (λ (file) (delete-file (build-path transcript-directory file))) dir-list) @@ -2669,7 +2674,8 @@ module browser threading seems wrong. #f this '(caution default=2 number-order) - 1)]) + 1 + #:dialog-mixin frame:focus-table-mixin)]) (case user-choice [(1) (void)] [(2) (revert)])))) @@ -3177,7 +3183,8 @@ module browser threading seems wrong. strs))]) (unless can-browse? (message-box (string-constant drscheme) - (string-constant module-browser-only-in-plt-and-module-langs))) + (string-constant module-browser-only-in-plt-and-module-langs) + #:dialog-mixin frame:focus-table-mixin)) can-browse?)) (define/private (update-module-browser-pane) @@ -3577,7 +3584,8 @@ module browser threading seems wrong. (send l capability-value 'drscheme:teachpack-menu-items) (format "\n ~a" (send l get-language-name)))) (drracket:language-configuration:get-languages)))))) - this))])))]))) + this + #:dialog-mixin frame:focus-table-mixin))])))]))) (define/private (initialize-menus) (let* ([mb (get-menu-bar)] @@ -4650,8 +4658,9 @@ module browser threading seems wrong. (frame:editor-mixin (frame:standard-menus-mixin (frame:register-group-mixin - (frame:basic-mixin - frame%)))))))))))))))))) + (frame:focus-table-mixin + (frame:basic-mixin + frame%))))))))))))))))))) (define-local-member-name enable-two-way-prefs) (define (make-two-way-prefs-dragable-panel% % pref-key) diff --git a/collects/framework/main.rkt b/collects/framework/main.rkt index 88de9a1db1..4352051fad 100644 --- a/collects/framework/main.rkt +++ b/collects/framework/main.rkt @@ -9,7 +9,12 @@ framework/framework-unit framework/private/sig (for-syntax scheme/base) - scribble/srcdoc) + scribble/srcdoc) + +;; these next two lines do a little dance to make the +;; require/doc setup work out properly +(require (prefix-in :: framework/private/focus-table)) +(define frame:lookup-focus-table ::frame:lookup-focus-table) (require framework/preferences framework/test @@ -709,7 +714,24 @@ @racket[bitmap% get-loaded-mask]) and @racket['large].}] Defaults to @racket[#f].}) - + + (proc-doc/names + frame:lookup-focus-table + (->* () (eventspace?) (listof (is-a?/c frame:focus-table<%>))) + (() + ((eventspace (current-eventspace)))) + @{Returns a list of the frames in @racket[eventspace], where the first element of the list + is the frame with the focus. + + The order and contents of the list are maintained by + the methods in @racket[frame:focus-table-mixin], meaning that the + OS-level callbacks that track the focus of individual frames is + ignored. + + See also @racket[test:use-focus-table] and @racket[test:get-active-top-level-window]. + + }) + (proc-doc/names group:get-the-frame-group (-> (is-a?/c group:%)) diff --git a/collects/framework/private/finder.rkt b/collects/framework/private/finder.rkt index 8b5675e986..ac020ee37f 100644 --- a/collects/framework/private/finder.rkt +++ b/collects/framework/private/finder.rkt @@ -1,14 +1,15 @@ #lang scheme/unit (require string-constants + (prefix-in r: racket/gui/base) "sig.rkt" "../preferences.rkt" mred/mred-sig scheme/path) - (import mred^ - [prefix keymap: framework:keymap^]) + [prefix keymap: framework:keymap^] + [prefix frame: framework:frame^]) (export (rename framework:finder^ [-put-file put-file] @@ -44,7 +45,8 @@ [name (or (and (string? name) (file-name-from-path name)) name)] [f (put-file prompt parent-win directory name - (default-extension) style (default-filters))]) + (default-extension) style (default-filters) + #:dialog-mixin frame:focus-table-mixin)]) (and f (or (not filter) (filter-match? filter f filter-msg)) (let* ([f (normal-case-path (simple-form-path f))] [dir (path-only f)] @@ -60,6 +62,7 @@ #f] [else f])))))) + (define op (current-output-port)) (define (*get-file style) (lambda ([directory #f] [prompt (string-constant select-file)] @@ -67,7 +70,8 @@ [filter-msg (string-constant file-wrong-form)] [parent-win (dialog-parent-parameter)]) (let ([f (get-file prompt parent-win directory #f - (default-extension) style (default-filters))]) + (default-extension) style (default-filters) + #:dialog-mixin frame:focus-table-mixin)]) (and f (or (not filter) (filter-match? filter f filter-msg)) (cond [(directory-exists? f) (message-box (string-constant error) diff --git a/collects/framework/private/frame.rkt b/collects/framework/private/frame.rkt index b051dea8a8..856b7fde77 100644 --- a/collects/framework/private/frame.rkt +++ b/collects/framework/private/frame.rkt @@ -9,6 +9,7 @@ "../preferences.rkt" "../gui-utils.rkt" "bday.rkt" + framework/private/focus-table mrlib/close-icon mred/mred-sig scheme/path) @@ -131,6 +132,26 @@ editing-this-file? get-filename make-visible)) + +(define focus-table<%> (interface ((class->interface frame%)))) +(define focus-table-mixin + (mixin (top-level-window<%>) (focus-table<%>) + (inherit get-eventspace) + + (define/override (show on?) + (define old (remove this (frame:lookup-focus-table (get-eventspace)))) + (define new (if on? (cons this old) old)) + (frame:set-focus-table (get-eventspace) new) + (super show on?)) + + (define/augment (on-close) + (frame:set-focus-table (get-eventspace) (remove this (frame:lookup-focus-table (get-eventspace)))) + (inner (void) on-close)) + + (super-new) + + (frame:set-focus-table (get-eventspace) (frame:lookup-focus-table (get-eventspace))))) + (define basic-mixin (mixin ((class->interface frame%)) (basic<%>) @@ -190,12 +211,11 @@ (λ (% parent) (make-object % parent))) - (inherit can-close? on-close) - (define/public close - (λ () - (when (can-close?) - (on-close) - (show #f)))) + (inherit on-close can-close?) + (define/public (close) + (when (can-close?) + (on-close) + (show #f))) (inherit accept-drop-files) @@ -2710,7 +2730,7 @@ (min-width (+ (inexact->exact (ceiling indicator-width)) 4)) (min-height (+ (inexact->exact (ceiling indicator-height)) 4)))) -(define basic% (register-group-mixin (basic-mixin frame%))) +(define basic% (focus-table-mixin (register-group-mixin (basic-mixin frame%)))) (define size-pref% (size-pref-mixin basic%)) (define info% (info-mixin basic%)) (define text-info% (text-info-mixin info%)) diff --git a/collects/framework/private/sig.rkt b/collects/framework/private/sig.rkt index 60520eeb3f..aa76198d74 100644 --- a/collects/framework/private/sig.rkt +++ b/collects/framework/private/sig.rkt @@ -256,6 +256,7 @@ (define-signature frame-class^ (basic<%> + focus-table<%> size-pref<%> register-group<%> status-line<%> @@ -285,6 +286,7 @@ delegate% pasteboard% + focus-table-mixin basic-mixin size-pref-mixin register-group-mixin diff --git a/collects/framework/test.rkt b/collects/framework/test.rkt index fe4bf793ca..df53fc681a 100644 --- a/collects/framework/test.rkt +++ b/collects/framework/test.rkt @@ -1,10 +1,12 @@ #lang at-exp scheme/gui -(require scribble/srcdoc) -(require/doc scheme/base scribble/manual) +(require scribble/srcdoc + (prefix-in :: framework/private/focus-table)) +(require/doc scheme/base scribble/manual + (for-label framework)) (define (test:top-level-focus-window-has? pred) - (let ([tlw (get-top-level-focus-window)]) + (let ([tlw (test:get-active-top-level-window)]) (and tlw (let loop ([tlw tlw]) (or (pred tlw) @@ -165,16 +167,30 @@ (define current-get-eventspaces (make-parameter (λ () (list (current-eventspace))))) -(define (get-active-frame) +(define test:use-focus-table (make-parameter #f)) + +(define (test:get-active-top-level-window) (ormap (λ (eventspace) (parameterize ([current-eventspace eventspace]) - (get-top-level-focus-window))) + (cond + [(test:use-focus-table) + (define lst (::frame:lookup-focus-table)) + (define focusd (and (not (null? lst)) (car lst))) + (when (eq? (test:use-focus-table) 'debug) + (define f2 (get-top-level-focus-window)) + (unless (eq? focusd f2) + (eprintf "found mismatch focus-table: ~s vs get-top-level-focus-window: ~s\n" + (map (λ (x) (send x get-label)) lst) + (and f2 (list (send f2 get-label)))))) + focusd] + [else + (get-top-level-focus-window)]))) ((current-get-eventspaces)))) (define (get-focused-window) - (let ([f (get-active-frame)]) + (let ([f (test:get-active-top-level-window)]) (and f - (send f get-focus-window)))) + (send f get-edit-target-window)))) (define time-stamp current-milliseconds) @@ -200,14 +216,13 @@ ;; get-parent returns () for no parent. ;; -(define in-active-frame? - (λ (window) - (let ([frame (get-active-frame)]) - (let loop ([window window]) - (cond [(not window) #f] - [(null? window) #f] ;; is this test needed? - [(eq? window frame) #t] - [else (loop (send window get-parent))]))))) +(define (in-active-frame? window) + (let ([frame (test:get-active-top-level-window)]) + (let loop ([window window]) + (cond [(not window) #f] + [(null? window) #f] ;; is this test needed? + [(eq? window frame) #t] + [else (loop (send window get-parent))])))) ;; ;; Verify modifier list. @@ -239,7 +254,7 @@ (cond [(or (string? b-desc) (procedure? b-desc)) - (let* ([active-frame (get-active-frame)] + (let* ([active-frame (test:get-active-top-level-window)] [_ (unless active-frame (error object-tag "could not find object: ~a, no active frame" @@ -516,7 +531,7 @@ [else (error key-tag - "focused window is not a text-field% and does not have on-char")])] + "focused window is not a text-field% and does not have on-char, ~e" window)])] [(send (car l) on-subwindow-char window event) #f] [else (loop (cdr l))]))) @@ -573,21 +588,20 @@ (define menu-tag 'test:menu-select) -(define menu-select - (λ (menu-name . item-names) - (cond - [(not (string? menu-name)) - (error menu-tag "expects string, given: ~e" menu-name)] - [(not (andmap string? item-names)) - (error menu-tag "expects strings, given: ~e" item-names)] - [else - (run-one - (λ () - (let* ([frame (get-active-frame)] - [item (get-menu-item frame (cons menu-name item-names))] - [evt (make-object control-event% 'menu)]) - (send evt set-time-stamp (current-milliseconds)) - (send item command evt))))]))) +(define (menu-select menu-name . item-names) + (cond + [(not (string? menu-name)) + (error menu-tag "expects string, given: ~e" menu-name)] + [(not (andmap string? item-names)) + (error menu-tag "expects strings, given: ~e" item-names)] + [else + (run-one + (λ () + (let* ([frame (test:get-active-top-level-window)] + [item (get-menu-item frame (cons menu-name item-names))] + [evt (make-object control-event% 'menu)]) + (send evt set-time-stamp (current-milliseconds)) + (send item command evt))))])) (define get-menu-item (λ (frame item-names) @@ -1021,7 +1035,7 @@ test:top-level-focus-window-has? (-> (-> (is-a?/c area<%>) boolean?) boolean?) (test) - @{Calls @racket[test] for each child of the top-level-focus-frame + @{Calls @racket[test] for each child of the @racket[test:get-active-top-level-window] and returns @racket[#t] if @racket[test] ever does, otherwise returns @racket[#f]. If there is no top-level-focus-window, returns @racket[#f].}) @@ -1041,4 +1055,20 @@ test:run-one (-> (-> void?) void?) (f) - @{Runs the function @racket[f] as if it was a simulated event.})) + @{Runs the function @racket[f] as if it was a simulated event.}) + + (parameter-doc + test:use-focus-table + (parameter/c (or/c boolean? 'debug)) + use-focus-table? + @{If @racket[#t], then the test framework uses @racket[frame:lookup-focus-table] to determine + which is the focused frame. If @racket[#f], then it uses @racket[get-top-level-focus-window]. + If @racket[test:use-focus-table]'s value is @racket['debug], then it still uses + @racket[frame:lookup-focus-table] but it also prints a message to the @racket[current-error-port] + when the two methods would give different results.}) + + (proc-doc/names + test:get-active-top-level-window + (-> (or/c (is-a?/c frame%) (is-a?/c dialog%) #f)) + () + @{Returns the frontmost frame, based on @racket[test:use-focus-table].})) diff --git a/collects/scribblings/framework/frame.scrbl b/collects/scribblings/framework/frame.scrbl index 571909cbbf..7e5a16ccc1 100644 --- a/collects/scribblings/framework/frame.scrbl +++ b/collects/scribblings/framework/frame.scrbl @@ -162,6 +162,35 @@ using the @method[frame:basic<%> make-root-area-container] method). } } + +@definterface[frame:focus-table<%> (frame%)]{} + +@defmixin[frame:focus-table-mixin (frame%) (frame:focus-table<%>)]{ + + Instances of classes returned from this mixin track how frontmost they are + based on calls made to methods at the Racket level, instead of using + the calls made by the operating system as it tracks the focus. + + See also @racket[frame:lookup-focus-table], @racket[test:use-focus-table] + and @racket[test:get-active-top-level-window]. + + @defmethod[#:mode override (show [on? boolean?]) void?]{ + When @racket[on?] is @racket[#t], adds this frame to the + front of the list of frames stored with the frame's eventspace. When + @racket[on?] is @racket[#f], this method removes this frame + from the list. + + See also @racket[frame:lookup-focus-table], @racket[test:use-focus-table] + and @racket[test:get-active-top-level-window]. + } + @defmethod[#:mode augment (on-close) void?]{ + Removes this frame from the list of frames stored with the frame's eventspace. + + See also @racket[frame:lookup-focus-table], @racket[test:use-focus-table] + and @racket[test:get-active-top-level-window]. + } +} + @definterface[frame:size-pref<%> (frame:basic<%>)]{ } diff --git a/collects/scribblings/framework/main-extracts.rkt b/collects/scribblings/framework/main-extracts.rkt index 443097475f..6d7e7c29f2 100644 --- a/collects/scribblings/framework/main-extracts.rkt +++ b/collects/scribblings/framework/main-extracts.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base (require scribble/extract) (provide-extracted (lib "framework/main.rkt")) diff --git a/collects/tests/drracket/no-write-and-frame-leak.rkt b/collects/tests/drracket/no-write-and-frame-leak.rkt index 1adbd72ef2..0a3b4f03b0 100644 --- a/collects/tests/drracket/no-write-and-frame-leak.rkt +++ b/collects/tests/drracket/no-write-and-frame-leak.rkt @@ -12,12 +12,6 @@ (error who "Deleting files is not allowed"))) void void)]) - (fire-up-drscheme-and-run-tests - (λ () - (define drs-frame (wait-for-drscheme-frame)) - (test:menu-select "File" "Close")))) - -(parameterize ([current-command-line-arguments '#()]) (fire-up-drscheme-and-run-tests (λ () (define drs-frame1 (wait-for-drscheme-frame)) @@ -29,7 +23,7 @@ (define drs-tabb (make-weak-box (send drs-frame1 get-current-tab))) (define tab-nsb (make-weak-box (send (send (send drs-frame1 get-current-tab) get-ints) get-user-namespace))) - (test:menu-select "File" "Close Tab") + (test:menu-select "File" (if (eq? (system-type) 'unix) "Close" "Close Tab")) (sync (system-idle-evt)) (test:menu-select "File" "New") @@ -38,7 +32,7 @@ (define drs-frame2b (make-weak-box (wait-for-new-frame drs-frame1))) (define frame2-nsb (make-weak-box (send (send (send (weak-box-value drs-frame2b) get-current-tab) get-ints) get-user-namespace))) - (test:menu-select "File" "Close") + (test:menu-select "File" (if (eq? (system-type) 'unix) "Close" "Close Window")) (sync (system-idle-evt)) (let loop ([n 30]) diff --git a/collects/tests/drracket/private/drracket-test-util.rkt b/collects/tests/drracket/private/drracket-test-util.rkt index 5d22431ccf..d0314f1ae9 100644 --- a/collects/tests/drracket/private/drracket-test-util.rkt +++ b/collects/tests/drracket/private/drracket-test-util.rkt @@ -61,7 +61,7 @@ (fw:preferences:set 'framework:file-dialogs 'common) (open-dialog) (let ([dlg (wait-for-new-frame drs)]) - (send (find-labelled-window "Filename:") focus) + (send (find-labelled-window "Filename:" #f (fw:test:get-active-top-level-window)) focus) (fw:test:keystroke #\a (list (case (system-type) [(windows) 'control] [(macosx macos) 'meta] @@ -100,7 +100,7 @@ (define (wait-for-drscheme-frame [print-message? #f]) (let ([wait-for-drscheme-frame-pred (lambda () - (let ([active (get-top-level-focus-window)]) + (let ([active (fw:test:get-active-top-level-window)]) (if (and active (drscheme-frame? active)) active @@ -123,15 +123,14 @@ [(old-frame extra-eventspaces timeout) (let ([wait-for-new-frame-pred (lambda () - (let ([active (or (get-top-level-focus-window) - (ormap + (let ([active (or (fw:test:get-active-top-level-window) + (ormap (lambda (eventspace) - (parameterize ([current-eventspace eventspace]) - (get-top-level-focus-window))) + (parameterize ([current-eventspace eventspace]) + (fw:test:get-active-top-level-window))) extra-eventspaces))]) (if (and active - (send active get-focus-window) - (not (eq? active old-frame))) + (not (eq? active old-frame))) active #f)))]) (poll-until wait-for-new-frame-pred timeout))])) @@ -172,7 +171,7 @@ (define (verify-drscheme-frame-frontmost function-name frame) (on-eventspace-handler-thread 'verify-drscheme-frame-frontmost) - (let ([tl (get-top-level-focus-window)]) + (let ([tl (fw:test:get-active-top-level-window)]) (unless (and (eq? frame tl) (drscheme-frame? tl)) (error function-name "drscheme frame not frontmost: ~e (found ~e)" frame tl)))) @@ -180,9 +179,9 @@ (define (clear-definitions frame) (queue-callback/res (λ () (verify-drscheme-frame-frontmost 'clear-definitions frame))) (fw:test:new-window (queue-callback/res (λ () (send frame get-definitions-canvas)))) - (let ([window (queue-callback/res (λ () (send frame get-focus-window)))]) + (let ([window (queue-callback/res (λ () (send frame get-edit-target-window)))]) (let-values ([(cw ch) (queue-callback/res (λ () (send window get-client-size)))] - [(w h) (queue-callback/res (λ () (send window get-size)))]) + [(w h) (queue-callback/res (λ () (send window get-size)))]) (fw:test:mouse-click 'left (inexact->exact (floor (+ cw (/ (- w cw) 2)))) (inexact->exact (floor (+ ch (/ (- h ch) 2))))))) @@ -344,10 +343,10 @@ (andmap (lambda (x) (or string? regexp?)) in-language-spec)) (error 'set-language-level! "expected a non-empty list of regexps and strings for language, got: ~e" in-language-spec)) (not-on-eventspace-handler-thread 'set-language-level!) - (let ([drs-frame (get-top-level-focus-window)]) + (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%)] + [language-choice (find-labelled-window #f hierarchical-list% (fw:test:get-active-top-level-window))] [b1 (box 0)] [b2 (box 0)] [click-on-snip @@ -411,7 +410,7 @@ drs-frame)))))))) (define (set-module-language! [close-dialog? #t]) (not-on-eventspace-handler-thread 'set-module-language!) - (let ([drs-frame (get-top-level-focus-window)]) + (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)]) (fw:test:set-radio-box-item! #rx"Use the language declared in the source") @@ -616,7 +615,9 @@ ;; been read by this point, but hopefully that won't affect much ;; of the startup of drscheme) (fw:preferences:restore-defaults) - + + (fw:test:use-focus-table #t) + (thread (λ () (let ([orig-display-handler (error-display-handler)]) (uncaught-exception-handler diff --git a/collects/tests/drracket/repl-test.rkt b/collects/tests/drracket/repl-test.rkt index 051168a4e1..7d2ff09807 100644 --- a/collects/tests/drracket/repl-test.rkt +++ b/collects/tests/drracket/repl-test.rkt @@ -1201,18 +1201,21 @@ This produces an ACK message (case language-cust [(raw) (void)] [else + (define edit-target (queue-callback/res (λ () (send drscheme-frame get-edit-target-window)))) + (define defs-focus? (eq? edit-target definitions-canvas)) + (define ints-focus? (eq? edit-target interactions-canvas)) (cond [(eq? source-location 'definitions) - (unless (send definitions-canvas has-focus?) + (unless defs-focus? (fprintf (current-error-port) "FAILED execute test for ~s\n expected definitions to have the focus\n" program))] [(eq? source-location 'interactions) - (unless (send interactions-canvas has-focus?) + (unless ints-focus? (fprintf (current-error-port) "FAILED execute test for ~s\n expected interactions to have the focus\n" program))] - [(queue-callback/res (λ () (send definitions-canvas has-focus?))) + [defs-focus? (let ([start (car source-location)] [finish (cdr source-location)]) (let* ([error-ranges (queue-callback/res (λ () (send interactions-text get-error-ranges)))] diff --git a/collects/tests/drracket/stepper-test.rkt b/collects/tests/drracket/stepper-test.rkt index c9d660ec5a..7742c09805 100644 --- a/collects/tests/drracket/stepper-test.rkt +++ b/collects/tests/drracket/stepper-test.rkt @@ -488,7 +488,7 @@ (set-definitions-to-program drs-frame program) (let* ([stepper-frame (start-stepper drs-frame)] [steps (get-all-steps stepper-frame)]) - (test:menu-select "File" "Close") + (test:menu-select "File" (if (eq? (system-type) 'unix) "Close" "Close Window")) (let ([drs-frame1 (wait-for-new-frame stepper-frame)]) (unless (eq? drs-frame1 drs-frame) (error 'step-and-extract "didn't get back to drscheme frame, got: ~e" drs-frame))) diff --git a/collects/tests/drracket/teaching-lang-save-file.rkt b/collects/tests/drracket/teaching-lang-save-file.rkt index 297b7b42b7..4856656572 100644 --- a/collects/tests/drracket/teaching-lang-save-file.rkt +++ b/collects/tests/drracket/teaching-lang-save-file.rkt @@ -30,7 +30,7 @@ (error 'save-teaching-lang-file.rkt "expected the saved file to contain the word 'metadata' in a comment")) (do-execute drr-frame) - (test:menu-select "File" "Close Tab") + (test:menu-select "File" (if (eq? (system-type) 'unix) "Close" "Close Tab")) (use-get/put-dialog (λ () (test:menu-select "File" "Open...")) @@ -40,7 +40,7 @@ drr-frame (send interactions-text paragraph-start-position 2) (send interactions-text last-position))]) - (test:menu-select "File" "Close Tab") + (test:menu-select "File" (if (eq? (system-type) 'unix) "Close" "Close Tab")) (delete-file fn) (unless (equal? result "1\n> ") (error 'save-teaching-lang-file.rkt "expected the program to produce 1 (followed by the prompt), got ~s" result))))))) From 8a30ed73b7e569faf809ca4cd4fa76b61bbd66c6 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 5 Sep 2011 09:41:49 -0500 Subject: [PATCH 138/235] add forgotten file --- collects/framework/private/focus-table.rkt | 13 +++++++++++++ 1 file changed, 13 insertions(+) create mode 100644 collects/framework/private/focus-table.rkt diff --git a/collects/framework/private/focus-table.rkt b/collects/framework/private/focus-table.rkt new file mode 100644 index 0000000000..e29bb2cbf7 --- /dev/null +++ b/collects/framework/private/focus-table.rkt @@ -0,0 +1,13 @@ +#lang racket/base +(require racket/gui/base racket/class) +(provide frame:lookup-focus-table + frame:set-focus-table) + +;; focus-table : hash[eventspace -o> (listof frame)] +(define focus-table (make-hash)) +(define (frame:lookup-focus-table [eventspace (current-eventspace)]) + (hash-ref focus-table eventspace '())) +(define (frame:set-focus-table eventspace new) + (if (null? new) + (hash-remove! focus-table eventspace) + (hash-set! focus-table eventspace new))) From 67d17645c425509f99d57da752c08f68fbcafe99 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 5 Sep 2011 12:33:53 -0500 Subject: [PATCH 139/235] wrong super interface --- collects/framework/private/frame.rkt | 2 +- collects/scribblings/framework/frame.scrbl | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/framework/private/frame.rkt b/collects/framework/private/frame.rkt index 856b7fde77..9930c009a1 100644 --- a/collects/framework/private/frame.rkt +++ b/collects/framework/private/frame.rkt @@ -133,7 +133,7 @@ get-filename make-visible)) -(define focus-table<%> (interface ((class->interface frame%)))) +(define focus-table<%> (interface (top-level-window<%>))) (define focus-table-mixin (mixin (top-level-window<%>) (focus-table<%>) (inherit get-eventspace) diff --git a/collects/scribblings/framework/frame.scrbl b/collects/scribblings/framework/frame.scrbl index 7e5a16ccc1..1ffda924d5 100644 --- a/collects/scribblings/framework/frame.scrbl +++ b/collects/scribblings/framework/frame.scrbl @@ -163,7 +163,7 @@ } } -@definterface[frame:focus-table<%> (frame%)]{} +@definterface[frame:focus-table<%> (top-level-window<%>)]{} @defmixin[frame:focus-table-mixin (frame%) (frame:focus-table<%>)]{ From 9c77ea71558dd5f7ea245b00f9dff4ef581362b5 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 5 Sep 2011 00:46:07 -0400 Subject: [PATCH 140/235] Actually run the strictness-tests. --- collects/tests/lazy/lang.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/tests/lazy/lang.rkt b/collects/tests/lazy/lang.rkt index 6ff18f6856..3967ce6bb9 100644 --- a/collects/tests/lazy/lang.rkt +++ b/collects/tests/lazy/lang.rkt @@ -207,4 +207,5 @@ (list-tests) (take-tests) (misc-tests) - (pcps-tests)))) + (pcps-tests) + (strictness-tests)))) From 01041988759108dc93201ea8825dabd7bb651d1b Mon Sep 17 00:00:00 2001 From: Jon Zeppieri Date: Mon, 29 Aug 2011 21:10:07 -0400 Subject: [PATCH 141/235] Moved `net/base64' code from unit to module. --- collects/net/base64-unit.rkt | 69 ++------------------------- collects/net/base64.rkt | 67 ++++++++++++++++++++++++-- collects/net/scribblings/base64.scrbl | 4 ++ 3 files changed, 73 insertions(+), 67 deletions(-) diff --git a/collects/net/base64-unit.rkt b/collects/net/base64-unit.rkt index 8fc1d28dbd..6fa00d416d 100644 --- a/collects/net/base64-unit.rkt +++ b/collects/net/base64-unit.rkt @@ -1,67 +1,8 @@ -#lang racket/unit +#lang racket/base -(require "base64-sig.rkt") +(require racket/unit + "base64-sig.rkt" "base64.rkt") -(import) -(export base64^) +(define-unit-from-context base64@ base64^) -(define ranges '([#"AZ" 0] [#"az" 26] [#"09" 52] [#"++" 62] [#"//" 63])) - -(define-values (base64-digit digit-base64) - (let ([bd (make-vector 256 #f)] [db (make-vector 64 #f)]) - (for ([r ranges] #:when #t - [i (in-range (bytes-ref (car r) 0) (add1 (bytes-ref (car r) 1)))] - [n (in-naturals (cadr r))]) - (vector-set! bd i n) - (vector-set! db n i)) - (values (vector->immutable-vector bd) (vector->immutable-vector db)))) - -(define =byte (bytes-ref #"=" 0)) -(define ones - (vector->immutable-vector - (list->vector (for/list ([i (in-range 9)]) (sub1 (arithmetic-shift 1 i)))))) - -(define (base64-decode-stream in out) - (let loop ([data 0] [bits 0]) - (if (>= bits 8) - (let ([bits (- bits 8)]) - (write-byte (arithmetic-shift data (- bits)) out) - (loop (bitwise-and data (vector-ref ones bits)) bits)) - (let ([c (read-byte in)]) - (unless (or (eof-object? c) (eq? c =byte)) - (let ([v (vector-ref base64-digit c)]) - (if v - (loop (+ (arithmetic-shift data 6) v) (+ bits 6)) - (loop data bits)))))))) - -(define (base64-encode-stream in out [linesep #"\n"]) - (let loop ([data 0] [bits 0] [width 0]) - (define (write-char) - (write-byte (vector-ref digit-base64 (arithmetic-shift data (- 6 bits))) - out) - (let ([width (modulo (add1 width) 72)]) - (when (zero? width) (display linesep out)) - width)) - (if (>= bits 6) - (let ([bits (- bits 6)]) - (loop (bitwise-and data (vector-ref ones bits)) bits (write-char))) - (let ([c (read-byte in)]) - (if (eof-object? c) - ;; flush extra bits - (begin - (let ([width (if (> bits 0) (write-char) width)]) - (when (> width 0) - (for ([i (in-range (modulo (- width) 4))]) - (write-byte =byte out)) - (display linesep out)))) - (loop (+ (arithmetic-shift data 8) c) (+ bits 8) width)))))) - -(define (base64-decode src) - (let ([s (open-output-bytes)]) - (base64-decode-stream (open-input-bytes src) s) - (get-output-bytes s))) - -(define (base64-encode src) - (let ([s (open-output-bytes)]) - (base64-encode-stream (open-input-bytes src) s (bytes 13 10)) - (get-output-bytes s))) +(provide base64@) diff --git a/collects/net/base64.rkt b/collects/net/base64.rkt index b9a84cf1b3..087c927d8c 100644 --- a/collects/net/base64.rkt +++ b/collects/net/base64.rkt @@ -1,6 +1,67 @@ #lang racket/base -(require racket/unit "base64-sig.rkt" "base64-unit.rkt") -(define-values/invoke-unit/infer base64@) +(provide base64-encode-stream + base64-decode-stream + base64-encode + base64-decode) -(provide-signature-elements base64^) +(define ranges '([#"AZ" 0] [#"az" 26] [#"09" 52] [#"++" 62] [#"//" 63])) + +(define-values (base64-digit digit-base64) + (let ([bd (make-vector 256 #f)] [db (make-vector 64 #f)]) + (for ([r ranges] #:when #t + [i (in-range (bytes-ref (car r) 0) (add1 (bytes-ref (car r) 1)))] + [n (in-naturals (cadr r))]) + (vector-set! bd i n) + (vector-set! db n i)) + (values (vector->immutable-vector bd) (vector->immutable-vector db)))) + +(define =byte (bytes-ref #"=" 0)) +(define ones + (vector->immutable-vector + (list->vector (for/list ([i (in-range 9)]) (sub1 (arithmetic-shift 1 i)))))) + +(define (base64-decode-stream in out) + (let loop ([data 0] [bits 0]) + (if (>= bits 8) + (let ([bits (- bits 8)]) + (write-byte (arithmetic-shift data (- bits)) out) + (loop (bitwise-and data (vector-ref ones bits)) bits)) + (let ([c (read-byte in)]) + (unless (or (eof-object? c) (eq? c =byte)) + (let ([v (vector-ref base64-digit c)]) + (if v + (loop (+ (arithmetic-shift data 6) v) (+ bits 6)) + (loop data bits)))))))) + +(define (base64-encode-stream in out [linesep #"\n"]) + (let loop ([data 0] [bits 0] [width 0]) + (define (write-char) + (write-byte (vector-ref digit-base64 (arithmetic-shift data (- 6 bits))) + out) + (let ([width (modulo (add1 width) 72)]) + (when (zero? width) (display linesep out)) + width)) + (if (>= bits 6) + (let ([bits (- bits 6)]) + (loop (bitwise-and data (vector-ref ones bits)) bits (write-char))) + (let ([c (read-byte in)]) + (if (eof-object? c) + ;; flush extra bits + (begin + (let ([width (if (> bits 0) (write-char) width)]) + (when (> width 0) + (for ([i (in-range (modulo (- width) 4))]) + (write-byte =byte out)) + (display linesep out)))) + (loop (+ (arithmetic-shift data 8) c) (+ bits 8) width)))))) + +(define (base64-decode src) + (let ([s (open-output-bytes)]) + (base64-decode-stream (open-input-bytes src) s) + (get-output-bytes s))) + +(define (base64-encode src) + (let ([s (open-output-bytes)]) + (base64-encode-stream (open-input-bytes src) s (bytes 13 10)) + (get-output-bytes s))) diff --git a/collects/net/scribblings/base64.scrbl b/collects/net/scribblings/base64.scrbl index 7d74db1fd6..0d3b6293ed 100644 --- a/collects/net/scribblings/base64.scrbl +++ b/collects/net/scribblings/base64.scrbl @@ -46,6 +46,10 @@ end-of-file or Base 64 terminator @litchar{=} from @racket[in].} @section{Base64 Unit} +@margin-note{@racket[base64@] and @racket[base64^] are deprecated. +They exist for backward-compatibility and will likely be removed in +the future. New code should use the @racketmodname[net/base64] module.} + @defmodule[net/base64-unit] @defthing[base64@ unit?]{ From a5222b948186d80552ff70ee154c86719d1db758 Mon Sep 17 00:00:00 2001 From: Jon Zeppieri Date: Mon, 29 Aug 2011 21:16:03 -0400 Subject: [PATCH 142/235] Moved `net/cgi' code from unit to module. --- collects/net/cgi-sig.rkt | 1 - collects/net/cgi-unit.rkt | 209 +------------------------- collects/net/cgi.rkt | 227 ++++++++++++++++++++++++++++- collects/net/scribblings/cgi.scrbl | 4 + 4 files changed, 233 insertions(+), 208 deletions(-) diff --git a/collects/net/cgi-sig.rkt b/collects/net/cgi-sig.rkt index 8e54485ed5..6ec6aacadc 100644 --- a/collects/net/cgi-sig.rkt +++ b/collects/net/cgi-sig.rkt @@ -20,4 +20,3 @@ get-cgi-method ;; -- general HTML utilities -- string->html generate-link-text - diff --git a/collects/net/cgi-unit.rkt b/collects/net/cgi-unit.rkt index 295836e9de..ac90c64e84 100644 --- a/collects/net/cgi-unit.rkt +++ b/collects/net/cgi-unit.rkt @@ -1,207 +1,8 @@ -#lang racket/unit -(require "cgi-sig.rkt" "uri-codec.rkt") +#lang racket/base -(import) -(export cgi^) +(require racket/unit + "cgi-sig.rkt" "cgi.rkt") -;; type bindings = list ((symbol . string)) +(define-unit-from-context cgi@ cgi^) -;; -------------------------------------------------------------------- - -;; Exceptions: - -(define-struct cgi-error ()) - -;; chars : list (char) -;; -- gives the suffix which is invalid, not including the `%' - -(define-struct (incomplete-%-suffix cgi-error) (chars)) - -;; char : char -;; -- an invalid character in a hex string - -(define-struct (invalid-%-suffix cgi-error) (char)) - -;; -------------------------------------------------------------------- - -;; query-string->string : string -> string - -;; -- The input is the string post-processed as per Web specs, which -;; is as follows: -;; spaces are turned into "+"es and lots of things are turned into %XX, where -;; XX are hex digits, eg, %E7 for ~. The output is a regular Scheme string -;; with all the characters converted back. - -(define query-string->string form-urlencoded-decode) - -;; string->html : string -> string -;; -- the input is raw text, the output is HTML appropriately quoted - -(define (string->html s) - (apply string-append - (map (lambda (c) - (case c - [(#\<) "<"] - [(#\>) ">"] - [(#\&) "&"] - [else (string c)])) - (string->list s)))) - -(define default-text-color "#000000") -(define default-bg-color "#ffffff") -(define default-link-color "#cc2200") -(define default-vlink-color "#882200") -(define default-alink-color "#444444") - -;; generate-html-output : -;; html-string x list (html-string) x ... -> () - -(define (generate-html-output title body-lines - [text-color default-text-color] - [bg-color default-bg-color] - [link-color default-link-color] - [vlink-color default-vlink-color] - [alink-color default-alink-color]) - (let ([sa string-append]) - (for ([l `("Content-type: text/html" - "" - "" - "" - "" - ,(sa "" title "") - "" - "" - ,(sa "") - "" - ,@body-lines - "" - "" - "")]) - (display l) - (newline)))) - -;; output-http-headers : -> void -(define (output-http-headers) - (printf "Content-type: text/html\r\n\r\n")) - -;; delimiter->predicate : symbol -> regexp -;; returns a regexp to read a chunk of text up to a delimiter (excluding it) -(define (delimiter->rx delimiter) - (case delimiter - [(amp) #rx#"^[^&]*"] - [(semi) #rx#"^[^;]*"] - [(amp-or-semi) #rx#"^[^&;]*"] - [else (error 'delimiter->rx - "internal-error, unknown delimiter: ~e" delimiter)])) - -;; get-bindings* : iport -> (listof (cons symbol string)) -;; Reads all bindings from the input port. The strings are processed to -;; remove the CGI spec "escape"s. -;; This code is _slightly_ lax: it allows an input to end in -;; (current-alist-separator-mode). It's not clear this is legal by the -;; CGI spec, which suggests that the last value binding must end in an -;; EOF. It doesn't look like this matters. -;; ELI: * Keeping this behavior for now, maybe better to remove it? -;; * Looks like `form-urlencoded->alist' is doing almost exactly -;; the same job this code does. -(define (get-bindings* method ip) - (define (err fmt . xs) - (generate-error-output - (list (format "Server generated malformed input for ~a method:" method) - (apply format fmt xs)))) - (define value-rx (delimiter->rx (current-alist-separator-mode))) - (define (process str) (query-string->string (bytes->string/utf-8 str))) - (let loop ([bindings '()]) - (if (eof-object? (peek-char ip)) - (reverse bindings) - (let () - (define name (car (or (regexp-match #rx"^[^=]+" ip) - (err "Missing field name before `='")))) - (unless (eq? #\= (read-char ip)) - (err "No binding for `~a' field." name)) - (define value (car (regexp-match value-rx ip))) - (read-char ip) ; consume the delimiter, possibly eof (retested above) - (loop (cons (cons (string->symbol (process name)) (process value)) - bindings)))))) - -;; get-bindings/post : () -> bindings -(define (get-bindings/post) - (get-bindings* "POST" (current-input-port))) - -;; get-bindings/get : () -> bindings -(define (get-bindings/get) - (get-bindings* "GET" (open-input-string (getenv "QUERY_STRING")))) - -;; get-bindings : () -> bindings -(define (get-bindings) - (if (string=? (get-cgi-method) "POST") - (get-bindings/post) - (get-bindings/get))) - -;; generate-error-output : list (html-string) -> -(define (generate-error-output error-message-lines) - (generate-html-output "Internal Error" error-message-lines) - (exit)) - -;; bindings-as-html : bindings -> list (html-string) -;; -- formats name-value bindings as HTML appropriate for displaying -(define (bindings-as-html bindings) - `("" - ,@(map (lambda (bind) - (string-append (symbol->string (car bind)) - " --> " - (cdr bind) - "
")) - bindings) - "")) - -;; extract-bindings : (string + symbol) x bindings -> list (string) -;; -- Extracts the bindings associated with a given name. The semantics of -;; forms states that a CHECKBOX may use the same NAME field multiple times. -;; Hence, a list of strings is returned. Note that the result may be the -;; empty list. -(define (extract-bindings field-name bindings) - (let ([field-name (if (symbol? field-name) - field-name (string->symbol field-name))]) - (let loop ([found null] [bindings bindings]) - (if (null? bindings) - found - (if (equal? field-name (caar bindings)) - (loop (cons (cdar bindings) found) (cdr bindings)) - (loop found (cdr bindings))))))) - -;; extract-binding/single : (string + symbol) x bindings -> string -;; -- used in cases where only one binding is supposed to occur -(define (extract-binding/single field-name bindings) - (let* ([field-name (if (symbol? field-name) - field-name (string->symbol field-name))] - [result (extract-bindings field-name bindings)]) - (cond - [(null? result) - (generate-error-output - (cons (format "No binding for field `~a':
" field-name) - (bindings-as-html bindings)))] - [(null? (cdr result)) - (car result)] - [else - (generate-error-output - (cons (format "Multiple bindings for field `~a' where one expected:
" - field-name) - (bindings-as-html bindings)))]))) - -;; get-cgi-method : () -> string -;; -- string is either GET or POST (though future extension is possible) -(define (get-cgi-method) - (or (getenv "REQUEST_METHOD") - (error 'get-cgi-method "no REQUEST_METHOD environment variable"))) - -;; generate-link-text : string x html-string -> html-string -(define (generate-link-text url anchor-text) - (string-append "" anchor-text "")) +(provide cgi@) diff --git a/collects/net/cgi.rkt b/collects/net/cgi.rkt index b848d16f0e..9612982942 100644 --- a/collects/net/cgi.rkt +++ b/collects/net/cgi.rkt @@ -1,6 +1,227 @@ #lang racket/base -(require racket/unit "cgi-sig.rkt" "cgi-unit.rkt") -(define-values/invoke-unit/infer cgi@) +(require "uri-codec.rkt") -(provide-signature-elements cgi^) +(provide + ;; -- exceptions raised -- + (struct-out cgi-error) + (struct-out incomplete-%-suffix) + (struct-out invalid-%-suffix) + + ;; -- cgi methods -- + get-bindings + get-bindings/post + get-bindings/get + output-http-headers + generate-html-output + generate-error-output + bindings-as-html + extract-bindings + extract-binding/single + get-cgi-method + + ;; -- general HTML utilities -- + string->html + generate-link-text) + +;; type bindings = list ((symbol . string)) + +;; -------------------------------------------------------------------- + +;; Exceptions: + +(define-struct cgi-error ()) + +;; chars : list (char) +;; -- gives the suffix which is invalid, not including the `%' + +(define-struct (incomplete-%-suffix cgi-error) (chars)) + +;; char : char +;; -- an invalid character in a hex string + +(define-struct (invalid-%-suffix cgi-error) (char)) + +;; -------------------------------------------------------------------- + +;; query-string->string : string -> string + +;; -- The input is the string post-processed as per Web specs, which +;; is as follows: +;; spaces are turned into "+"es and lots of things are turned into %XX, where +;; XX are hex digits, eg, %E7 for ~. The output is a regular Scheme string +;; with all the characters converted back. + +(define query-string->string form-urlencoded-decode) + +;; string->html : string -> string +;; -- the input is raw text, the output is HTML appropriately quoted + +(define (string->html s) + (apply string-append + (map (lambda (c) + (case c + [(#\<) "<"] + [(#\>) ">"] + [(#\&) "&"] + [else (string c)])) + (string->list s)))) + +(define default-text-color "#000000") +(define default-bg-color "#ffffff") +(define default-link-color "#cc2200") +(define default-vlink-color "#882200") +(define default-alink-color "#444444") + +;; generate-html-output : +;; html-string x list (html-string) x ... -> () + +(define (generate-html-output title body-lines + [text-color default-text-color] + [bg-color default-bg-color] + [link-color default-link-color] + [vlink-color default-vlink-color] + [alink-color default-alink-color]) + (let ([sa string-append]) + (for ([l `("Content-type: text/html" + "" + "" + "" + "" + ,(sa "" title "") + "" + "" + ,(sa "") + "" + ,@body-lines + "" + "" + "")]) + (display l) + (newline)))) + +;; output-http-headers : -> void +(define (output-http-headers) + (printf "Content-type: text/html\r\n\r\n")) + +;; delimiter->predicate : symbol -> regexp +;; returns a regexp to read a chunk of text up to a delimiter (excluding it) +(define (delimiter->rx delimiter) + (case delimiter + [(amp) #rx#"^[^&]*"] + [(semi) #rx#"^[^;]*"] + [(amp-or-semi) #rx#"^[^&;]*"] + [else (error 'delimiter->rx + "internal-error, unknown delimiter: ~e" delimiter)])) + +;; get-bindings* : iport -> (listof (cons symbol string)) +;; Reads all bindings from the input port. The strings are processed to +;; remove the CGI spec "escape"s. +;; This code is _slightly_ lax: it allows an input to end in +;; (current-alist-separator-mode). It's not clear this is legal by the +;; CGI spec, which suggests that the last value binding must end in an +;; EOF. It doesn't look like this matters. +;; ELI: * Keeping this behavior for now, maybe better to remove it? +;; * Looks like `form-urlencoded->alist' is doing almost exactly +;; the same job this code does. +(define (get-bindings* method ip) + (define (err fmt . xs) + (generate-error-output + (list (format "Server generated malformed input for ~a method:" method) + (apply format fmt xs)))) + (define value-rx (delimiter->rx (current-alist-separator-mode))) + (define (process str) (query-string->string (bytes->string/utf-8 str))) + (let loop ([bindings '()]) + (if (eof-object? (peek-char ip)) + (reverse bindings) + (let () + (define name (car (or (regexp-match #rx"^[^=]+" ip) + (err "Missing field name before `='")))) + (unless (eq? #\= (read-char ip)) + (err "No binding for `~a' field." name)) + (define value (car (regexp-match value-rx ip))) + (read-char ip) ; consume the delimiter, possibly eof (retested above) + (loop (cons (cons (string->symbol (process name)) (process value)) + bindings)))))) + +;; get-bindings/post : () -> bindings +(define (get-bindings/post) + (get-bindings* "POST" (current-input-port))) + +;; get-bindings/get : () -> bindings +(define (get-bindings/get) + (get-bindings* "GET" (open-input-string (getenv "QUERY_STRING")))) + +;; get-bindings : () -> bindings +(define (get-bindings) + (if (string=? (get-cgi-method) "POST") + (get-bindings/post) + (get-bindings/get))) + +;; generate-error-output : list (html-string) -> +(define (generate-error-output error-message-lines) + (generate-html-output "Internal Error" error-message-lines) + (exit)) + +;; bindings-as-html : bindings -> list (html-string) +;; -- formats name-value bindings as HTML appropriate for displaying +(define (bindings-as-html bindings) + `("" + ,@(map (lambda (bind) + (string-append (symbol->string (car bind)) + " --> " + (cdr bind) + "
")) + bindings) + "")) + +;; extract-bindings : (string + symbol) x bindings -> list (string) +;; -- Extracts the bindings associated with a given name. The semantics of +;; forms states that a CHECKBOX may use the same NAME field multiple times. +;; Hence, a list of strings is returned. Note that the result may be the +;; empty list. +(define (extract-bindings field-name bindings) + (let ([field-name (if (symbol? field-name) + field-name (string->symbol field-name))]) + (let loop ([found null] [bindings bindings]) + (if (null? bindings) + found + (if (equal? field-name (caar bindings)) + (loop (cons (cdar bindings) found) (cdr bindings)) + (loop found (cdr bindings))))))) + +;; extract-binding/single : (string + symbol) x bindings -> string +;; -- used in cases where only one binding is supposed to occur +(define (extract-binding/single field-name bindings) + (let* ([field-name (if (symbol? field-name) + field-name (string->symbol field-name))] + [result (extract-bindings field-name bindings)]) + (cond + [(null? result) + (generate-error-output + (cons (format "No binding for field `~a':
" field-name) + (bindings-as-html bindings)))] + [(null? (cdr result)) + (car result)] + [else + (generate-error-output + (cons (format "Multiple bindings for field `~a' where one expected:
" + field-name) + (bindings-as-html bindings)))]))) + +;; get-cgi-method : () -> string +;; -- string is either GET or POST (though future extension is possible) +(define (get-cgi-method) + (or (getenv "REQUEST_METHOD") + (error 'get-cgi-method "no REQUEST_METHOD environment variable"))) + +;; generate-link-text : string x html-string -> html-string +(define (generate-link-text url anchor-text) + (string-append "" anchor-text "")) diff --git a/collects/net/scribblings/cgi.scrbl b/collects/net/scribblings/cgi.scrbl index 562d659d92..169ccef9b0 100644 --- a/collects/net/scribblings/cgi.scrbl +++ b/collects/net/scribblings/cgi.scrbl @@ -140,6 +140,10 @@ query is invalid.} @section{CGI Unit} +@margin-note{@racket[cgi@] and @racket[cgi^] are deprecated. +They exist for backward-compatibility and will likely be removed in +the future. New code should use the @racketmodname[net/cgi] module.} + @defmodule[net/cgi-unit] @defthing[cgi@ unit?]{ From 2faa761f533604d99df08a041aa244a45d23495c Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 4 Sep 2011 13:25:14 -0400 Subject: [PATCH 143/235] Use better language for lang-info --- collects/typed/racket/base/no-check.rkt | 2 +- collects/typed/racket/no-check.rkt | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/typed/racket/base/no-check.rkt b/collects/typed/racket/base/no-check.rkt index a5be88a158..4508a415b6 100644 --- a/collects/typed/racket/base/no-check.rkt +++ b/collects/typed/racket/base/no-check.rkt @@ -1,4 +1,4 @@ -#lang racket/base +#lang typed-racket/minimal (require racket/require typed-scheme/no-check (subtract-in typed/racket/base typed-scheme/no-check)) (provide (all-from-out typed/racket/base typed-scheme/no-check)) diff --git a/collects/typed/racket/no-check.rkt b/collects/typed/racket/no-check.rkt index f4ee4b0923..5dec3f1a25 100644 --- a/collects/typed/racket/no-check.rkt +++ b/collects/typed/racket/no-check.rkt @@ -1,4 +1,4 @@ -#lang racket/base +#lang typed-racket/minimal (require racket/require typed-scheme/no-check (subtract-in typed/racket typed-scheme/no-check)) (provide (all-from-out typed/racket typed-scheme/no-check)) From d36257701dc2a3aa05e2a8b6fbd23fd47a262cd7 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 5 Sep 2011 13:33:46 -0400 Subject: [PATCH 144/235] Increase time limit. --- collects/meta/props | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/meta/props b/collects/meta/props index 41cd5fcde5..5a5e0ea0b5 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1608,7 +1608,7 @@ path/s is either such a string or a list of them. "collects/tests/racket/benchmarks/mz/expand-class.rktl" drdr:command-line (racket "-f" *) "collects/tests/racket/benchmarks/mz/parsing.rktl" drdr:command-line (gracket "-f" *) "collects/tests/racket/benchmarks/mz/redsem.rktl" drdr:command-line (racket "-f" * "--" "--skip-struct-test") -"collects/tests/racket/benchmarks/mz/ssax.rktl" drdr:command-line (racket "-f" *) +"collects/tests/racket/benchmarks/mz/ssax.rktl" drdr:command-line (racket "-f" *) drdr:timeout 300 "collects/tests/racket/benchmarks/places" drdr:command-line #f "collects/tests/racket/benchmarks/rx/auto.rkt" drdr:command-line (racket "-t" * "--" "racket" "simple") drdr:timeout 600 "collects/tests/racket/benchmarks/shootout/ackermann.rkt" drdr:command-line (racket "-t" * "--" "10") From 14e62f6caf43207eed54f2436ab3007624f01662 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 5 Sep 2011 13:57:03 -0500 Subject: [PATCH 145/235] when the filename changes, re-run the "what language are we in" code to facilitate things in the s-exp language with relative paths closes PR 12177 --- .../drracket/private/module-language-tools.rkt | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/collects/drracket/private/module-language-tools.rkt b/collects/drracket/private/module-language-tools.rkt index 14c7c42b66..c0751f00e8 100644 --- a/collects/drracket/private/module-language-tools.rkt +++ b/collects/drracket/private/module-language-tools.rkt @@ -89,7 +89,7 @@ (define definitions-text-mixin (mixin (text:basic<%> drracket:unit:definitions-text<%>) (drracket:module-language-tools:definitions-text<%>) - (inherit get-next-settings) + (inherit get-next-settings get-filename) (define in-module-language? #f) ;; true when we are in the module language (define hash-lang-last-location #f) ;; non-false when we know where the hash-lang line ended (define hash-lang-language #f) ;; non-false is the string that was parsed for the language @@ -101,13 +101,26 @@ (inner (void) after-delete start len) (modification-at start)) + (define last-filename #f) + (define/augment (after-save-file success?) + (inner (void) after-save-file success?) + (define this-filename (get-filename)) + (unless (equal? last-filename this-filename) + (set! last-filename this-filename) + (modification-at #f))) + (define timer #f) + ;; modification-at : (or/c #f number) -> void + ;; checks to see if the lang line has changed when start + ;; is in the region of the lang line, or when start is #f, or + ;; when there is no #lang line known. (define/private (modification-at start) (send (send (get-tab) get-frame) when-initialized (λ () (when in-module-language? - (when (or (not hash-lang-last-location) + (when (or (not start) + (not hash-lang-last-location) (<= start hash-lang-last-location)) (unless timer From cda12b39ed2c98ddfa926bae2fbc26287503b8a0 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 5 Sep 2011 14:12:09 -0500 Subject: [PATCH 146/235] more adjustment of the drracket test suites to avoid using os-given focus information also increase the timeout of the io.rkt test --- collects/meta/props | 2 +- collects/tests/drracket/language-test.rkt | 8 ++++---- collects/tests/drracket/module-lang-test-utils.rkt | 4 ++-- collects/tests/drracket/private/randomly-click.rkt | 11 ++++------- collects/tests/drracket/repl-test.rkt | 4 ++-- .../tests/drracket/sample-solutions-one-window.rkt | 2 +- collects/tests/drracket/teachpack.rkt | 6 +++--- collects/tests/drracket/test-engine-test.rkt | 4 ++-- collects/tests/drracket/time-keystrokes.rkt | 2 +- 9 files changed, 20 insertions(+), 23 deletions(-) diff --git a/collects/meta/props b/collects/meta/props index 5a5e0ea0b5..8595c0e60e 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1432,7 +1432,7 @@ path/s is either such a string or a list of them. "collects/tests/drracket/example-tool.rkt" drdr:command-line (gracket "-t" *) "collects/tests/drracket/get-defs-test.rkt" drdr:command-line (gracket *) "collects/tests/drracket/hangman.rkt" responsible (robby matthias) drdr:command-line (gracket *) -"collects/tests/drracket/io.rkt" drdr:command-line (gracket *) +"collects/tests/drracket/io.rkt" drdr:command-line (gracket *) drdr:timeout 500 "collects/tests/drracket/language-test.rkt" responsible (robby matthias) drdr:command-line (gracket *) drdr:timeout 600 "collects/tests/drracket/leaky-frame.rkt" drdr:command-line (gracket *) "collects/tests/drracket/memory-log.rkt" drdr:command-line (gracket *) diff --git a/collects/tests/drracket/language-test.rkt b/collects/tests/drracket/language-test.rkt index a2a5b62f28..8bf26b1bf7 100644 --- a/collects/tests/drracket/language-test.rkt +++ b/collects/tests/drracket/language-test.rkt @@ -1107,10 +1107,10 @@ the settings above should match r5rs (define (test-setting set-setting setting-name expression result) (set-language #f) (set-setting) - (let ([f (get-top-level-focus-window)]) + (let ([f (test:get-active-top-level-window)]) (fw:test:button-push "OK") (wait-for-new-frame f)) - (let* ([drs (get-top-level-focus-window)] + (let* ([drs (test:get-active-top-level-window)] [interactions (send drs get-interactions-text)]) (clear-definitions drs) (type-in-definitions drs expression) @@ -1124,7 +1124,7 @@ the settings above should match r5rs (define (test-hash-bang) (let* ([expression "#!/bin/sh\n1"] [result "1"] - [drs (get-top-level-focus-window)] + [drs (test:get-active-top-level-window)] [interactions (queue-callback (λ () (send drs get-interactions-text)))]) (clear-definitions drs) (type-in-definitions drs expression) @@ -1235,7 +1235,7 @@ the settings above should match r5rs (fw:test:set-check-box! "Insert newlines in printed values" pretty?) - (let ([f (get-top-level-focus-window)]) + (let ([f (test:get-active-top-level-window)]) (fw:test:button-push "OK") (wait-for-new-frame f)))] [shorten diff --git a/collects/tests/drracket/module-lang-test-utils.rkt b/collects/tests/drracket/module-lang-test-utils.rkt index 6782c02d92..284899f0d9 100644 --- a/collects/tests/drracket/module-lang-test-utils.rkt +++ b/collects/tests/drracket/module-lang-test-utils.rkt @@ -147,7 +147,7 @@ (set-module-language! #f) (test:set-radio-box-item! "Debugging") - (let ([f (queue-callback/res (λ () (get-top-level-focus-window)))]) + (let ([f (queue-callback/res (λ () (test:get-active-top-level-window)))]) (test:button-push "OK") (wait-for-new-frame f)) @@ -163,7 +163,7 @@ (define (setup-dialog/run proc) (set-module-language! #f) (proc) - (let ([f (get-top-level-focus-window)]) + (let ([f (test:get-active-top-level-window)]) (test:button-push "OK") (wait-for-new-frame f)) (do-execute drs) diff --git a/collects/tests/drracket/private/randomly-click.rkt b/collects/tests/drracket/private/randomly-click.rkt index a9ebd6e917..0e975eaf0e 100644 --- a/collects/tests/drracket/private/randomly-click.rkt +++ b/collects/tests/drracket/private/randomly-click.rkt @@ -69,7 +69,7 @@ (send area get-label)])) (define (g open-dialog) - (let ((base-window (get-top-level-focus-window))) + (let ((base-window (test:get-active-top-level-window))) (open-dialog) (wait-for-different-frame base-window) (let loop ([n numButtonsToPush] @@ -84,7 +84,7 @@ (when (= 1 (modulo n 10)) (printf "\n")) (flush-output) - (let ((window (get-top-level-focus-window))) + (let ((window (test:get-active-top-level-window))) (cond ;; Back to base-window is not interesting, Reopen [(eq? base-window window) @@ -92,9 +92,6 @@ (wait-for-different-frame base-window) (loop (- n 1) actions)] - ;; get-top-level-focus-window returns #f may imply window not in current eventspace - ;; but it also might just mean we didn't look into subeventspaces(?) - ;; or that we need to wait for something to happen in the GUI(?) [(eq? window #f) (sleep .1) (loop (- n 1) actions)] @@ -137,7 +134,7 @@ ;; the splash screen is in a separate eventspace so wont' show up. (define (wait-for-first-frame) (let loop () - (let ([tlw (get-top-level-focus-window)]) + (let ([tlw (test:get-active-top-level-window)]) (cond [(not tlw) (sleep 1/20) @@ -151,7 +148,7 @@ [(zero? n) (error 'wait-for-different-frame "never got that new window, only this one: ~s" win)] [else - (let ([tlw (get-top-level-focus-window)]) + (let ([tlw (test:get-active-top-level-window)]) (when (eq? win tlw) (sleep 1/10) (loop (- n 1))))]))) diff --git a/collects/tests/drracket/repl-test.rkt b/collects/tests/drracket/repl-test.rkt index 7d2ff09807..d32d03a809 100644 --- a/collects/tests/drracket/repl-test.rkt +++ b/collects/tests/drracket/repl-test.rkt @@ -1336,7 +1336,7 @@ This produces an ACK message (begin (set-language-level! level #f) (test:set-radio-box-item! "No debugging or profiling") - (let ([f (get-top-level-focus-window)]) + (let ([f (test:get-active-top-level-window)]) (test:button-push "OK") (wait-for-new-frame f)))] [(debug) @@ -1345,7 +1345,7 @@ This produces an ACK message (begin (set-language-level! level #f) (test:set-radio-box-item! "Debugging and profiling") - (let ([f (get-top-level-focus-window)]) + (let ([f (test:get-active-top-level-window)]) (test:button-push "OK") (wait-for-new-frame f)))]) diff --git a/collects/tests/drracket/sample-solutions-one-window.rkt b/collects/tests/drracket/sample-solutions-one-window.rkt index f0e2a88e7e..9ee0c97a64 100644 --- a/collects/tests/drracket/sample-solutions-one-window.rkt +++ b/collects/tests/drracket/sample-solutions-one-window.rkt @@ -110,7 +110,7 @@ (custodian-shutdown-all cust)))) (let ([wait-for-kill-window (lambda () - (let ([f (get-top-level-focus-window)]) + (let ([f (test:get-active-top-level-window)]) (and f (equal? (send f get-label) "Evaluation Terminated"))))]) (poll-until wait-for-kill-window) diff --git a/collects/tests/drracket/teachpack.rkt b/collects/tests/drracket/teachpack.rkt index 2aabd7fd88..d7582899b3 100644 --- a/collects/tests/drracket/teachpack.rkt +++ b/collects/tests/drracket/teachpack.rkt @@ -109,11 +109,11 @@ (lambda () (let ([active (or - (get-top-level-focus-window) + (test:get-active-top-level-window) (and (send interactions-text get-user-eventspace) (parameterize ([current-eventspace (send interactions-text get-user-eventspace)]) - (get-top-level-focus-window))))]) + (test:get-active-top-level-window))))]) (if (and active (not (eq? active drs-frame))) active #f)))]) @@ -198,7 +198,7 @@ (fw:test:menu-select "Language" "Clear All Teachpacks") (fw:test:menu-select "Language" "Add Teachpack...") (wait-for-new-frame drs-frame) - (let* ([tp-dialog (get-top-level-focus-window)] + (let* ([tp-dialog (test:get-active-top-level-window)] [choice (find/select-relevant-choice tp-dialog (path->string teachpack))]) (fw:test:button-push "OK") (wait-for-new-frame tp-dialog)) diff --git a/collects/tests/drracket/test-engine-test.rkt b/collects/tests/drracket/test-engine-test.rkt index ad421d727b..e78232459b 100644 --- a/collects/tests/drracket/test-engine-test.rkt +++ b/collects/tests/drracket/test-engine-test.rkt @@ -201,10 +201,10 @@ (define (test-setting set-setting setting-name expression result) (set-language #f) (set-setting) - (let ([f (get-top-level-focus-window)]) + (let ([f (test:get-active-top-level-window)]) (fw:test:button-push "OK") (wait-for-new-frame f)) - (let* ([drs (get-top-level-focus-window)] + (let* ([drs (test:get-active-top-level-window)] [interactions (send drs get-interactions-text)]) (clear-definitions drs) (type-in-definitions drs expression) diff --git a/collects/tests/drracket/time-keystrokes.rkt b/collects/tests/drracket/time-keystrokes.rkt index c1e57b1017..6980a475fd 100644 --- a/collects/tests/drracket/time-keystrokes.rkt +++ b/collects/tests/drracket/time-keystrokes.rkt @@ -41,7 +41,7 @@ (let loop ([n 10]) (when (zero? n) (error 'time-keystrokes "could not find drscheme frame")) - (let ([front-frame (get-top-level-focus-window)]) + (let ([front-frame (test:get-active-top-level-window)]) (unless (eq? front-frame frame) (sleep 1/10) (loop (- n 1))))) From a0eac7ac5c663fae4c57d3d6bf851da744d97e46 Mon Sep 17 00:00:00 2001 From: Jon Zeppieri Date: Mon, 29 Aug 2011 21:21:51 -0400 Subject: [PATCH 147/235] Moved `net/dns' code from unit to module. --- collects/net/dns-unit.rkt | 340 +--------------------------- collects/net/dns.rkt | 341 ++++++++++++++++++++++++++++- collects/net/scribblings/dns.scrbl | 4 + 3 files changed, 347 insertions(+), 338 deletions(-) diff --git a/collects/net/dns-unit.rkt b/collects/net/dns-unit.rkt index 9c0d175963..f5f99fb94b 100644 --- a/collects/net/dns-unit.rkt +++ b/collects/net/dns-unit.rkt @@ -1,338 +1,8 @@ -#lang racket/unit +#lang racket/base -(require "dns-sig.rkt" racket/system racket/udp) +(require racket/unit + "dns-sig.rkt" "dns.rkt") -(import) -(export dns^) +(define-unit-from-context dns@ dns^) -;; UDP retry timeout: -(define INIT-TIMEOUT 50) - -(define types - '((a 1) - (ns 2) - (md 3) - (mf 4) - (cname 5) - (soa 6) - (mb 7) - (mg 8) - (mr 9) - (null 10) - (wks 11) - (ptr 12) - (hinfo 13) - (minfo 14) - (mx 15) - (txt 16))) - -(define classes - '((in 1) - (cs 2) - (ch 3) - (hs 4))) - -(define (cossa i l) - (cond [(null? l) #f] - [(equal? (cadar l) i) (car l)] - [else (cossa i (cdr l))])) - -(define (number->octet-pair n) - (list (arithmetic-shift n -8) - (modulo n 256))) - -(define (octet-pair->number a b) - (+ (arithmetic-shift a 8) b)) - -(define (octet-quad->number a b c d) - (+ (arithmetic-shift a 24) - (arithmetic-shift b 16) - (arithmetic-shift c 8) - d)) - -(define (name->octets s) - (let ([do-one (lambda (s) (cons (bytes-length s) (bytes->list s)))]) - (let loop ([s s]) - (let ([m (regexp-match #rx#"^([^.]*)[.](.*)" s)]) - (if m - (append (do-one (cadr m)) (loop (caddr m))) - (append (do-one s) (list 0))))))) - -(define (make-std-query-header id question-count) - (append (number->octet-pair id) - (list 1 0) ; Opcode & flags (recusive flag set) - (number->octet-pair question-count) - (number->octet-pair 0) - (number->octet-pair 0) - (number->octet-pair 0))) - -(define (make-query id name type class) - (append (make-std-query-header id 1) - (name->octets name) - (number->octet-pair (cadr (assoc type types))) - (number->octet-pair (cadr (assoc class classes))))) - -(define (add-size-tag m) - (append (number->octet-pair (length m)) m)) - -(define (rr-data rr) - (cadddr (cdr rr))) - -(define (rr-type rr) - (cadr rr)) - -(define (rr-name rr) - (car rr)) - -(define (parse-name start reply) - (let ([v (car start)]) - (cond - [(zero? v) - ;; End of name - (values #f (cdr start))] - [(zero? (bitwise-and #xc0 v)) - ;; Normal label - (let loop ([len v][start (cdr start)][accum null]) - (if (zero? len) - (let-values ([(s start) (parse-name start reply)]) - (let ([s0 (list->bytes (reverse accum))]) - (values (if s (bytes-append s0 #"." s) s0) - start))) - (loop (sub1 len) (cdr start) (cons (car start) accum))))] - [else - ;; Compression offset - (let ([offset (+ (arithmetic-shift (bitwise-and #x3f v) 8) - (cadr start))]) - (let-values ([(s ignore-start) - (parse-name (list-tail reply offset) reply)]) - (values s (cddr start))))]))) - -(define (parse-rr start reply) - (let-values ([(name start) (parse-name start reply)]) - (let* ([type (car (cossa (octet-pair->number (car start) (cadr start)) - types))] - [start (cddr start)] - ;; - [class (car (cossa (octet-pair->number (car start) (cadr start)) - classes))] - [start (cddr start)] - ;; - [ttl (octet-quad->number (car start) (cadr start) - (caddr start) (cadddr start))] - [start (cddddr start)] - ;; - [len (octet-pair->number (car start) (cadr start))] - [start (cddr start)]) - ;; Extract next len bytes for data: - (let loop ([len len] [start start] [accum null]) - (if (zero? len) - (values (list name type class ttl (reverse accum)) - start) - (loop (sub1 len) (cdr start) (cons (car start) accum))))))) - -(define (parse-ques start reply) - (let-values ([(name start) (parse-name start reply)]) - (let* ([type (car (cossa (octet-pair->number (car start) (cadr start)) - types))] - [start (cddr start)] - ;; - [class (car (cossa (octet-pair->number (car start) (cadr start)) - classes))] - [start (cddr start)]) - (values (list name type class) start)))) - -(define (parse-n parse start reply n) - (let loop ([n n][start start][accum null]) - (if (zero? n) - (values (reverse accum) start) - (let-values ([(rr start) (parse start reply)]) - (loop (sub1 n) start (cons rr accum)))))) - -(define (dns-query nameserver addr type class) - (unless (assoc type types) - (raise-type-error 'dns-query "DNS query type" type)) - (unless (assoc class classes) - (raise-type-error 'dns-query "DNS query class" class)) - - (let* ([query (make-query (random 256) (string->bytes/latin-1 addr) - type class)] - [udp (udp-open-socket)] - [reply - (dynamic-wind - void - (lambda () - (let ([s (make-bytes 512)]) - (let retry ([timeout INIT-TIMEOUT]) - (udp-send-to udp nameserver 53 (list->bytes query)) - (sync (handle-evt (udp-receive!-evt udp s) - (lambda (r) - (bytes->list (subbytes s 0 (car r))))) - (handle-evt (alarm-evt (+ (current-inexact-milliseconds) - timeout)) - (lambda (v) - (retry (* timeout 2)))))))) - (lambda () (udp-close udp)))]) - - ;; First two bytes must match sent message id: - (unless (and (= (car reply) (car query)) - (= (cadr reply) (cadr query))) - (error 'dns-query "bad reply id from server")) - - (let ([v0 (caddr reply)] - [v1 (cadddr reply)]) - ;; Check for error code: - (let ([rcode (bitwise-and #xf v1)]) - (unless (zero? rcode) - (error 'dns-query "error from server: ~a" - (case rcode - [(1) "format error"] - [(2) "server failure"] - [(3) "name error"] - [(4) "not implemented"] - [(5) "refused"])))) - - (let ([qd-count (octet-pair->number (list-ref reply 4) (list-ref reply 5))] - [an-count (octet-pair->number (list-ref reply 6) (list-ref reply 7))] - [ns-count (octet-pair->number (list-ref reply 8) (list-ref reply 9))] - [ar-count (octet-pair->number (list-ref reply 10) (list-ref reply 11))]) - - (let ([start (list-tail reply 12)]) - (let*-values ([(qds start) (parse-n parse-ques start reply qd-count)] - [(ans start) (parse-n parse-rr start reply an-count)] - [(nss start) (parse-n parse-rr start reply ns-count)] - [(ars start) (parse-n parse-rr start reply ar-count)]) - (unless (null? start) - (error 'dns-query "error parsing server reply")) - (values (positive? (bitwise-and #x4 v0)) - qds ans nss ars reply))))))) - -(define cache (make-hasheq)) -(define (dns-query/cache nameserver addr type class) - (let ([key (string->symbol (format "~a;~a;~a;~a" nameserver addr type class))]) - (let ([v (hash-ref cache key (lambda () #f))]) - (if v - (apply values v) - (let-values ([(auth? qds ans nss ars reply) - (dns-query nameserver addr type class)]) - (hash-set! cache key (list auth? qds ans nss ars reply)) - (values auth? qds ans nss ars reply)))))) - -(define (ip->string s) - (format "~a.~a.~a.~a" - (list-ref s 0) (list-ref s 1) (list-ref s 2) (list-ref s 3))) - -(define (try-forwarding k nameserver) - (let loop ([nameserver nameserver][tried (list nameserver)]) - ;; Normally the recusion is done for us, but it's technically optional - (let-values ([(v ars auth?) (k nameserver)]) - (or v - (and (not auth?) - (let* ([ns (ormap (lambda (ar) - (and (eq? (rr-type ar) 'a) - (ip->string (rr-data ar)))) - ars)]) - (and ns - (not (member ns tried)) - (loop ns (cons ns tried))))))))) - -(define (ip->in-addr.arpa ip) - (let ([result (regexp-match #rx"^([0-9]+)\\.([0-9]+)\\.([0-9]+)\\.([0-9]+)$" - ip)]) - (format "~a.~a.~a.~a.in-addr.arpa" - (list-ref result 4) - (list-ref result 3) - (list-ref result 2) - (list-ref result 1)))) - -(define (get-ptr-list-from-ans ans) - (filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'ptr)) ans)) - -(define (dns-get-name nameserver ip) - (or (try-forwarding - (lambda (nameserver) - (let-values ([(auth? qds ans nss ars reply) - (dns-query/cache nameserver (ip->in-addr.arpa ip) 'ptr 'in)]) - (values (and (positive? (length (get-ptr-list-from-ans ans))) - (let ([s (rr-data (car (get-ptr-list-from-ans ans)))]) - (let-values ([(name null) (parse-name s reply)]) - (bytes->string/latin-1 name)))) - ars auth?))) - nameserver) - (error 'dns-get-name "bad ip address"))) - -(define (get-a-list-from-ans ans) - (filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'a)) - ans)) - -(define (dns-get-address nameserver addr) - (or (try-forwarding - (lambda (nameserver) - (let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'a 'in)]) - (values (and (positive? (length (get-a-list-from-ans ans))) - (let ([s (rr-data (car (get-a-list-from-ans ans)))]) - (ip->string s))) - ars auth?))) - nameserver) - (error 'dns-get-address "bad address"))) - -(define (dns-get-mail-exchanger nameserver addr) - (or (try-forwarding - (lambda (nameserver) - (let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'mx 'in)]) - (values (let loop ([ans ans][best-pref +inf.0][exchanger #f]) - (cond - [(null? ans) - (or exchanger - ;; Does 'soa mean that the input address is fine? - (and (ormap (lambda (ns) (eq? (rr-type ns) 'soa)) - nss) - addr))] - [else - (let ([d (rr-data (car ans))]) - (let ([pref (octet-pair->number (car d) (cadr d))]) - (if (< pref best-pref) - (let-values ([(name start) (parse-name (cddr d) reply)]) - (loop (cdr ans) pref name)) - (loop (cdr ans) best-pref exchanger))))])) - ars auth?))) - nameserver) - (error 'dns-get-mail-exchanger "bad address"))) - -(define (dns-find-nameserver) - (case (system-type) - [(unix macosx) - (with-handlers ([void (lambda (x) #f)]) - (with-input-from-file "/etc/resolv.conf" - (lambda () - (let loop () - (let ([l (read-line)]) - (or (and (string? l) - (let ([m (regexp-match - #rx"nameserver[ \t]+([0-9]+[.][0-9]+[.][0-9]+[.][0-9]+)" - l)]) - (and m (cadr m)))) - (and (not (eof-object? l)) - (loop))))))))] - [(windows) - (let ([nslookup (find-executable-path "nslookup.exe" #f)]) - (and nslookup - (let-values ([(pin pout pid perr proc) - (apply - values - (process/ports - #f (open-input-file "NUL") (current-error-port) - nslookup))]) - (let loop ([name #f] [ip #f] [try-ip? #f]) - (let ([line (read-line pin 'any)]) - (cond [(eof-object? line) - (close-input-port pin) - (proc 'wait) - (or ip name)] - [(and (not name) - (regexp-match #rx"^Default Server: +(.*)$" line)) - => (lambda (m) (loop (cadr m) #f #t))] - [(and try-ip? - (regexp-match #rx"^Address: +(.*)$" line)) - => (lambda (m) (loop name (cadr m) #f))] - [else (loop name ip #f)]))))))] - [else #f])) +(provide dns@) diff --git a/collects/net/dns.rkt b/collects/net/dns.rkt index 901649091f..6496204bb7 100644 --- a/collects/net/dns.rkt +++ b/collects/net/dns.rkt @@ -1,6 +1,341 @@ #lang racket/base -(require racket/unit "dns-sig.rkt" "dns-unit.rkt") -(define-values/invoke-unit/infer dns@) +(require racket/udp + racket/system) -(provide-signature-elements dns^) +(provide dns-get-address + dns-get-name + dns-get-mail-exchanger + dns-find-nameserver) + +;; UDP retry timeout: +(define INIT-TIMEOUT 50) + +(define types + '((a 1) + (ns 2) + (md 3) + (mf 4) + (cname 5) + (soa 6) + (mb 7) + (mg 8) + (mr 9) + (null 10) + (wks 11) + (ptr 12) + (hinfo 13) + (minfo 14) + (mx 15) + (txt 16))) + +(define classes + '((in 1) + (cs 2) + (ch 3) + (hs 4))) + +(define (cossa i l) + (cond [(null? l) #f] + [(equal? (cadar l) i) (car l)] + [else (cossa i (cdr l))])) + +(define (number->octet-pair n) + (list (arithmetic-shift n -8) + (modulo n 256))) + +(define (octet-pair->number a b) + (+ (arithmetic-shift a 8) b)) + +(define (octet-quad->number a b c d) + (+ (arithmetic-shift a 24) + (arithmetic-shift b 16) + (arithmetic-shift c 8) + d)) + +(define (name->octets s) + (let ([do-one (lambda (s) (cons (bytes-length s) (bytes->list s)))]) + (let loop ([s s]) + (let ([m (regexp-match #rx#"^([^.]*)[.](.*)" s)]) + (if m + (append (do-one (cadr m)) (loop (caddr m))) + (append (do-one s) (list 0))))))) + +(define (make-std-query-header id question-count) + (append (number->octet-pair id) + (list 1 0) ; Opcode & flags (recusive flag set) + (number->octet-pair question-count) + (number->octet-pair 0) + (number->octet-pair 0) + (number->octet-pair 0))) + +(define (make-query id name type class) + (append (make-std-query-header id 1) + (name->octets name) + (number->octet-pair (cadr (assoc type types))) + (number->octet-pair (cadr (assoc class classes))))) + +(define (add-size-tag m) + (append (number->octet-pair (length m)) m)) + +(define (rr-data rr) + (cadddr (cdr rr))) + +(define (rr-type rr) + (cadr rr)) + +(define (rr-name rr) + (car rr)) + +(define (parse-name start reply) + (let ([v (car start)]) + (cond + [(zero? v) + ;; End of name + (values #f (cdr start))] + [(zero? (bitwise-and #xc0 v)) + ;; Normal label + (let loop ([len v][start (cdr start)][accum null]) + (if (zero? len) + (let-values ([(s start) (parse-name start reply)]) + (let ([s0 (list->bytes (reverse accum))]) + (values (if s (bytes-append s0 #"." s) s0) + start))) + (loop (sub1 len) (cdr start) (cons (car start) accum))))] + [else + ;; Compression offset + (let ([offset (+ (arithmetic-shift (bitwise-and #x3f v) 8) + (cadr start))]) + (let-values ([(s ignore-start) + (parse-name (list-tail reply offset) reply)]) + (values s (cddr start))))]))) + +(define (parse-rr start reply) + (let-values ([(name start) (parse-name start reply)]) + (let* ([type (car (cossa (octet-pair->number (car start) (cadr start)) + types))] + [start (cddr start)] + ;; + [class (car (cossa (octet-pair->number (car start) (cadr start)) + classes))] + [start (cddr start)] + ;; + [ttl (octet-quad->number (car start) (cadr start) + (caddr start) (cadddr start))] + [start (cddddr start)] + ;; + [len (octet-pair->number (car start) (cadr start))] + [start (cddr start)]) + ;; Extract next len bytes for data: + (let loop ([len len] [start start] [accum null]) + (if (zero? len) + (values (list name type class ttl (reverse accum)) + start) + (loop (sub1 len) (cdr start) (cons (car start) accum))))))) + +(define (parse-ques start reply) + (let-values ([(name start) (parse-name start reply)]) + (let* ([type (car (cossa (octet-pair->number (car start) (cadr start)) + types))] + [start (cddr start)] + ;; + [class (car (cossa (octet-pair->number (car start) (cadr start)) + classes))] + [start (cddr start)]) + (values (list name type class) start)))) + +(define (parse-n parse start reply n) + (let loop ([n n][start start][accum null]) + (if (zero? n) + (values (reverse accum) start) + (let-values ([(rr start) (parse start reply)]) + (loop (sub1 n) start (cons rr accum)))))) + +(define (dns-query nameserver addr type class) + (unless (assoc type types) + (raise-type-error 'dns-query "DNS query type" type)) + (unless (assoc class classes) + (raise-type-error 'dns-query "DNS query class" class)) + + (let* ([query (make-query (random 256) (string->bytes/latin-1 addr) + type class)] + [udp (udp-open-socket)] + [reply + (dynamic-wind + void + (lambda () + (let ([s (make-bytes 512)]) + (let retry ([timeout INIT-TIMEOUT]) + (udp-send-to udp nameserver 53 (list->bytes query)) + (sync (handle-evt (udp-receive!-evt udp s) + (lambda (r) + (bytes->list (subbytes s 0 (car r))))) + (handle-evt (alarm-evt (+ (current-inexact-milliseconds) + timeout)) + (lambda (v) + (retry (* timeout 2)))))))) + (lambda () (udp-close udp)))]) + + ;; First two bytes must match sent message id: + (unless (and (= (car reply) (car query)) + (= (cadr reply) (cadr query))) + (error 'dns-query "bad reply id from server")) + + (let ([v0 (caddr reply)] + [v1 (cadddr reply)]) + ;; Check for error code: + (let ([rcode (bitwise-and #xf v1)]) + (unless (zero? rcode) + (error 'dns-query "error from server: ~a" + (case rcode + [(1) "format error"] + [(2) "server failure"] + [(3) "name error"] + [(4) "not implemented"] + [(5) "refused"])))) + + (let ([qd-count (octet-pair->number (list-ref reply 4) (list-ref reply 5))] + [an-count (octet-pair->number (list-ref reply 6) (list-ref reply 7))] + [ns-count (octet-pair->number (list-ref reply 8) (list-ref reply 9))] + [ar-count (octet-pair->number (list-ref reply 10) (list-ref reply 11))]) + + (let ([start (list-tail reply 12)]) + (let*-values ([(qds start) (parse-n parse-ques start reply qd-count)] + [(ans start) (parse-n parse-rr start reply an-count)] + [(nss start) (parse-n parse-rr start reply ns-count)] + [(ars start) (parse-n parse-rr start reply ar-count)]) + (unless (null? start) + (error 'dns-query "error parsing server reply")) + (values (positive? (bitwise-and #x4 v0)) + qds ans nss ars reply))))))) + +(define cache (make-hasheq)) +(define (dns-query/cache nameserver addr type class) + (let ([key (string->symbol (format "~a;~a;~a;~a" nameserver addr type class))]) + (let ([v (hash-ref cache key (lambda () #f))]) + (if v + (apply values v) + (let-values ([(auth? qds ans nss ars reply) + (dns-query nameserver addr type class)]) + (hash-set! cache key (list auth? qds ans nss ars reply)) + (values auth? qds ans nss ars reply)))))) + +(define (ip->string s) + (format "~a.~a.~a.~a" + (list-ref s 0) (list-ref s 1) (list-ref s 2) (list-ref s 3))) + +(define (try-forwarding k nameserver) + (let loop ([nameserver nameserver][tried (list nameserver)]) + ;; Normally the recusion is done for us, but it's technically optional + (let-values ([(v ars auth?) (k nameserver)]) + (or v + (and (not auth?) + (let* ([ns (ormap (lambda (ar) + (and (eq? (rr-type ar) 'a) + (ip->string (rr-data ar)))) + ars)]) + (and ns + (not (member ns tried)) + (loop ns (cons ns tried))))))))) + +(define (ip->in-addr.arpa ip) + (let ([result (regexp-match #rx"^([0-9]+)\\.([0-9]+)\\.([0-9]+)\\.([0-9]+)$" + ip)]) + (format "~a.~a.~a.~a.in-addr.arpa" + (list-ref result 4) + (list-ref result 3) + (list-ref result 2) + (list-ref result 1)))) + +(define (get-ptr-list-from-ans ans) + (filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'ptr)) ans)) + +(define (dns-get-name nameserver ip) + (or (try-forwarding + (lambda (nameserver) + (let-values ([(auth? qds ans nss ars reply) + (dns-query/cache nameserver (ip->in-addr.arpa ip) 'ptr 'in)]) + (values (and (positive? (length (get-ptr-list-from-ans ans))) + (let ([s (rr-data (car (get-ptr-list-from-ans ans)))]) + (let-values ([(name null) (parse-name s reply)]) + (bytes->string/latin-1 name)))) + ars auth?))) + nameserver) + (error 'dns-get-name "bad ip address"))) + +(define (get-a-list-from-ans ans) + (filter (lambda (ans-entry) (eq? (list-ref ans-entry 1) 'a)) + ans)) + +(define (dns-get-address nameserver addr) + (or (try-forwarding + (lambda (nameserver) + (let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'a 'in)]) + (values (and (positive? (length (get-a-list-from-ans ans))) + (let ([s (rr-data (car (get-a-list-from-ans ans)))]) + (ip->string s))) + ars auth?))) + nameserver) + (error 'dns-get-address "bad address"))) + +(define (dns-get-mail-exchanger nameserver addr) + (or (try-forwarding + (lambda (nameserver) + (let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'mx 'in)]) + (values (let loop ([ans ans][best-pref +inf.0][exchanger #f]) + (cond + [(null? ans) + (or exchanger + ;; Does 'soa mean that the input address is fine? + (and (ormap (lambda (ns) (eq? (rr-type ns) 'soa)) + nss) + addr))] + [else + (let ([d (rr-data (car ans))]) + (let ([pref (octet-pair->number (car d) (cadr d))]) + (if (< pref best-pref) + (let-values ([(name start) (parse-name (cddr d) reply)]) + (loop (cdr ans) pref name)) + (loop (cdr ans) best-pref exchanger))))])) + ars auth?))) + nameserver) + (error 'dns-get-mail-exchanger "bad address"))) + +(define (dns-find-nameserver) + (case (system-type) + [(unix macosx) + (with-handlers ([void (lambda (x) #f)]) + (with-input-from-file "/etc/resolv.conf" + (lambda () + (let loop () + (let ([l (read-line)]) + (or (and (string? l) + (let ([m (regexp-match + #rx"nameserver[ \t]+([0-9]+[.][0-9]+[.][0-9]+[.][0-9]+)" + l)]) + (and m (cadr m)))) + (and (not (eof-object? l)) + (loop))))))))] + [(windows) + (let ([nslookup (find-executable-path "nslookup.exe" #f)]) + (and nslookup + (let-values ([(pin pout pid perr proc) + (apply + values + (process/ports + #f (open-input-file "NUL") (current-error-port) + nslookup))]) + (let loop ([name #f] [ip #f] [try-ip? #f]) + (let ([line (read-line pin 'any)]) + (cond [(eof-object? line) + (close-input-port pin) + (proc 'wait) + (or ip name)] + [(and (not name) + (regexp-match #rx"^Default Server: +(.*)$" line)) + => (lambda (m) (loop (cadr m) #f #t))] + [(and try-ip? + (regexp-match #rx"^Address: +(.*)$" line)) + => (lambda (m) (loop name (cadr m) #f))] + [else (loop name ip #f)]))))))] + [else #f])) diff --git a/collects/net/scribblings/dns.scrbl b/collects/net/scribblings/dns.scrbl index 016a237413..552c59d202 100644 --- a/collects/net/scribblings/dns.scrbl +++ b/collects/net/scribblings/dns.scrbl @@ -56,6 +56,10 @@ extract the first nameserver address. On Windows, it runs @section{DNS Unit} +@margin-note{@racket[dns@] and @racket[dns^] are deprecated. +They exist for backward-compatibility and will likely be removed in +the future. New code should use the @racketmodname[net/dns] module.} + @defmodule[net/dns-unit] @defthing[dns@ unit?]{ From 03237c06f2754ed75450defc61ad5da979adb47a Mon Sep 17 00:00:00 2001 From: Jon Zeppieri Date: Mon, 29 Aug 2011 21:26:28 -0400 Subject: [PATCH 148/235] Moved `net/ftp' code from unit to module. --- collects/net/ftp-unit.rkt | 211 +--------------------------- collects/net/ftp.rkt | 215 ++++++++++++++++++++++++++++- collects/net/scribblings/ftp.scrbl | 4 + 3 files changed, 221 insertions(+), 209 deletions(-) diff --git a/collects/net/ftp-unit.rkt b/collects/net/ftp-unit.rkt index 77436f8f4d..42432a561f 100644 --- a/collects/net/ftp-unit.rkt +++ b/collects/net/ftp-unit.rkt @@ -1,213 +1,12 @@ -#lang racket/unit +#lang racket/base ;; Version 0.2 ;; Version 0.1a ;; Micah Flatt ;; 06-06-2002 -(require racket/date racket/file racket/port racket/tcp "ftp-sig.rkt") -(import) -(export ftp^) +(require racket/unit + "ftp-sig.rkt" "ftp.rkt") -;; opqaue record to represent an FTP connection: -(define-struct ftp-connection (in out)) +(define-unit-from-context ftp@ ftp^) -(define re:multi-response-start #rx#"^[0-9][0-9][0-9]-") -(define re:response-end #rx#"^[0-9][0-9][0-9] ") - -(define (check-expected-result line expected) - (when expected - (unless (ormap (lambda (expected) - (bytes=? expected (subbytes line 0 3))) - (if (bytes? expected) - (list expected) - expected)) - (error 'ftp "expected result code ~a, got ~a" expected line)))) - -;; ftp-check-response : input-port output-port bytes-or-byteslist-or-#f (bytes any -> any) any -> any -;; -;; Checks a standard-format response, checking for the given -;; expected 3-digit result code if expected is not #f. -;; -;; While checking, the function sends response lines to -;; diagnostic-accum. This function -accum functions can return a -;; value that accumulates over multiple calls to the function, and -;; accum-start is used as the initial value. Use `void' and -;; `(void)' to ignore the response info. -;; -;; If an unexpected result is found, an exception is raised, and the -;; stream is left in an undefined state. -(define (ftp-check-response tcpin tcpout expected diagnostic-accum accum-start) - (flush-output tcpout) - (let ([line (read-bytes-line tcpin 'any)]) - (cond - [(eof-object? line) - (error 'ftp "unexpected EOF")] - [(regexp-match re:multi-response-start line) - (check-expected-result line expected) - (let ([re:done (regexp (format "^~a " (subbytes line 0 3)))]) - (let loop ([accum (diagnostic-accum line accum-start)]) - (let ([line (read-bytes-line tcpin 'any)]) - (cond [(eof-object? line) - (error 'ftp "unexpected EOF")] - [(regexp-match re:done line) - (diagnostic-accum line accum)] - [else - (loop (diagnostic-accum line accum))]))))] - [(regexp-match re:response-end line) - (check-expected-result line expected) - (diagnostic-accum line accum-start)] - [else - (error 'ftp "unexpected result: ~e" line)]))) - -(define (get-month month-bytes) - (cond [(assoc month-bytes - '((#"Jan" 1) (#"Feb" 2) (#"Mar" 3) (#"Apr" 4) (#"May" 5) - (#"Jun" 6) (#"Jul" 7) (#"Aug" 8) (#"Sep" 9) (#"Oct" 10) - (#"Nov" 11) (#"Dec" 12))) - => cadr] - [else (error 'get-month "bad month: ~s" month-bytes)])) - -(define (bytes->number bytes) - (string->number (bytes->string/latin-1 bytes))) - -(define re:date #rx#"(...) *(.*) (..):(..)|(...) *([0-9]*) +(....)") - -(define (ftp-make-file-seconds ftp-date-str) - (define date-list (regexp-match re:date (string->bytes/utf-8 ftp-date-str))) - (if (not (list-ref date-list 4)) - (find-seconds 0 0 0 - (bytes->number (list-ref date-list 6)) - (get-month (list-ref date-list 5)) - (bytes->number (list-ref date-list 7))) - (let* ([cur-secs (current-seconds)] - [cur-date (seconds->date cur-secs)] - [cur-year (date-year cur-date)] - [tzofs (date-time-zone-offset cur-date)] - [minute (bytes->number (list-ref date-list 4))] - [hour (bytes->number (list-ref date-list 3))] - [day (bytes->number (list-ref date-list 2))] - [month (get-month (list-ref date-list 1))] - [guess (+ (find-seconds 0 minute hour day month cur-year) tzofs)]) - (if (guess . <= . cur-secs) - guess - (+ (find-seconds 0 minute hour day month (sub1 cur-year)) tzofs))))) - -(define re:passive #rx#"\\((.*),(.*),(.*),(.*),(.*),(.*)\\)") - -(define (establish-data-connection tcp-ports) - (fprintf (ftp-connection-out tcp-ports) "PASV\r\n") - (let ([response (ftp-check-response - (ftp-connection-in tcp-ports) - (ftp-connection-out tcp-ports) - #"227" - (lambda (s ignore) s) ; should be the only response - (void))]) - (let* ([reg-list (regexp-match re:passive response)] - [pn1 (and reg-list - (bytes->number (list-ref reg-list 5)))] - [pn2 (bytes->number (list-ref reg-list 6))]) - (unless (and reg-list pn1 pn2) - (error 'ftp "can't understand PASV response: ~e" response)) - (let-values ([(tcp-data tcp-data-out) - (tcp-connect (format "~a.~a.~a.~a" - (list-ref reg-list 1) - (list-ref reg-list 2) - (list-ref reg-list 3) - (list-ref reg-list 4)) - (+ (* 256 pn1) pn2))]) - (fprintf (ftp-connection-out tcp-ports) "TYPE I\r\n") - (ftp-check-response (ftp-connection-in tcp-ports) - (ftp-connection-out tcp-ports) - #"200" void (void)) - (tcp-abandon-port tcp-data-out) - tcp-data)))) - -;; Used where version 0.1a printed responses: -(define (print-msg s ignore) - ;; (printf "~a\n" s) - (void)) - -(define (ftp-establish-connection* in out username password) - (ftp-check-response in out #"220" print-msg (void)) - (fprintf out "USER ~a\r\n" username) - (let ([no-password? (ftp-check-response - in out (list #"331" #"230") - (lambda (line 230?) - (or 230? (regexp-match #rx#"^230" line))) - #f)]) - (unless no-password? - (fprintf out "PASS ~a\r\n" password) - (ftp-check-response in out #"230" void (void)))) - (make-ftp-connection in out)) - -(define (ftp-establish-connection server-address server-port username password) - (let-values ([(tcpin tcpout) (tcp-connect server-address server-port)]) - (ftp-establish-connection* tcpin tcpout username password))) - -(define (ftp-close-connection tcp-ports) - (fprintf (ftp-connection-out tcp-ports) "QUIT\r\n") - (ftp-check-response (ftp-connection-in tcp-ports) - (ftp-connection-out tcp-ports) - #"221" void (void)) - (close-input-port (ftp-connection-in tcp-ports)) - (close-output-port (ftp-connection-out tcp-ports))) - -(define (ftp-cd ftp-ports new-dir) - (fprintf (ftp-connection-out ftp-ports) "CWD ~a\r\n" new-dir) - (ftp-check-response (ftp-connection-in ftp-ports) - (ftp-connection-out ftp-ports) - #"250" void (void))) - -(define re:dir-line - (regexp (string-append - "^(.)(.*) ((?i:jan|feb|mar|apr|may|jun|jul|aug|sep|oct|nov|dec)" - " .* [0-9][0-9]:?[0-9][0-9]) (.*)$"))) - -(define (ftp-directory-list tcp-ports [path #f]) - (define tcp-data (establish-data-connection tcp-ports)) - (if path - (fprintf (ftp-connection-out tcp-ports) "LIST ~a\r\n" path) - (fprintf (ftp-connection-out tcp-ports) "LIST\r\n")) - (ftp-check-response (ftp-connection-in tcp-ports) - (ftp-connection-out tcp-ports) - (list #"150" #"125") void (void)) - (define lines (port->lines tcp-data)) - (close-input-port tcp-data) - (ftp-check-response (ftp-connection-in tcp-ports) - (ftp-connection-out tcp-ports) - #"226" print-msg (void)) - (for*/list ([l (in-list lines)] - [m (in-value (cond [(regexp-match re:dir-line l) => cdr] - [else #f]))] - #:when m) - (define size (cond [(and (equal? "-" (car m)) - (regexp-match #rx"([0-9]+) *$" (cadr m))) - => cadr] - [else #f])) - (define r `(,(car m) ,@(cddr m))) - (if size `(,@r ,size) r))) - -(define (ftp-download-file tcp-ports folder filename) - ;; Save the file under the name tmp.file, rename it once download is - ;; complete this assures we don't over write any existing file without - ;; having a good file down - (let* ([tmpfile (make-temporary-file - (string-append - (regexp-replace - #rx"~" - (path->string (build-path folder "ftptmp")) - "~~") - "~a"))] - [new-file (open-output-file tmpfile #:exists 'replace)] - [tcp-data (establish-data-connection tcp-ports)]) - (fprintf (ftp-connection-out tcp-ports) "RETR ~a\r\n" filename) - (ftp-check-response (ftp-connection-in tcp-ports) - (ftp-connection-out tcp-ports) - (list #"125" #"150") print-msg (void)) - (copy-port tcp-data new-file) - (close-output-port new-file) - (close-input-port tcp-data) - (ftp-check-response (ftp-connection-in tcp-ports) - (ftp-connection-out tcp-ports) - #"226" print-msg (void)) - (rename-file-or-directory tmpfile (build-path folder filename) #t))) +(provide ftp@) diff --git a/collects/net/ftp.rkt b/collects/net/ftp.rkt index 5e4ff2a349..6702448612 100644 --- a/collects/net/ftp.rkt +++ b/collects/net/ftp.rkt @@ -1,6 +1,215 @@ #lang racket/base -(require racket/unit "ftp-sig.rkt" "ftp-unit.rkt") -(define-values/invoke-unit/infer ftp@) +(require racket/date racket/file racket/port racket/tcp) -(provide-signature-elements ftp^) +(provide ftp-connection? + ftp-cd + ftp-establish-connection ftp-establish-connection* + ftp-close-connection + ftp-directory-list + ftp-download-file + ftp-make-file-seconds) + +;; opqaue record to represent an FTP connection: +(define-struct ftp-connection (in out)) + +(define re:multi-response-start #rx#"^[0-9][0-9][0-9]-") +(define re:response-end #rx#"^[0-9][0-9][0-9] ") + +(define (check-expected-result line expected) + (when expected + (unless (ormap (lambda (expected) + (bytes=? expected (subbytes line 0 3))) + (if (bytes? expected) + (list expected) + expected)) + (error 'ftp "expected result code ~a, got ~a" expected line)))) + +;; ftp-check-response : input-port output-port bytes-or-byteslist-or-#f (bytes any -> any) any -> any +;; +;; Checks a standard-format response, checking for the given +;; expected 3-digit result code if expected is not #f. +;; +;; While checking, the function sends response lines to +;; diagnostic-accum. This function -accum functions can return a +;; value that accumulates over multiple calls to the function, and +;; accum-start is used as the initial value. Use `void' and +;; `(void)' to ignore the response info. +;; +;; If an unexpected result is found, an exception is raised, and the +;; stream is left in an undefined state. +(define (ftp-check-response tcpin tcpout expected diagnostic-accum accum-start) + (flush-output tcpout) + (let ([line (read-bytes-line tcpin 'any)]) + (cond + [(eof-object? line) + (error 'ftp "unexpected EOF")] + [(regexp-match re:multi-response-start line) + (check-expected-result line expected) + (let ([re:done (regexp (format "^~a " (subbytes line 0 3)))]) + (let loop ([accum (diagnostic-accum line accum-start)]) + (let ([line (read-bytes-line tcpin 'any)]) + (cond [(eof-object? line) + (error 'ftp "unexpected EOF")] + [(regexp-match re:done line) + (diagnostic-accum line accum)] + [else + (loop (diagnostic-accum line accum))]))))] + [(regexp-match re:response-end line) + (check-expected-result line expected) + (diagnostic-accum line accum-start)] + [else + (error 'ftp "unexpected result: ~e" line)]))) + +(define (get-month month-bytes) + (cond [(assoc month-bytes + '((#"Jan" 1) (#"Feb" 2) (#"Mar" 3) (#"Apr" 4) (#"May" 5) + (#"Jun" 6) (#"Jul" 7) (#"Aug" 8) (#"Sep" 9) (#"Oct" 10) + (#"Nov" 11) (#"Dec" 12))) + => cadr] + [else (error 'get-month "bad month: ~s" month-bytes)])) + +(define (bytes->number bytes) + (string->number (bytes->string/latin-1 bytes))) + +(define re:date #rx#"(...) *(.*) (..):(..)|(...) *([0-9]*) +(....)") + +(define (ftp-make-file-seconds ftp-date-str) + (define date-list (regexp-match re:date (string->bytes/utf-8 ftp-date-str))) + (if (not (list-ref date-list 4)) + (find-seconds 0 0 0 + (bytes->number (list-ref date-list 6)) + (get-month (list-ref date-list 5)) + (bytes->number (list-ref date-list 7))) + (let* ([cur-secs (current-seconds)] + [cur-date (seconds->date cur-secs)] + [cur-year (date-year cur-date)] + [tzofs (date-time-zone-offset cur-date)] + [minute (bytes->number (list-ref date-list 4))] + [hour (bytes->number (list-ref date-list 3))] + [day (bytes->number (list-ref date-list 2))] + [month (get-month (list-ref date-list 1))] + [guess (+ (find-seconds 0 minute hour day month cur-year) tzofs)]) + (if (guess . <= . cur-secs) + guess + (+ (find-seconds 0 minute hour day month (sub1 cur-year)) tzofs))))) + +(define re:passive #rx#"\\((.*),(.*),(.*),(.*),(.*),(.*)\\)") + +(define (establish-data-connection tcp-ports) + (fprintf (ftp-connection-out tcp-ports) "PASV\r\n") + (let ([response (ftp-check-response + (ftp-connection-in tcp-ports) + (ftp-connection-out tcp-ports) + #"227" + (lambda (s ignore) s) ; should be the only response + (void))]) + (let* ([reg-list (regexp-match re:passive response)] + [pn1 (and reg-list + (bytes->number (list-ref reg-list 5)))] + [pn2 (bytes->number (list-ref reg-list 6))]) + (unless (and reg-list pn1 pn2) + (error 'ftp "can't understand PASV response: ~e" response)) + (let-values ([(tcp-data tcp-data-out) + (tcp-connect (format "~a.~a.~a.~a" + (list-ref reg-list 1) + (list-ref reg-list 2) + (list-ref reg-list 3) + (list-ref reg-list 4)) + (+ (* 256 pn1) pn2))]) + (fprintf (ftp-connection-out tcp-ports) "TYPE I\r\n") + (ftp-check-response (ftp-connection-in tcp-ports) + (ftp-connection-out tcp-ports) + #"200" void (void)) + (tcp-abandon-port tcp-data-out) + tcp-data)))) + +;; Used where version 0.1a printed responses: +(define (print-msg s ignore) + ;; (printf "~a\n" s) + (void)) + +(define (ftp-establish-connection* in out username password) + (ftp-check-response in out #"220" print-msg (void)) + (fprintf out "USER ~a\r\n" username) + (let ([no-password? (ftp-check-response + in out (list #"331" #"230") + (lambda (line 230?) + (or 230? (regexp-match #rx#"^230" line))) + #f)]) + (unless no-password? + (fprintf out "PASS ~a\r\n" password) + (ftp-check-response in out #"230" void (void)))) + (make-ftp-connection in out)) + +(define (ftp-establish-connection server-address server-port username password) + (let-values ([(tcpin tcpout) (tcp-connect server-address server-port)]) + (ftp-establish-connection* tcpin tcpout username password))) + +(define (ftp-close-connection tcp-ports) + (fprintf (ftp-connection-out tcp-ports) "QUIT\r\n") + (ftp-check-response (ftp-connection-in tcp-ports) + (ftp-connection-out tcp-ports) + #"221" void (void)) + (close-input-port (ftp-connection-in tcp-ports)) + (close-output-port (ftp-connection-out tcp-ports))) + +(define (ftp-cd ftp-ports new-dir) + (fprintf (ftp-connection-out ftp-ports) "CWD ~a\r\n" new-dir) + (ftp-check-response (ftp-connection-in ftp-ports) + (ftp-connection-out ftp-ports) + #"250" void (void))) + +(define re:dir-line + (regexp (string-append + "^(.)(.*) ((?i:jan|feb|mar|apr|may|jun|jul|aug|sep|oct|nov|dec)" + " .* [0-9][0-9]:?[0-9][0-9]) (.*)$"))) + +(define (ftp-directory-list tcp-ports [path #f]) + (define tcp-data (establish-data-connection tcp-ports)) + (if path + (fprintf (ftp-connection-out tcp-ports) "LIST ~a\r\n" path) + (fprintf (ftp-connection-out tcp-ports) "LIST\r\n")) + (ftp-check-response (ftp-connection-in tcp-ports) + (ftp-connection-out tcp-ports) + (list #"150" #"125") void (void)) + (define lines (port->lines tcp-data)) + (close-input-port tcp-data) + (ftp-check-response (ftp-connection-in tcp-ports) + (ftp-connection-out tcp-ports) + #"226" print-msg (void)) + (for*/list ([l (in-list lines)] + [m (in-value (cond [(regexp-match re:dir-line l) => cdr] + [else #f]))] + #:when m) + (define size (cond [(and (equal? "-" (car m)) + (regexp-match #rx"([0-9]+) *$" (cadr m))) + => cadr] + [else #f])) + (define r `(,(car m) ,@(cddr m))) + (if size `(,@r ,size) r))) + +(define (ftp-download-file tcp-ports folder filename) + ;; Save the file under the name tmp.file, rename it once download is + ;; complete this assures we don't over write any existing file without + ;; having a good file down + (let* ([tmpfile (make-temporary-file + (string-append + (regexp-replace + #rx"~" + (path->string (build-path folder "ftptmp")) + "~~") + "~a"))] + [new-file (open-output-file tmpfile #:exists 'replace)] + [tcp-data (establish-data-connection tcp-ports)]) + (fprintf (ftp-connection-out tcp-ports) "RETR ~a\r\n" filename) + (ftp-check-response (ftp-connection-in tcp-ports) + (ftp-connection-out tcp-ports) + (list #"125" #"150") print-msg (void)) + (copy-port tcp-data new-file) + (close-output-port new-file) + (close-input-port tcp-data) + (ftp-check-response (ftp-connection-in tcp-ports) + (ftp-connection-out tcp-ports) + #"226" print-msg (void)) + (rename-file-or-directory tmpfile (build-path folder filename) #t))) diff --git a/collects/net/scribblings/ftp.scrbl b/collects/net/scribblings/ftp.scrbl index 7c8fc253db..1bbcaf0387 100644 --- a/collects/net/scribblings/ftp.scrbl +++ b/collects/net/scribblings/ftp.scrbl @@ -88,6 +88,10 @@ file, then moved into place on success).} @section{FTP Unit} +@margin-note{@racket[ftp@] and @racket[ftp^] are deprecated. +They exist for backward-compatibility and will likely be removed in +the future. New code should use the @racketmodname[net/ftp] module.} + @defmodule[net/ftp-unit] @defthing[ftp@ unit?]{ From 095ee4e00761f1286ddcd600041e11df3425d931 Mon Sep 17 00:00:00 2001 From: Jon Zeppieri Date: Mon, 29 Aug 2011 21:29:37 -0400 Subject: [PATCH 149/235] Moved `net/head' code from unit to module. --- collects/net/head-unit.rkt | 347 +-------------------------- collects/net/head.rkt | 355 +++++++++++++++++++++++++++- collects/net/scribblings/head.scrbl | 4 + 3 files changed, 361 insertions(+), 345 deletions(-) diff --git a/collects/net/head-unit.rkt b/collects/net/head-unit.rkt index 8f182333a1..1a1606b729 100644 --- a/collects/net/head-unit.rkt +++ b/collects/net/head-unit.rkt @@ -1,345 +1,8 @@ -#lang racket/unit +#lang racket/base -(require racket/date racket/string "head-sig.rkt") +(require racket/unit + "head-sig.rkt" "head.rkt") -(import) -(export head^) +(define-unit-from-context head@ head^) -;; NB: I've done a copied-code adaptation of a number of these definitions -;; into "bytes-compatible" versions. Finishing the rest will require some -;; kind of interface decision---that is, when you don't supply a header, -;; should the resulting operation be string-centric or bytes-centric? -;; Easiest just to stop here. -;; -- JBC 2006-07-31 - -(define CRLF (string #\return #\newline)) -(define CRLF/bytes #"\r\n") - -(define empty-header CRLF) -(define empty-header/bytes CRLF/bytes) - -(define re:field-start (regexp "^[^ \t\n\r\v:\001-\032\"]*:")) -(define re:field-start/bytes #rx#"^[^ \t\n\r\v:\001-\032\"]*:") - -(define re:continue (regexp "^[ \t\v]")) -(define re:continue/bytes #rx#"^[ \t\v]") - -(define (validate-header s) - (if (bytes? s) - ;; legal char check not needed per rfc 2822, IIUC. - (let ([len (bytes-length s)]) - (let loop ([offset 0]) - (cond - [(and (= (+ offset 2) len) - (bytes=? CRLF/bytes (subbytes s offset len))) - (void)] ; validated - [(= offset len) (error 'validate-header "missing ending CRLF")] - [(or (regexp-match re:field-start/bytes s offset) - (regexp-match re:continue/bytes s offset)) - (let ([m (regexp-match-positions #rx#"\r\n" s offset)]) - (if m - (loop (cdar m)) - (error 'validate-header "missing ending CRLF")))] - [else (error 'validate-header "ill-formed header at ~s" - (subbytes s offset (bytes-length s)))]))) - ;; otherwise it should be a string: - (begin - (let ([m (regexp-match #rx"[^\000-\377]" s)]) - (when m - (error 'validate-header "non-Latin-1 character in string: ~v" (car m)))) - (let ([len (string-length s)]) - (let loop ([offset 0]) - (cond - [(and (= (+ offset 2) len) - (string=? CRLF (substring s offset len))) - (void)] ; validated - [(= offset len) (error 'validate-header "missing ending CRLF")] - [(or (regexp-match re:field-start s offset) - (regexp-match re:continue s offset)) - (let ([m (regexp-match-positions #rx"\r\n" s offset)]) - (if m - (loop (cdar m)) - (error 'validate-header "missing ending CRLF")))] - [else (error 'validate-header "ill-formed header at ~s" - (substring s offset (string-length s)))])))))) - -(define (make-field-start-regexp field) - (regexp (format "(^|[\r][\n])(~a: *)" (regexp-quote field #f)))) - -(define (make-field-start-regexp/bytes field) - (byte-regexp (bytes-append #"(^|[\r][\n])("(regexp-quote field #f) #": *)"))) - -(define (extract-field field header) - (if (bytes? header) - (let ([m (regexp-match-positions (make-field-start-regexp/bytes field) - header)]) - (and m - (let ([s (subbytes header - (cdaddr m) - (bytes-length header))]) - (let ([m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)]) - (if m - (subbytes s 0 (caar m)) - ;; Rest of header is this field, but strip trailing CRLFCRLF: - (regexp-replace #rx#"\r\n\r\n$" s "")))))) - ;; otherwise header & field should be strings: - (let ([m (regexp-match-positions (make-field-start-regexp field) - header)]) - (and m - (let ([s (substring header - (cdaddr m) - (string-length header))]) - (let ([m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)]) - (if m - (substring s 0 (caar m)) - ;; Rest of header is this field, but strip trailing CRLFCRLF: - (regexp-replace #rx"\r\n\r\n$" s "")))))))) - -(define (replace-field field data header) - (if (bytes? header) - (let ([m (regexp-match-positions (make-field-start-regexp/bytes field) - header)]) - (if m - (let* ([pre (subbytes header 0 (caaddr m))] - [s (subbytes header (cdaddr m))] - [m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)] - [rest (if m (subbytes s (+ 2 (caar m))) empty-header/bytes)]) - (bytes-append pre (if data (insert-field field data rest) rest))) - (if data (insert-field field data header) header))) - ;; otherwise header & field & data should be strings: - (let ([m (regexp-match-positions (make-field-start-regexp field) header)]) - (if m - (let* ([pre (substring header 0 (caaddr m))] - [s (substring header (cdaddr m))] - [m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)] - [rest (if m (substring s (+ 2 (caar m))) empty-header)]) - (string-append pre (if data (insert-field field data rest) rest))) - (if data (insert-field field data header) header))))) - -(define (remove-field field header) - (replace-field field #f header)) - -(define (insert-field field data header) - (if (bytes? header) - (let ([field (bytes-append field #": "data #"\r\n")]) - (bytes-append field header)) - ;; otherwise field, data, & header should be strings: - (let ([field (format "~a: ~a\r\n" field data)]) - (string-append field header)))) - -(define (append-headers a b) - (if (bytes? a) - (let ([alen (bytes-length a)]) - (if (> alen 1) - (bytes-append (subbytes a 0 (- alen 2)) b) - (error 'append-headers "first argument is not a header: ~a" a))) - ;; otherwise, a & b should be strings: - (let ([alen (string-length a)]) - (if (> alen 1) - (string-append (substring a 0 (- alen 2)) b) - (error 'append-headers "first argument is not a header: ~a" a))))) - -(define (extract-all-fields header) - (if (bytes? header) - (let ([re #rx#"(^|[\r][\n])(([^\r\n:\"]*): *)"]) - (let loop ([start 0]) - (let ([m (regexp-match-positions re header start)]) - (if m - (let ([start (cdaddr m)] - [field-name (subbytes header (caaddr (cdr m)) - (cdaddr (cdr m)))]) - (let ([m2 (regexp-match-positions - #rx#"\r\n[^: \r\n\"]*:" - header - start)]) - (if m2 - (cons (cons field-name - (subbytes header start (caar m2))) - (loop (caar m2))) - ;; Rest of header is this field, but strip trailing CRLFCRLF: - (list - (cons field-name - (regexp-replace #rx#"\r\n\r\n$" - (subbytes header start (bytes-length header)) - "")))))) - ;; malformed header: - null)))) - ;; otherwise, header should be a string: - (let ([re #rx"(^|[\r][\n])(([^\r\n:\"]*): *)"]) - (let loop ([start 0]) - (let ([m (regexp-match-positions re header start)]) - (if m - (let ([start (cdaddr m)] - [field-name (substring header (caaddr (cdr m)) (cdaddr (cdr m)))]) - (let ([m2 (regexp-match-positions - #rx"\r\n[^: \r\n\"]*:" header start)]) - (if m2 - (cons (cons field-name - (substring header start (caar m2))) - (loop (caar m2))) - ;; Rest of header is this field, but strip trailing CRLFCRLF: - (list - (cons field-name - (regexp-replace #rx"\r\n\r\n$" - (substring header start (string-length header)) - "")))))) - ;; malformed header: - null)))))) - -;; It's slightly less obvious how to generalize the functions that don't -;; accept a header as input; for lack of an obvious solution (and free time), -;; I'm stopping the string->bytes translation here. -- JBC, 2006-07-31 - -(define (standard-message-header from tos ccs bccs subject) - (let ([h (insert-field - "Subject" subject - (insert-field - "Date" (parameterize ([date-display-format 'rfc2822]) - (date->string (seconds->date (current-seconds)) #t)) - CRLF))]) - ;; NOTE: bccs don't go into the header; that's why they're "blind" - (let ([h (if (null? ccs) - h - (insert-field "CC" (assemble-address-field ccs) h))]) - (let ([h (if (null? tos) - h - (insert-field "To" (assemble-address-field tos) h))]) - (insert-field "From" from h))))) - -(define (splice l sep) - (if (null? l) - "" - (format "~a~a" - (car l) - (apply string-append - (map (lambda (n) (format "~a~a" sep n)) - (cdr l)))))) - -(define (data-lines->data datas) - (splice datas "\r\n\t")) - -;; Extracting Addresses ;; - -(define blank "[ \t\n\r\v]") -(define nonblank "[^ \t\n\r\v]") -(define re:all-blank (regexp (format "^~a*$" blank))) -(define re:quoted (regexp "\"[^\"]*\"")) -(define re:parened (regexp "[(][^)]*[)]")) -(define re:comma (regexp ",")) -(define re:comma-separated (regexp "([^,]*),(.*)")) - -(define (extract-addresses s form) - (unless (memq form '(name address full all)) - (raise-type-error 'extract-addresses - "form: 'name, 'address, 'full, or 'all" - form)) - (if (or (not s) (regexp-match re:all-blank s)) - null - (let loop ([prefix ""][s s]) - ;; Which comes first - a quote or a comma? - (let* ([mq1 (regexp-match-positions re:quoted s)] - [mq2 (regexp-match-positions re:parened s)] - [mq (if (and mq1 mq2) - (if (< (caar mq1) (caar mq2)) mq1 mq2) - (or mq1 mq2))] - [mc (regexp-match-positions re:comma s)]) - (if (and mq mc (< (caar mq) (caar mc) (cdar mq))) - ;; Quote contains a comma - (loop (string-append - prefix - (substring s 0 (cdar mq))) - (substring s (cdar mq) (string-length s))) - ;; Normal comma parsing: - (let ([m (regexp-match re:comma-separated s)]) - (if m - (let ([n (extract-one-name (string-append prefix (cadr m)) form)] - [rest (extract-addresses (caddr m) form)]) - (cons n rest)) - (let ([n (extract-one-name (string-append prefix s) form)]) - (list n))))))))) - -(define (select-result form name addr full) - (case form - [(name) name] - [(address) addr] - [(full) full] - [(all) (list name addr full)])) - -(define (one-result form s) - (select-result form s s s)) - -(define re:quoted-name (regexp (format "^~a*(\"[^\"]*\")(.*)" blank))) -(define re:parened-name (regexp (format "(.*)[(]([^)]*)[)]~a*$" blank))) -(define re:simple-name (regexp (format "^~a*(~a.*)(<.*>)~a*$" blank nonblank blank))) -(define re:normal-name (regexp (format "~a*<([^>]*)>~a*" blank blank))) -(define re:double-less (regexp "<.*<")) -(define re:double-greater (regexp ">.*>")) -(define re:bad-chars (regexp "[,\"()<>]")) -(define re:tail-blanks (regexp (format "~a+$" blank))) -(define re:head-blanks (regexp (format "^~a+" blank))) - -(define (extract-one-name orig form) - (let loop ([s orig][form form]) - (cond - ;; ?!?!? Where does the "addr (name)" standard come from ?!?!? - [(regexp-match re:parened-name s) - => (lambda (m) - (let ([name (caddr m)] - [all (loop (cadr m) 'all)]) - (select-result - form - (if (string=? (car all) (cadr all)) name (car all)) - (cadr all) - (format "~a (~a)" (caddr all) name))))] - [(regexp-match re:quoted-name s) - => (lambda (m) - (let ([name (cadr m)] - [addr (extract-angle-addr (caddr m) s)]) - (select-result form name addr - (format "~a <~a>" name addr))))] - [(regexp-match re:simple-name s) - => (lambda (m) - (let ([name (regexp-replace (format "~a*$" blank) (cadr m) "")] - [addr (extract-angle-addr (caddr m) s)]) - (select-result form name addr - (format "~a <~a>" name addr))))] - [(or (regexp-match "<" s) (regexp-match ">" s)) - (one-result form (extract-angle-addr s orig))] - [else (one-result form (extract-simple-addr s orig))]))) - -(define (extract-angle-addr s orig) - (if (or (regexp-match re:double-less s) (regexp-match re:double-greater s)) - (error 'extract-address "too many angle brackets: ~a" s) - (let ([m (regexp-match re:normal-name s)]) - (if m - (extract-simple-addr (cadr m) orig) - (error 'extract-address "cannot parse address: ~a" orig))))) - -(define (extract-simple-addr s orig) - (cond [(regexp-match re:bad-chars s) - (error 'extract-address "cannot parse address: ~a" orig)] - [else - ;; final whitespace strip - (regexp-replace re:tail-blanks - (regexp-replace re:head-blanks s "") - "")])) - -(define (assemble-address-field addresses) - (if (null? addresses) - "" - (let loop ([addresses (cdr addresses)] - [s (car addresses)] - [len (string-length (car addresses))]) - (if (null? addresses) - s - (let* ([addr (car addresses)] - [alen (string-length addr)]) - (if (<= 72 (+ len alen)) - (loop (cdr addresses) - (format "~a,~a~a~a~a" - s #\return #\linefeed - #\tab addr) - alen) - (loop (cdr addresses) - (format "~a, ~a" s addr) - (+ len alen 2)))))))) +(provide head@) diff --git a/collects/net/head.rkt b/collects/net/head.rkt index 5cc95b36dd..8365326c82 100644 --- a/collects/net/head.rkt +++ b/collects/net/head.rkt @@ -1,6 +1,355 @@ #lang racket/base -(require racket/unit "head-sig.rkt" "head-unit.rkt") -(define-values/invoke-unit/infer head@) +(require racket/date racket/string) -(provide-signature-elements head^) +(provide empty-header + validate-header + extract-field + remove-field + insert-field + replace-field + extract-all-fields + append-headers + standard-message-header + data-lines->data + extract-addresses + assemble-address-field) + +;; NB: I've done a copied-code adaptation of a number of these definitions +;; into "bytes-compatible" versions. Finishing the rest will require some +;; kind of interface decision---that is, when you don't supply a header, +;; should the resulting operation be string-centric or bytes-centric? +;; Easiest just to stop here. +;; -- JBC 2006-07-31 + +(define CRLF (string #\return #\newline)) +(define CRLF/bytes #"\r\n") + +(define empty-header CRLF) +(define empty-header/bytes CRLF/bytes) + +(define re:field-start (regexp "^[^ \t\n\r\v:\001-\032\"]*:")) +(define re:field-start/bytes #rx#"^[^ \t\n\r\v:\001-\032\"]*:") + +(define re:continue (regexp "^[ \t\v]")) +(define re:continue/bytes #rx#"^[ \t\v]") + +(define (validate-header s) + (if (bytes? s) + ;; legal char check not needed per rfc 2822, IIUC. + (let ([len (bytes-length s)]) + (let loop ([offset 0]) + (cond + [(and (= (+ offset 2) len) + (bytes=? CRLF/bytes (subbytes s offset len))) + (void)] ; validated + [(= offset len) (error 'validate-header "missing ending CRLF")] + [(or (regexp-match re:field-start/bytes s offset) + (regexp-match re:continue/bytes s offset)) + (let ([m (regexp-match-positions #rx#"\r\n" s offset)]) + (if m + (loop (cdar m)) + (error 'validate-header "missing ending CRLF")))] + [else (error 'validate-header "ill-formed header at ~s" + (subbytes s offset (bytes-length s)))]))) + ;; otherwise it should be a string: + (begin + (let ([m (regexp-match #rx"[^\000-\377]" s)]) + (when m + (error 'validate-header "non-Latin-1 character in string: ~v" (car m)))) + (let ([len (string-length s)]) + (let loop ([offset 0]) + (cond + [(and (= (+ offset 2) len) + (string=? CRLF (substring s offset len))) + (void)] ; validated + [(= offset len) (error 'validate-header "missing ending CRLF")] + [(or (regexp-match re:field-start s offset) + (regexp-match re:continue s offset)) + (let ([m (regexp-match-positions #rx"\r\n" s offset)]) + (if m + (loop (cdar m)) + (error 'validate-header "missing ending CRLF")))] + [else (error 'validate-header "ill-formed header at ~s" + (substring s offset (string-length s)))])))))) + +(define (make-field-start-regexp field) + (regexp (format "(^|[\r][\n])(~a: *)" (regexp-quote field #f)))) + +(define (make-field-start-regexp/bytes field) + (byte-regexp (bytes-append #"(^|[\r][\n])("(regexp-quote field #f) #": *)"))) + +(define (extract-field field header) + (if (bytes? header) + (let ([m (regexp-match-positions (make-field-start-regexp/bytes field) + header)]) + (and m + (let ([s (subbytes header + (cdaddr m) + (bytes-length header))]) + (let ([m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)]) + (if m + (subbytes s 0 (caar m)) + ;; Rest of header is this field, but strip trailing CRLFCRLF: + (regexp-replace #rx#"\r\n\r\n$" s "")))))) + ;; otherwise header & field should be strings: + (let ([m (regexp-match-positions (make-field-start-regexp field) + header)]) + (and m + (let ([s (substring header + (cdaddr m) + (string-length header))]) + (let ([m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)]) + (if m + (substring s 0 (caar m)) + ;; Rest of header is this field, but strip trailing CRLFCRLF: + (regexp-replace #rx"\r\n\r\n$" s "")))))))) + +(define (replace-field field data header) + (if (bytes? header) + (let ([m (regexp-match-positions (make-field-start-regexp/bytes field) + header)]) + (if m + (let* ([pre (subbytes header 0 (caaddr m))] + [s (subbytes header (cdaddr m))] + [m (regexp-match-positions #rx#"[\r][\n][^: \r\n\"]*:" s)] + [rest (if m (subbytes s (+ 2 (caar m))) empty-header/bytes)]) + (bytes-append pre (if data (insert-field field data rest) rest))) + (if data (insert-field field data header) header))) + ;; otherwise header & field & data should be strings: + (let ([m (regexp-match-positions (make-field-start-regexp field) header)]) + (if m + (let* ([pre (substring header 0 (caaddr m))] + [s (substring header (cdaddr m))] + [m (regexp-match-positions #rx"[\r][\n][^: \r\n\"]*:" s)] + [rest (if m (substring s (+ 2 (caar m))) empty-header)]) + (string-append pre (if data (insert-field field data rest) rest))) + (if data (insert-field field data header) header))))) + +(define (remove-field field header) + (replace-field field #f header)) + +(define (insert-field field data header) + (if (bytes? header) + (let ([field (bytes-append field #": "data #"\r\n")]) + (bytes-append field header)) + ;; otherwise field, data, & header should be strings: + (let ([field (format "~a: ~a\r\n" field data)]) + (string-append field header)))) + +(define (append-headers a b) + (if (bytes? a) + (let ([alen (bytes-length a)]) + (if (> alen 1) + (bytes-append (subbytes a 0 (- alen 2)) b) + (error 'append-headers "first argument is not a header: ~a" a))) + ;; otherwise, a & b should be strings: + (let ([alen (string-length a)]) + (if (> alen 1) + (string-append (substring a 0 (- alen 2)) b) + (error 'append-headers "first argument is not a header: ~a" a))))) + +(define (extract-all-fields header) + (if (bytes? header) + (let ([re #rx#"(^|[\r][\n])(([^\r\n:\"]*): *)"]) + (let loop ([start 0]) + (let ([m (regexp-match-positions re header start)]) + (if m + (let ([start (cdaddr m)] + [field-name (subbytes header (caaddr (cdr m)) + (cdaddr (cdr m)))]) + (let ([m2 (regexp-match-positions + #rx#"\r\n[^: \r\n\"]*:" + header + start)]) + (if m2 + (cons (cons field-name + (subbytes header start (caar m2))) + (loop (caar m2))) + ;; Rest of header is this field, but strip trailing CRLFCRLF: + (list + (cons field-name + (regexp-replace #rx#"\r\n\r\n$" + (subbytes header start (bytes-length header)) + "")))))) + ;; malformed header: + null)))) + ;; otherwise, header should be a string: + (let ([re #rx"(^|[\r][\n])(([^\r\n:\"]*): *)"]) + (let loop ([start 0]) + (let ([m (regexp-match-positions re header start)]) + (if m + (let ([start (cdaddr m)] + [field-name (substring header (caaddr (cdr m)) (cdaddr (cdr m)))]) + (let ([m2 (regexp-match-positions + #rx"\r\n[^: \r\n\"]*:" header start)]) + (if m2 + (cons (cons field-name + (substring header start (caar m2))) + (loop (caar m2))) + ;; Rest of header is this field, but strip trailing CRLFCRLF: + (list + (cons field-name + (regexp-replace #rx"\r\n\r\n$" + (substring header start (string-length header)) + "")))))) + ;; malformed header: + null)))))) + +;; It's slightly less obvious how to generalize the functions that don't +;; accept a header as input; for lack of an obvious solution (and free time), +;; I'm stopping the string->bytes translation here. -- JBC, 2006-07-31 + +(define (standard-message-header from tos ccs bccs subject) + (let ([h (insert-field + "Subject" subject + (insert-field + "Date" (parameterize ([date-display-format 'rfc2822]) + (date->string (seconds->date (current-seconds)) #t)) + CRLF))]) + ;; NOTE: bccs don't go into the header; that's why they're "blind" + (let ([h (if (null? ccs) + h + (insert-field "CC" (assemble-address-field ccs) h))]) + (let ([h (if (null? tos) + h + (insert-field "To" (assemble-address-field tos) h))]) + (insert-field "From" from h))))) + +(define (splice l sep) + (if (null? l) + "" + (format "~a~a" + (car l) + (apply string-append + (map (lambda (n) (format "~a~a" sep n)) + (cdr l)))))) + +(define (data-lines->data datas) + (splice datas "\r\n\t")) + +;; Extracting Addresses ;; + +(define blank "[ \t\n\r\v]") +(define nonblank "[^ \t\n\r\v]") +(define re:all-blank (regexp (format "^~a*$" blank))) +(define re:quoted (regexp "\"[^\"]*\"")) +(define re:parened (regexp "[(][^)]*[)]")) +(define re:comma (regexp ",")) +(define re:comma-separated (regexp "([^,]*),(.*)")) + +(define (extract-addresses s form) + (unless (memq form '(name address full all)) + (raise-type-error 'extract-addresses + "form: 'name, 'address, 'full, or 'all" + form)) + (if (or (not s) (regexp-match re:all-blank s)) + null + (let loop ([prefix ""][s s]) + ;; Which comes first - a quote or a comma? + (let* ([mq1 (regexp-match-positions re:quoted s)] + [mq2 (regexp-match-positions re:parened s)] + [mq (if (and mq1 mq2) + (if (< (caar mq1) (caar mq2)) mq1 mq2) + (or mq1 mq2))] + [mc (regexp-match-positions re:comma s)]) + (if (and mq mc (< (caar mq) (caar mc) (cdar mq))) + ;; Quote contains a comma + (loop (string-append + prefix + (substring s 0 (cdar mq))) + (substring s (cdar mq) (string-length s))) + ;; Normal comma parsing: + (let ([m (regexp-match re:comma-separated s)]) + (if m + (let ([n (extract-one-name (string-append prefix (cadr m)) form)] + [rest (extract-addresses (caddr m) form)]) + (cons n rest)) + (let ([n (extract-one-name (string-append prefix s) form)]) + (list n))))))))) + +(define (select-result form name addr full) + (case form + [(name) name] + [(address) addr] + [(full) full] + [(all) (list name addr full)])) + +(define (one-result form s) + (select-result form s s s)) + +(define re:quoted-name (regexp (format "^~a*(\"[^\"]*\")(.*)" blank))) +(define re:parened-name (regexp (format "(.*)[(]([^)]*)[)]~a*$" blank))) +(define re:simple-name (regexp (format "^~a*(~a.*)(<.*>)~a*$" blank nonblank blank))) +(define re:normal-name (regexp (format "~a*<([^>]*)>~a*" blank blank))) +(define re:double-less (regexp "<.*<")) +(define re:double-greater (regexp ">.*>")) +(define re:bad-chars (regexp "[,\"()<>]")) +(define re:tail-blanks (regexp (format "~a+$" blank))) +(define re:head-blanks (regexp (format "^~a+" blank))) + +(define (extract-one-name orig form) + (let loop ([s orig][form form]) + (cond + ;; ?!?!? Where does the "addr (name)" standard come from ?!?!? + [(regexp-match re:parened-name s) + => (lambda (m) + (let ([name (caddr m)] + [all (loop (cadr m) 'all)]) + (select-result + form + (if (string=? (car all) (cadr all)) name (car all)) + (cadr all) + (format "~a (~a)" (caddr all) name))))] + [(regexp-match re:quoted-name s) + => (lambda (m) + (let ([name (cadr m)] + [addr (extract-angle-addr (caddr m) s)]) + (select-result form name addr + (format "~a <~a>" name addr))))] + [(regexp-match re:simple-name s) + => (lambda (m) + (let ([name (regexp-replace (format "~a*$" blank) (cadr m) "")] + [addr (extract-angle-addr (caddr m) s)]) + (select-result form name addr + (format "~a <~a>" name addr))))] + [(or (regexp-match "<" s) (regexp-match ">" s)) + (one-result form (extract-angle-addr s orig))] + [else (one-result form (extract-simple-addr s orig))]))) + +(define (extract-angle-addr s orig) + (if (or (regexp-match re:double-less s) (regexp-match re:double-greater s)) + (error 'extract-address "too many angle brackets: ~a" s) + (let ([m (regexp-match re:normal-name s)]) + (if m + (extract-simple-addr (cadr m) orig) + (error 'extract-address "cannot parse address: ~a" orig))))) + +(define (extract-simple-addr s orig) + (cond [(regexp-match re:bad-chars s) + (error 'extract-address "cannot parse address: ~a" orig)] + [else + ;; final whitespace strip + (regexp-replace re:tail-blanks + (regexp-replace re:head-blanks s "") + "")])) + +(define (assemble-address-field addresses) + (if (null? addresses) + "" + (let loop ([addresses (cdr addresses)] + [s (car addresses)] + [len (string-length (car addresses))]) + (if (null? addresses) + s + (let* ([addr (car addresses)] + [alen (string-length addr)]) + (if (<= 72 (+ len alen)) + (loop (cdr addresses) + (format "~a,~a~a~a~a" + s #\return #\linefeed + #\tab addr) + alen) + (loop (cdr addresses) + (format "~a, ~a" s addr) + (+ len alen 2)))))))) diff --git a/collects/net/scribblings/head.scrbl b/collects/net/scribblings/head.scrbl index d93cba84f0..440612e680 100644 --- a/collects/net/scribblings/head.scrbl +++ b/collects/net/scribblings/head.scrbl @@ -222,6 +222,10 @@ are comma-separated, and possibly broken into multiple lines. @section{Header Unit} +@margin-note{@racket[head@] and @racket[head^] are deprecated. +They exist for backward-compatibility and will likely be removed in +the future. New code should use the @racketmodname[net/head] module.} + @defmodule[net/head-unit] @defthing[head@ unit?]{ From 9ae38402112eb4808abedd6df6350e9d8e97dbad Mon Sep 17 00:00:00 2001 From: Jon Zeppieri Date: Mon, 29 Aug 2011 21:31:37 -0400 Subject: [PATCH 150/235] Moved `net/imap' code from unit to module. --- collects/net/imap-unit.rkt | 556 +--------------------------- collects/net/imap.rkt | 552 ++++++++++++++++++++++++++- collects/net/scribblings/imap.scrbl | 4 + 3 files changed, 559 insertions(+), 553 deletions(-) diff --git a/collects/net/imap-unit.rkt b/collects/net/imap-unit.rkt index b9a7b83d84..4b28b4f2cd 100644 --- a/collects/net/imap-unit.rkt +++ b/collects/net/imap-unit.rkt @@ -1,554 +1,8 @@ -#lang racket/unit +#lang racket/base -(require racket/tcp "imap-sig.rkt" "private/rbtree.rkt") +(require racket/unit + "imap-sig.rkt" "imap.rkt") -(import) -(export imap^) +(define-unit-from-context imap@ imap^) -(define debug-via-stdio? #f) - -(define eol (if debug-via-stdio? 'linefeed 'return-linefeed)) - -(define (tag-eq? a b) - (or (eq? a b) - (and (symbol? a) - (symbol? b) - (string-ci=? (symbol->string a) (symbol->string b))))) - -(define field-names - (list (list 'uid (string->symbol "UID")) - (list 'header (string->symbol "RFC822.HEADER")) - (list 'body (string->symbol "RFC822.TEXT")) - (list 'size (string->symbol "RFC822.SIZE")) - (list 'flags (string->symbol "FLAGS")))) - -(define flag-names - (list (list 'seen (string->symbol "\\Seen")) - (list 'answered (string->symbol "\\Answered")) - (list 'flagged (string->symbol "\\Flagged")) - (list 'deleted (string->symbol "\\Deleted")) - (list 'draft (string->symbol "\\Draft")) - (list 'recent (string->symbol "\\Recent")) - - (list 'noinferiors (string->symbol "\\Noinferiors")) - (list 'noselect (string->symbol "\\Noselect")) - (list 'marked (string->symbol "\\Marked")) - (list 'unmarked (string->symbol "\\Unmarked")) - - (list 'hasnochildren (string->symbol "\\HasNoChildren")) - (list 'haschildren (string->symbol "\\HasChildren")))) - -(define (imap-flag->symbol f) - (or (ormap (lambda (a) (and (tag-eq? f (cadr a)) (car a))) flag-names) - f)) - -(define (symbol->imap-flag s) - (cond [(assoc s flag-names) => cadr] [else s])) - -(define (log-warning . args) - ;; (apply printf args) - (void)) -(define log log-warning) - -(define make-msg-id - (let ([id 0]) - (lambda () - (begin0 (string->bytes/latin-1 (format "a~a " id)) - (set! id (add1 id)))))) - -(define (starts-with? l n) - (and (>= (bytes-length l) (bytes-length n)) - (bytes=? n (subbytes l 0 (bytes-length n))))) - -(define (skip s n) - (subbytes s (if (number? n) n (bytes-length n)))) - -(define (splice l sep) - (if (null? l) - "" - (format "~a~a" - (car l) - (apply string-append - (map (lambda (n) (format "~a~a" sep n)) (cdr l)))))) - -(define (imap-read s r) - (let loop ([s s] - [r r] - [accum null] - [eol-k (lambda (accum) (reverse accum))] - [eop-k (lambda (s accum) (error 'imap-read "unxpected close parenthesis"))]) - (cond - [(bytes=? #"" s) - (eol-k accum)] - [(char-whitespace? (integer->char (bytes-ref s 0))) - (loop (skip s 1) r accum eol-k eop-k)] - [else - (case (integer->char (bytes-ref s 0)) - [(#\") - (let ([m (regexp-match #rx#"\"([^\"]*)\"(.*)" s)]) - (if m - (loop (caddr m) r (cons (cadr m) accum) eol-k eop-k) - (error 'imap-read "didn't find end of quoted string in: ~a" s)))] - [(#\)) - (eop-k (skip s 1) accum)] - [(#\() (letrec ([next-line - (lambda (accum) - (loop (read-bytes-line r eol) r - accum - next-line - finish-parens))] - [finish-parens - (lambda (s laccum) - (loop s r - (cons (reverse laccum) accum) - eol-k eop-k))]) - (loop (skip s 1) r null next-line finish-parens))] - [(#\{) (let ([m (regexp-match #rx#"{([0-9]+)}(.*)" s)]) - (cond - [(not m) (error 'imap-read "couldn't read {} number: ~a" s)] - [(not (bytes=? (caddr m) #"")) (error 'imap-read "{} not at end-of-line: ~a" s)] - [else - (loop #"" r - (cons (read-bytes (string->number - (bytes->string/latin-1 (cadr m))) - r) - accum) - eol-k eop-k)]))] - [else (let ([m (regexp-match #rx#"([^ (){}]+)(.*)" s)]) - (if m - (loop (caddr m) r - (cons (let ([v (cadr m)]) - (if (regexp-match #rx#"^[0-9]*$" v) - (string->number (bytes->string/latin-1 v)) - (string->symbol (bytes->string/latin-1 v)))) - accum) - eol-k eop-k) - (error 'imap-read "failure reading atom: ~a" s)))])]))) - -(define (get-response r id info-handler continuation-handler) - (let loop () - (let ([l (read-bytes-line r eol)]) - (log "raw-reply: ~s\n" l) - (cond [(eof-object? l) - (error 'imap-send "unexpected end-of-file from server")] - [(and id (starts-with? l id)) - (let ([reply (imap-read (skip l id) r)]) - (log "response: ~a\n" reply) - reply)] - [(starts-with? l #"* ") - (let ([info (imap-read (skip l 2) r)]) - (log "info: ~s\n" info) - (info-handler info)) - (when id (loop))] - [(starts-with? l #"+ ") - (if (null? continuation-handler) - (error 'imap-send "unexpected continuation request: ~a" l) - ((car continuation-handler) loop (imap-read (skip l 2) r)))] - [else - (log-warning "warning: unexpected response for ~a: ~a\n" id l) - (when id (loop))])))) - -;; A cmd is -;; * (box v) - send v literally via ~a -;; * string or bytes - protect as necessary -;; * (cons cmd null) - same as cmd -;; * (cons cmd cmd) - send cmd, space, cmd - -(define (imap-send imap cmd info-handler . continuation-handler) - (let ([r (imap-r imap)] - [w (imap-w imap)] - [id (make-msg-id)]) - (log "sending ~a~a\n" id cmd) - (fprintf w "~a" id) - (let loop ([cmd cmd]) - (cond - [(box? cmd) (fprintf w "~a" (unbox cmd))] - [(string? cmd) (loop (string->bytes/utf-8 cmd))] - [(bytes? cmd) - (if (or (regexp-match #rx#"[ *\"\r\n]" cmd) - (equal? cmd #"")) - (if (regexp-match #rx#"[\"\r\n]" cmd) - (begin - ;; Have to send size, then continue if the - ;; server consents - (fprintf w "{~a}\r\n" (bytes-length cmd)) - (flush-output w) - (get-response r #f void (list (lambda (gloop data) (void)))) - ;; Continue by writing the data - (write-bytes cmd w)) - (fprintf w "\"~a\"" cmd)) - (fprintf w "~a" cmd))] - [(and (pair? cmd) (null? (cdr cmd))) (loop (car cmd))] - [(pair? cmd) (begin (loop (car cmd)) - (fprintf w " ") - (loop (cdr cmd)))])) - (fprintf w "\r\n") - (flush-output w) - (get-response r id (wrap-info-handler imap info-handler) - continuation-handler))) - -(define (check-ok reply) - (unless (and (pair? reply) (tag-eq? (car reply) 'OK)) - (error 'check-ok "server error: ~s" reply))) - -(define (ok-tag-eq? i t) - (and (tag-eq? (car i) 'OK) - ((length i) . >= . 3) - (tag-eq? (cadr i) (string->symbol (format "[~a" t))))) - -(define (ok-tag-val i) - (let ([v (caddr i)]) - (and (symbol? v) - (let ([v (symbol->string v)]) - (regexp-match #rx"[]]$" v) - (string->number (substring v 0 (sub1 (string-length v)))))))) - -(define (wrap-info-handler imap info-handler) - (lambda (i) - (when (and (list? i) ((length i) . >= . 2)) - (cond - [(tag-eq? (cadr i) 'EXISTS) - (when (> (car i) (or (imap-exists imap) 0)) - (set-imap-new?! imap #t)) - (set-imap-exists! imap (car i))] - [(tag-eq? (cadr i) 'RECENT) - (set-imap-recent! imap (car i))] - [(tag-eq? (cadr i) 'EXPUNGE) - (let ([n (car i)]) - (log "Recording expunge: ~s\n" n) - ;; add it to the tree of expunges - (expunge-insert! (imap-expunges imap) n) - ;; decrement exists count: - (set-imap-exists! imap (sub1 (imap-exists imap))) - ;; adjust ids for any remembered fetches: - (fetch-shift! (imap-fetches imap) n))] - [(tag-eq? (cadr i) 'FETCH) - (fetch-insert! - (imap-fetches imap) - ;; Convert result to assoc list: - (cons (car i) - (let ([new - (let loop ([l (caddr i)]) - (if (null? l) - null - (cons (cons (car l) (cadr l)) - (loop (cddr l)))))]) - ;; Keep anything not overridden: - (let ([old (cdr (or (fetch-find (imap-fetches imap) (car i)) - '(0)))]) - (let loop ([old old][new new]) - (cond - [(null? old) new] - [(assq (caar old) new) - (loop (cdr old) new)] - [else (loop (cdr old) (cons (car old) new))]))))))] - [(ok-tag-eq? i 'UIDNEXT) - (set-imap-uidnext! imap (ok-tag-val i))] - [(ok-tag-eq? i 'UIDVALIDITY) - (set-imap-uidvalidity! imap (ok-tag-val i))] - [(ok-tag-eq? i 'UNSEEN) - (set-imap-uidvalidity! imap (ok-tag-val i))])) - (info-handler i))) - -(define-struct imap (r w exists recent unseen uidnext uidvalidity - expunges fetches new?) - #:mutable) -(define (imap-connection? v) (imap? v)) - -(define imap-port-number - (make-parameter 143 - (lambda (v) - (unless (and (number? v) - (exact? v) - (integer? v) - (<= 1 v 65535)) - (raise-type-error 'imap-port-number - "exact integer in [1,65535]" - v)) - v))) - -(define (imap-connect* r w username password inbox) - (with-handlers ([void - (lambda (x) - (close-input-port r) - (close-output-port w) - (raise x))]) - - (let ([imap (make-imap r w #f #f #f #f #f - (new-tree) (new-tree) #f)]) - (check-ok (imap-send imap "NOOP" void)) - (let ([reply (imap-send imap (list "LOGIN" username password) void)]) - (if (and (pair? reply) (tag-eq? 'NO (car reply))) - (error 'imap-connect - "username or password rejected by server: ~s" reply) - (check-ok reply))) - (let-values ([(init-count init-recent) (imap-reselect imap inbox)]) - (values imap init-count init-recent))))) - -(define (imap-connect server username password inbox) - ;; => imap count-k recent-k - (let-values ([(r w) - (if debug-via-stdio? - (begin - (printf "stdin == ~a\n" server) - (values (current-input-port) (current-output-port))) - (tcp-connect server (imap-port-number)))]) - (imap-connect* r w username password inbox))) - -(define (imap-reselect imap inbox) - (imap-selectish-command imap (list "SELECT" inbox) #t)) - -(define (imap-examine imap inbox) - (imap-selectish-command imap (list "EXAMINE" inbox) #t)) - -;; Used to return (values #f #f) if no change since last check? -(define (imap-noop imap) - (imap-selectish-command imap "NOOP" #f)) - -(define (imap-selectish-command imap cmd reset?) - (let ([init-count #f] - [init-recent #f]) - (check-ok (imap-send imap cmd void)) - (when reset? - (set-imap-expunges! imap (new-tree)) - (set-imap-fetches! imap (new-tree)) - (set-imap-new?! imap #f)) - (values (imap-exists imap) (imap-recent imap)))) - -(define (imap-status imap inbox flags) - (unless (and (list? flags) - (andmap (lambda (s) - (memq s '(messages recent uidnext uidvalidity unseen))) - flags)) - (raise-type-error 'imap-status "list of status flag symbols" flags)) - (let ([results null]) - (check-ok (imap-send imap (list "STATUS" inbox (box (format "~a" flags))) - (lambda (i) - (when (and (list? i) (= 3 (length i)) - (tag-eq? (car i) 'STATUS)) - (set! results (caddr i)))))) - (map (lambda (f) - (let loop ([l results]) - (cond - [(or (null? l) (null? (cdr l))) #f] - [(tag-eq? f (car l)) (cadr l)] - [else (loop (cdr l))]))) - flags))) - -(define (imap-poll imap) - (when (and ;; Check for async messages from the server - (char-ready? (imap-r imap)) - ;; It has better start with "*"... - (= (peek-byte (imap-r imap)) (char->integer #\*))) - ;; May set fields in `imap': - (get-response (imap-r imap) #f (wrap-info-handler imap void) null) - (void))) - -(define (imap-get-updates imap) - (no-expunges 'imap-updates imap) - (let ([l (fetch-tree->list (imap-fetches imap))]) - (set-imap-fetches! imap (new-tree)) - l)) - -(define (imap-pending-updates? imap) - (not (tree-empty? (imap-fetches imap)))) - -(define (imap-get-expunges imap) - (let ([l (expunge-tree->list (imap-expunges imap))]) - (set-imap-expunges! imap (new-tree)) - l)) - -(define (imap-pending-expunges? imap) - (not (tree-empty? (imap-expunges imap)))) - -(define (imap-reset-new! imap) - (set-imap-new?! imap #f)) - -(define (imap-messages imap) - (imap-exists imap)) - -(define (imap-disconnect imap) - (let ([r (imap-r imap)] - [w (imap-w imap)]) - (check-ok (imap-send imap "LOGOUT" void)) - (close-input-port r) - (close-output-port w))) - -(define (imap-force-disconnect imap) - (let ([r (imap-r imap)] - [w (imap-w imap)]) - (close-input-port r) - (close-output-port w))) - -(define (no-expunges who imap) - (unless (tree-empty? (imap-expunges imap)) - (raise-mismatch-error who "session has pending expunge reports: " imap))) - -(define (msg-set msgs) - (apply - string-append - (let loop ([prev #f][msgs msgs]) - (cond - [(null? msgs) null] - [(and prev - (pair? (cdr msgs)) - (= (add1 prev) (car msgs))) - (loop (car msgs) (cdr msgs))] - [prev (cons (format ":~a," prev) - (loop #f msgs))] - [(null? (cdr msgs)) (list (format "~a" (car msgs)))] - [(= (add1 (car msgs)) (cadr msgs)) - (cons (format "~a" (car msgs)) - (loop (car msgs) (cdr msgs)))] - [else (cons (format "~a," (car msgs)) - (loop #f (cdr msgs)))])))) - -(define (imap-get-messages imap msgs field-list) - (no-expunges 'imap-get-messages imap) - (when (or (not (list? msgs)) - (not (andmap integer? msgs))) - (raise-type-error 'imap-get-messages "non-empty message list" msgs)) - (when (or (null? field-list) - (not (list? field-list)) - (not (andmap (lambda (f) (assoc f field-names)) field-list))) - (raise-type-error 'imap-get-messages "non-empty field list" field-list)) - - (if (null? msgs) - null - (begin - ;; FETCH request adds info to `(imap-fectches imap)': - (imap-send imap - (list "FETCH" - (box (msg-set msgs)) - (box - (format "(~a)" - (splice (map (lambda (f) - (cadr (assoc f field-names))) - field-list) - " ")))) - void) - ;; Sort out the collected info: - (let ([flds (map (lambda (f) (cadr (assoc f field-names))) - field-list)]) - (begin0 - ;; For each msg, try to get each field value: - (map - (lambda (msg) - (let ([m (or (fetch-find (imap-fetches imap) msg) - (error 'imap-get-messages "no result for message ~a" msg))]) - (let loop ([flds flds][m (cdr m)]) - (cond - [(null? flds) - (if (null? m) - (fetch-delete! (imap-fetches imap) msg) - (fetch-insert! (imap-fetches imap) (cons msg m))) - null] - [else - (let ([a (assoc (car flds) m)]) - (cons (and a (cdr a)) - (loop (cdr flds) (if a (remq a m) m))))])))) - msgs)))))) - -(define (imap-store imap mode msgs flags) - (no-expunges 'imap-store imap) - (check-ok - (imap-send imap - (list "STORE" - (box (msg-set msgs)) - (case mode - [(+) "+FLAGS.SILENT"] - [(-) "-FLAGS.SILENT"] - [(!) "FLAGS.SILENT"] - [else (raise-type-error 'imap-store - "mode: '!, '+, or '-" mode)]) - (box (format "~a" flags))) - void))) - -(define (imap-copy imap msgs dest-mailbox) - (no-expunges 'imap-copy imap) - (check-ok - (imap-send imap (list "COPY" (box (msg-set msgs)) dest-mailbox) void))) - -(define (imap-append imap dest-mailbox msg) - (no-expunges 'imap-append imap) - (let ([msg (if (bytes? msg) msg (string->bytes/utf-8 msg))]) - (check-ok - (imap-send imap (list "APPEND" - dest-mailbox - (box "(\\Seen)") - (box (format "{~a}" (bytes-length msg)))) - void - (lambda (loop contin) - (fprintf (imap-w imap) "~a\r\n" msg) - (loop)))))) - -(define (imap-expunge imap) - (check-ok (imap-send imap "EXPUNGE" void))) - -(define (imap-mailbox-exists? imap mailbox) - (let ([exists? #f]) - (check-ok (imap-send imap - (list "LIST" "" mailbox) - (lambda (i) - (when (and (pair? i) (tag-eq? (car i) 'LIST)) - (set! exists? #t))))) - exists?)) - -(define (imap-create-mailbox imap mailbox) - (check-ok (imap-send imap (list "CREATE" mailbox) void))) - -(define (imap-get-hierarchy-delimiter imap) - (let ([result #f]) - (check-ok - (imap-send imap (list "LIST" "" "") - (lambda (i) - (when (and (pair? i) (tag-eq? (car i) 'LIST)) - (set! result (caddr i)))))) - result)) - -(define imap-list-child-mailboxes - (case-lambda - [(imap mailbox) - (imap-list-child-mailboxes imap mailbox #f)] - [(imap mailbox raw-delimiter) - (let* ([delimiter (or raw-delimiter (imap-get-hierarchy-delimiter imap))] - [mailbox-name (and mailbox (bytes-append mailbox delimiter))] - [pattern (if mailbox - (bytes-append mailbox-name #"%") - #"%")]) - (map (lambda (p) - (list (car p) - (cond - [(symbol? (cadr p)) - (string->bytes/utf-8 (symbol->string (cadr p)))] - [(string? (cadr p)) - (string->bytes/utf-8 (symbol->string (cadr p)))] - [(bytes? (cadr p)) - (cadr p)]))) - (imap-list-mailboxes imap pattern mailbox-name)))])) - -(define (imap-mailbox-flags imap mailbox) - (let ([r (imap-list-mailboxes imap mailbox #f)]) - (if (= (length r) 1) - (caar r) - (error 'imap-mailbox-flags "could not get flags for ~s (~a)" - mailbox - (if (null? r) "no matches" "multiple matches"))))) - -(define (imap-list-mailboxes imap pattern except) - (let* ([sub-folders null]) - (check-ok - (imap-send imap (list "LIST" "" pattern) - (lambda (x) - (when (and (pair? x) - (tag-eq? (car x) 'LIST)) - (let* ([flags (cadr x)] - [name (cadddr x)] - [bytes-name (if (symbol? name) - (string->bytes/utf-8 (symbol->string name)) - name)]) - (unless (and except - (bytes=? bytes-name except)) - (set! sub-folders - (cons (list flags name) sub-folders)))))))) - (reverse sub-folders))) +(provide imap@) diff --git a/collects/net/imap.rkt b/collects/net/imap.rkt index 6c02a92485..37e8b00be7 100644 --- a/collects/net/imap.rkt +++ b/collects/net/imap.rkt @@ -1,7 +1,12 @@ #lang racket/base -(require racket/unit racket/contract "imap-sig.rkt" "imap-unit.rkt") -(define-values/invoke-unit/infer imap@) +(require racket/contract/base racket/tcp "private/rbtree.rkt") + +;; define the imap struct and its predicate here, for use in the contract, below +(define-struct imap (r w exists recent unseen uidnext uidvalidity + expunges fetches new?) + #:mutable) +(define (imap-connection? v) (imap? v)) (provide/contract [imap-get-hierarchy-delimiter (imap-connection? . -> . bytes?)] @@ -48,3 +53,546 @@ imap-create-mailbox imap-mailbox-flags) + +(define debug-via-stdio? #f) + +(define eol (if debug-via-stdio? 'linefeed 'return-linefeed)) + +(define (tag-eq? a b) + (or (eq? a b) + (and (symbol? a) + (symbol? b) + (string-ci=? (symbol->string a) (symbol->string b))))) + +(define field-names + (list (list 'uid (string->symbol "UID")) + (list 'header (string->symbol "RFC822.HEADER")) + (list 'body (string->symbol "RFC822.TEXT")) + (list 'size (string->symbol "RFC822.SIZE")) + (list 'flags (string->symbol "FLAGS")))) + +(define flag-names + (list (list 'seen (string->symbol "\\Seen")) + (list 'answered (string->symbol "\\Answered")) + (list 'flagged (string->symbol "\\Flagged")) + (list 'deleted (string->symbol "\\Deleted")) + (list 'draft (string->symbol "\\Draft")) + (list 'recent (string->symbol "\\Recent")) + + (list 'noinferiors (string->symbol "\\Noinferiors")) + (list 'noselect (string->symbol "\\Noselect")) + (list 'marked (string->symbol "\\Marked")) + (list 'unmarked (string->symbol "\\Unmarked")) + + (list 'hasnochildren (string->symbol "\\HasNoChildren")) + (list 'haschildren (string->symbol "\\HasChildren")))) + +(define (imap-flag->symbol f) + (or (ormap (lambda (a) (and (tag-eq? f (cadr a)) (car a))) flag-names) + f)) + +(define (symbol->imap-flag s) + (cond [(assoc s flag-names) => cadr] [else s])) + +(define (log-warning . args) + ;; (apply printf args) + (void)) +(define log log-warning) + +(define make-msg-id + (let ([id 0]) + (lambda () + (begin0 (string->bytes/latin-1 (format "a~a " id)) + (set! id (add1 id)))))) + +(define (starts-with? l n) + (and (>= (bytes-length l) (bytes-length n)) + (bytes=? n (subbytes l 0 (bytes-length n))))) + +(define (skip s n) + (subbytes s (if (number? n) n (bytes-length n)))) + +(define (splice l sep) + (if (null? l) + "" + (format "~a~a" + (car l) + (apply string-append + (map (lambda (n) (format "~a~a" sep n)) (cdr l)))))) + +(define (imap-read s r) + (let loop ([s s] + [r r] + [accum null] + [eol-k (lambda (accum) (reverse accum))] + [eop-k (lambda (s accum) (error 'imap-read "unxpected close parenthesis"))]) + (cond + [(bytes=? #"" s) + (eol-k accum)] + [(char-whitespace? (integer->char (bytes-ref s 0))) + (loop (skip s 1) r accum eol-k eop-k)] + [else + (case (integer->char (bytes-ref s 0)) + [(#\") + (let ([m (regexp-match #rx#"\"([^\"]*)\"(.*)" s)]) + (if m + (loop (caddr m) r (cons (cadr m) accum) eol-k eop-k) + (error 'imap-read "didn't find end of quoted string in: ~a" s)))] + [(#\)) + (eop-k (skip s 1) accum)] + [(#\() (letrec ([next-line + (lambda (accum) + (loop (read-bytes-line r eol) r + accum + next-line + finish-parens))] + [finish-parens + (lambda (s laccum) + (loop s r + (cons (reverse laccum) accum) + eol-k eop-k))]) + (loop (skip s 1) r null next-line finish-parens))] + [(#\{) (let ([m (regexp-match #rx#"{([0-9]+)}(.*)" s)]) + (cond + [(not m) (error 'imap-read "couldn't read {} number: ~a" s)] + [(not (bytes=? (caddr m) #"")) (error 'imap-read "{} not at end-of-line: ~a" s)] + [else + (loop #"" r + (cons (read-bytes (string->number + (bytes->string/latin-1 (cadr m))) + r) + accum) + eol-k eop-k)]))] + [else (let ([m (regexp-match #rx#"([^ (){}]+)(.*)" s)]) + (if m + (loop (caddr m) r + (cons (let ([v (cadr m)]) + (if (regexp-match #rx#"^[0-9]*$" v) + (string->number (bytes->string/latin-1 v)) + (string->symbol (bytes->string/latin-1 v)))) + accum) + eol-k eop-k) + (error 'imap-read "failure reading atom: ~a" s)))])]))) + +(define (get-response r id info-handler continuation-handler) + (let loop () + (let ([l (read-bytes-line r eol)]) + (log "raw-reply: ~s\n" l) + (cond [(eof-object? l) + (error 'imap-send "unexpected end-of-file from server")] + [(and id (starts-with? l id)) + (let ([reply (imap-read (skip l id) r)]) + (log "response: ~a\n" reply) + reply)] + [(starts-with? l #"* ") + (let ([info (imap-read (skip l 2) r)]) + (log "info: ~s\n" info) + (info-handler info)) + (when id (loop))] + [(starts-with? l #"+ ") + (if (null? continuation-handler) + (error 'imap-send "unexpected continuation request: ~a" l) + ((car continuation-handler) loop (imap-read (skip l 2) r)))] + [else + (log-warning "warning: unexpected response for ~a: ~a\n" id l) + (when id (loop))])))) + +;; A cmd is +;; * (box v) - send v literally via ~a +;; * string or bytes - protect as necessary +;; * (cons cmd null) - same as cmd +;; * (cons cmd cmd) - send cmd, space, cmd + +(define (imap-send imap cmd info-handler . continuation-handler) + (let ([r (imap-r imap)] + [w (imap-w imap)] + [id (make-msg-id)]) + (log "sending ~a~a\n" id cmd) + (fprintf w "~a" id) + (let loop ([cmd cmd]) + (cond + [(box? cmd) (fprintf w "~a" (unbox cmd))] + [(string? cmd) (loop (string->bytes/utf-8 cmd))] + [(bytes? cmd) + (if (or (regexp-match #rx#"[ *\"\r\n]" cmd) + (equal? cmd #"")) + (if (regexp-match #rx#"[\"\r\n]" cmd) + (begin + ;; Have to send size, then continue if the + ;; server consents + (fprintf w "{~a}\r\n" (bytes-length cmd)) + (flush-output w) + (get-response r #f void (list (lambda (gloop data) (void)))) + ;; Continue by writing the data + (write-bytes cmd w)) + (fprintf w "\"~a\"" cmd)) + (fprintf w "~a" cmd))] + [(and (pair? cmd) (null? (cdr cmd))) (loop (car cmd))] + [(pair? cmd) (begin (loop (car cmd)) + (fprintf w " ") + (loop (cdr cmd)))])) + (fprintf w "\r\n") + (flush-output w) + (get-response r id (wrap-info-handler imap info-handler) + continuation-handler))) + +(define (check-ok reply) + (unless (and (pair? reply) (tag-eq? (car reply) 'OK)) + (error 'check-ok "server error: ~s" reply))) + +(define (ok-tag-eq? i t) + (and (tag-eq? (car i) 'OK) + ((length i) . >= . 3) + (tag-eq? (cadr i) (string->symbol (format "[~a" t))))) + +(define (ok-tag-val i) + (let ([v (caddr i)]) + (and (symbol? v) + (let ([v (symbol->string v)]) + (regexp-match #rx"[]]$" v) + (string->number (substring v 0 (sub1 (string-length v)))))))) + +(define (wrap-info-handler imap info-handler) + (lambda (i) + (when (and (list? i) ((length i) . >= . 2)) + (cond + [(tag-eq? (cadr i) 'EXISTS) + (when (> (car i) (or (imap-exists imap) 0)) + (set-imap-new?! imap #t)) + (set-imap-exists! imap (car i))] + [(tag-eq? (cadr i) 'RECENT) + (set-imap-recent! imap (car i))] + [(tag-eq? (cadr i) 'EXPUNGE) + (let ([n (car i)]) + (log "Recording expunge: ~s\n" n) + ;; add it to the tree of expunges + (expunge-insert! (imap-expunges imap) n) + ;; decrement exists count: + (set-imap-exists! imap (sub1 (imap-exists imap))) + ;; adjust ids for any remembered fetches: + (fetch-shift! (imap-fetches imap) n))] + [(tag-eq? (cadr i) 'FETCH) + (fetch-insert! + (imap-fetches imap) + ;; Convert result to assoc list: + (cons (car i) + (let ([new + (let loop ([l (caddr i)]) + (if (null? l) + null + (cons (cons (car l) (cadr l)) + (loop (cddr l)))))]) + ;; Keep anything not overridden: + (let ([old (cdr (or (fetch-find (imap-fetches imap) (car i)) + '(0)))]) + (let loop ([old old][new new]) + (cond + [(null? old) new] + [(assq (caar old) new) + (loop (cdr old) new)] + [else (loop (cdr old) (cons (car old) new))]))))))] + [(ok-tag-eq? i 'UIDNEXT) + (set-imap-uidnext! imap (ok-tag-val i))] + [(ok-tag-eq? i 'UIDVALIDITY) + (set-imap-uidvalidity! imap (ok-tag-val i))] + [(ok-tag-eq? i 'UNSEEN) + (set-imap-uidvalidity! imap (ok-tag-val i))])) + (info-handler i))) + +(define imap-port-number + (make-parameter 143 + (lambda (v) + (unless (and (number? v) + (exact? v) + (integer? v) + (<= 1 v 65535)) + (raise-type-error 'imap-port-number + "exact integer in [1,65535]" + v)) + v))) + +(define (imap-connect* r w username password inbox) + (with-handlers ([void + (lambda (x) + (close-input-port r) + (close-output-port w) + (raise x))]) + + (let ([imap (make-imap r w #f #f #f #f #f + (new-tree) (new-tree) #f)]) + (check-ok (imap-send imap "NOOP" void)) + (let ([reply (imap-send imap (list "LOGIN" username password) void)]) + (if (and (pair? reply) (tag-eq? 'NO (car reply))) + (error 'imap-connect + "username or password rejected by server: ~s" reply) + (check-ok reply))) + (let-values ([(init-count init-recent) (imap-reselect imap inbox)]) + (values imap init-count init-recent))))) + +(define (imap-connect server username password inbox) + ;; => imap count-k recent-k + (let-values ([(r w) + (if debug-via-stdio? + (begin + (printf "stdin == ~a\n" server) + (values (current-input-port) (current-output-port))) + (tcp-connect server (imap-port-number)))]) + (imap-connect* r w username password inbox))) + +(define (imap-reselect imap inbox) + (imap-selectish-command imap (list "SELECT" inbox) #t)) + +(define (imap-examine imap inbox) + (imap-selectish-command imap (list "EXAMINE" inbox) #t)) + +;; Used to return (values #f #f) if no change since last check? +(define (imap-noop imap) + (imap-selectish-command imap "NOOP" #f)) + +(define (imap-selectish-command imap cmd reset?) + (let ([init-count #f] + [init-recent #f]) + (check-ok (imap-send imap cmd void)) + (when reset? + (set-imap-expunges! imap (new-tree)) + (set-imap-fetches! imap (new-tree)) + (set-imap-new?! imap #f)) + (values (imap-exists imap) (imap-recent imap)))) + +(define (imap-status imap inbox flags) + (unless (and (list? flags) + (andmap (lambda (s) + (memq s '(messages recent uidnext uidvalidity unseen))) + flags)) + (raise-type-error 'imap-status "list of status flag symbols" flags)) + (let ([results null]) + (check-ok (imap-send imap (list "STATUS" inbox (box (format "~a" flags))) + (lambda (i) + (when (and (list? i) (= 3 (length i)) + (tag-eq? (car i) 'STATUS)) + (set! results (caddr i)))))) + (map (lambda (f) + (let loop ([l results]) + (cond + [(or (null? l) (null? (cdr l))) #f] + [(tag-eq? f (car l)) (cadr l)] + [else (loop (cdr l))]))) + flags))) + +(define (imap-poll imap) + (when (and ;; Check for async messages from the server + (char-ready? (imap-r imap)) + ;; It has better start with "*"... + (= (peek-byte (imap-r imap)) (char->integer #\*))) + ;; May set fields in `imap': + (get-response (imap-r imap) #f (wrap-info-handler imap void) null) + (void))) + +(define (imap-get-updates imap) + (no-expunges 'imap-updates imap) + (let ([l (fetch-tree->list (imap-fetches imap))]) + (set-imap-fetches! imap (new-tree)) + l)) + +(define (imap-pending-updates? imap) + (not (tree-empty? (imap-fetches imap)))) + +(define (imap-get-expunges imap) + (let ([l (expunge-tree->list (imap-expunges imap))]) + (set-imap-expunges! imap (new-tree)) + l)) + +(define (imap-pending-expunges? imap) + (not (tree-empty? (imap-expunges imap)))) + +(define (imap-reset-new! imap) + (set-imap-new?! imap #f)) + +(define (imap-messages imap) + (imap-exists imap)) + +(define (imap-disconnect imap) + (let ([r (imap-r imap)] + [w (imap-w imap)]) + (check-ok (imap-send imap "LOGOUT" void)) + (close-input-port r) + (close-output-port w))) + +(define (imap-force-disconnect imap) + (let ([r (imap-r imap)] + [w (imap-w imap)]) + (close-input-port r) + (close-output-port w))) + +(define (no-expunges who imap) + (unless (tree-empty? (imap-expunges imap)) + (raise-mismatch-error who "session has pending expunge reports: " imap))) + +(define (msg-set msgs) + (apply + string-append + (let loop ([prev #f][msgs msgs]) + (cond + [(null? msgs) null] + [(and prev + (pair? (cdr msgs)) + (= (add1 prev) (car msgs))) + (loop (car msgs) (cdr msgs))] + [prev (cons (format ":~a," prev) + (loop #f msgs))] + [(null? (cdr msgs)) (list (format "~a" (car msgs)))] + [(= (add1 (car msgs)) (cadr msgs)) + (cons (format "~a" (car msgs)) + (loop (car msgs) (cdr msgs)))] + [else (cons (format "~a," (car msgs)) + (loop #f (cdr msgs)))])))) + +(define (imap-get-messages imap msgs field-list) + (no-expunges 'imap-get-messages imap) + (when (or (not (list? msgs)) + (not (andmap integer? msgs))) + (raise-type-error 'imap-get-messages "non-empty message list" msgs)) + (when (or (null? field-list) + (not (list? field-list)) + (not (andmap (lambda (f) (assoc f field-names)) field-list))) + (raise-type-error 'imap-get-messages "non-empty field list" field-list)) + + (if (null? msgs) + null + (begin + ;; FETCH request adds info to `(imap-fectches imap)': + (imap-send imap + (list "FETCH" + (box (msg-set msgs)) + (box + (format "(~a)" + (splice (map (lambda (f) + (cadr (assoc f field-names))) + field-list) + " ")))) + void) + ;; Sort out the collected info: + (let ([flds (map (lambda (f) (cadr (assoc f field-names))) + field-list)]) + (begin0 + ;; For each msg, try to get each field value: + (map + (lambda (msg) + (let ([m (or (fetch-find (imap-fetches imap) msg) + (error 'imap-get-messages "no result for message ~a" msg))]) + (let loop ([flds flds][m (cdr m)]) + (cond + [(null? flds) + (if (null? m) + (fetch-delete! (imap-fetches imap) msg) + (fetch-insert! (imap-fetches imap) (cons msg m))) + null] + [else + (let ([a (assoc (car flds) m)]) + (cons (and a (cdr a)) + (loop (cdr flds) (if a (remq a m) m))))])))) + msgs)))))) + +(define (imap-store imap mode msgs flags) + (no-expunges 'imap-store imap) + (check-ok + (imap-send imap + (list "STORE" + (box (msg-set msgs)) + (case mode + [(+) "+FLAGS.SILENT"] + [(-) "-FLAGS.SILENT"] + [(!) "FLAGS.SILENT"] + [else (raise-type-error 'imap-store + "mode: '!, '+, or '-" mode)]) + (box (format "~a" flags))) + void))) + +(define (imap-copy imap msgs dest-mailbox) + (no-expunges 'imap-copy imap) + (check-ok + (imap-send imap (list "COPY" (box (msg-set msgs)) dest-mailbox) void))) + +(define (imap-append imap dest-mailbox msg) + (no-expunges 'imap-append imap) + (let ([msg (if (bytes? msg) msg (string->bytes/utf-8 msg))]) + (check-ok + (imap-send imap (list "APPEND" + dest-mailbox + (box "(\\Seen)") + (box (format "{~a}" (bytes-length msg)))) + void + (lambda (loop contin) + (fprintf (imap-w imap) "~a\r\n" msg) + (loop)))))) + +(define (imap-expunge imap) + (check-ok (imap-send imap "EXPUNGE" void))) + +(define (imap-mailbox-exists? imap mailbox) + (let ([exists? #f]) + (check-ok (imap-send imap + (list "LIST" "" mailbox) + (lambda (i) + (when (and (pair? i) (tag-eq? (car i) 'LIST)) + (set! exists? #t))))) + exists?)) + +(define (imap-create-mailbox imap mailbox) + (check-ok (imap-send imap (list "CREATE" mailbox) void))) + +(define (imap-get-hierarchy-delimiter imap) + (let ([result #f]) + (check-ok + (imap-send imap (list "LIST" "" "") + (lambda (i) + (when (and (pair? i) (tag-eq? (car i) 'LIST)) + (set! result (caddr i)))))) + result)) + +(define imap-list-child-mailboxes + (case-lambda + [(imap mailbox) + (imap-list-child-mailboxes imap mailbox #f)] + [(imap mailbox raw-delimiter) + (let* ([delimiter (or raw-delimiter (imap-get-hierarchy-delimiter imap))] + [mailbox-name (and mailbox (bytes-append mailbox delimiter))] + [pattern (if mailbox + (bytes-append mailbox-name #"%") + #"%")]) + (map (lambda (p) + (list (car p) + (cond + [(symbol? (cadr p)) + (string->bytes/utf-8 (symbol->string (cadr p)))] + [(string? (cadr p)) + (string->bytes/utf-8 (symbol->string (cadr p)))] + [(bytes? (cadr p)) + (cadr p)]))) + (imap-list-mailboxes imap pattern mailbox-name)))])) + +(define (imap-mailbox-flags imap mailbox) + (let ([r (imap-list-mailboxes imap mailbox #f)]) + (if (= (length r) 1) + (caar r) + (error 'imap-mailbox-flags "could not get flags for ~s (~a)" + mailbox + (if (null? r) "no matches" "multiple matches"))))) + +(define (imap-list-mailboxes imap pattern except) + (let* ([sub-folders null]) + (check-ok + (imap-send imap (list "LIST" "" pattern) + (lambda (x) + (when (and (pair? x) + (tag-eq? (car x) 'LIST)) + (let* ([flags (cadr x)] + [name (cadddr x)] + [bytes-name (if (symbol? name) + (string->bytes/utf-8 (symbol->string name)) + name)]) + (unless (and except + (bytes=? bytes-name except)) + (set! sub-folders + (cons (list flags name) sub-folders)))))))) + (reverse sub-folders))) diff --git a/collects/net/scribblings/imap.scrbl b/collects/net/scribblings/imap.scrbl index e4f835a4d5..da85e9565d 100644 --- a/collects/net/scribblings/imap.scrbl +++ b/collects/net/scribblings/imap.scrbl @@ -497,6 +497,10 @@ Returns a list of IMAP flags for the given mailbox. See also @section{IMAP Unit} +@margin-note{@racket[imap@] and @racket[imap^] are deprecated. +They exist for backward-compatibility and will likely be removed in +the future. New code should use the @racketmodname[net/imap] module.} + @defmodule[net/imap-unit] @defthing[imap@ unit?]{ From 67ca846fd9440eec9c154ca5cde7d3019f12f821 Mon Sep 17 00:00:00 2001 From: Jon Zeppieri Date: Mon, 29 Aug 2011 21:33:56 -0400 Subject: [PATCH 151/235] Moved `net/mime' code from unit to module. --- collects/net/mime-unit.rkt | 736 +--------------------------- collects/net/mime.rkt | 728 ++++++++++++++++++++++++++- collects/net/scribblings/mime.scrbl | 4 + 3 files changed, 725 insertions(+), 743 deletions(-) diff --git a/collects/net/mime-unit.rkt b/collects/net/mime-unit.rkt index fee2e9f890..538eab9236 100644 --- a/collects/net/mime-unit.rkt +++ b/collects/net/mime-unit.rkt @@ -1,734 +1,8 @@ -;;; -;;; ---- MIME support -;;; -;;; Copyright (C) 2002 by PLT. -;;; Copyright (C) 2001 by Wish Computing. -;;; -;;; This file is part of mime +#lang racket/base -;;; mime-plt is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 2, or (at your option) -;;; any later version. +(require racket/unit + "mime-sig.rkt" "mime.rkt") -;;; mime-plt is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. +(define-unit-from-context mime@ mime^) -;;; You should have received a copy of the GNU General Public License -;;; along with mime-plt; see the file COPYING. If not, write to the -;;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;;; Boston, MA 02110-1301 USA. - -;;; Author: Francisco Solsona -;; -;; -;; Commentary: MIME support for PLT Scheme: an implementation of -;; rfc2045, rfc2046, rfc2047, rfc2048, and rfc2049. - -#lang racket/unit - -(require "mime-sig.rkt" "qp-sig.rkt" "base64-sig.rkt" "head-sig.rkt" - "mime-util.rkt" - racket/port) - -(import base64^ qp^ head^) -(export mime^) - -;; Constants: -(define discrete-alist - '(("text" . text) - ("image" . image) - ("audio" . audio) - ("video" . video) - ("application" . application))) - -(define disposition-alist - '(("inline" . inline) - ("attachment" . attachment) - ("file" . attachment) ;; This is used (don't know why) by - ;; multipart/form-data - ("messagetext" . inline) - ("form-data" . form-data))) - -(define composite-alist - '(("message" . message) - ("multipart" . multipart))) - -(define mechanism-alist - '(("7bit" . 7bit) - ("8bit" . 8bit) - ("binary" . binary) - ("quoted-printable" . quoted-printable) - ("base64" . base64))) - -(define ietf-extensions '()) -(define iana-extensions - '(;; text - ("plain" . plain) - ("html" . html) - ("enriched" . enriched) ; added 5/2005 - probably not iana - ("richtext" . richtext) - ("tab-separated-values" . tab-separated-values) - ;; Multipart - ("mixed" . mixed) - ("alternative" . alternative) - ("digest" . digest) - ("parallel" . parallel) - ("appledouble" . appledouble) - ("header-set" . header-set) - ("form-data" . form-data) - ;; Message - ("rfc822" . rfc822) - ("partial" . partial) - ("external-body" . external-body) - ("news" . news) - ;; Application - ("octet-stream" . octet-stream) - ("postscript" . postscript) - ("oda" . oda) - ("atomicmail" . atomicmail) - ("andrew-inset" . andrew-inset) - ("slate" . slate) - ("wita" . wita) - ("dec-dx" . dec-dx) - ("dca-rf" . dca-rf) - ("activemessage" . activemessage) - ("rtf" . rtf) - ("applefile" . applefile) - ("mac-binhex40" . mac-binhex40) - ("news-message-id" . news-message-id) - ("news-transmissio" . news-transmissio) - ("wordperfect5.1" . wordperfect5.1) - ("pdf" . pdf) - ("zip" . zip) - ("macwritei" . macwritei) - ;; "image" - ("jpeg" . jpeg) - ("gif" . gif) - ("ief" . ief) - ("tiff" . tiff) - ;; "audio" - ("basic" . basic) - ;; "video" . - ("mpeg" . mpeg) - ("quicktime" . quicktime))) - -;; Basic structures -(define-struct message (version entity fields) - #:mutable) -(define-struct entity - (type subtype charset encoding disposition params id description other - fields parts body) - #:mutable) -(define-struct disposition - (type filename creation modification read size params) - #:mutable) - -;; Exceptions -(define-struct mime-error ()) -(define-struct (unexpected-termination mime-error) (msg)) -(define-struct (missing-multipart-boundary-parameter mime-error) ()) -(define-struct (malformed-multipart-entity mime-error) (msg)) -(define-struct (empty-mechanism mime-error) ()) -(define-struct (empty-type mime-error) ()) -(define-struct (empty-subtype mime-error) ()) -(define-struct (empty-disposition-type mime-error) ()) - -;; ************************************* -;; Practical stuff, aka MIME in action: -;; ************************************* -(define CRLF (format "~a~a" #\return #\newline)) -(define CRLF-binary "=0D=0A") ;; quoted printable representation - -;; get-headers : input-port -> string -;; returns the header part of a message/part conforming to rfc822, and -;; rfc2045. -(define (get-headers in) - (let loop ([headers ""] [ln (read-line in 'any)]) - (cond [(eof-object? ln) - ;; (raise (make-unexpected-termination "eof reached! while parsing headers")) - (warning "premature eof while parsing headers") - headers] - [(string=? ln "") headers] - [else - ;; Quoting rfc822: - ;; " Headers occur before the message body and are - ;; terminated by a null line (i.e., two contiguous - ;; CRLFs)." - ;; That is: Two empty lines. But most MUAs seem to count - ;; the CRLF ending the last field (header) as the first - ;; CRLF of the null line. - (loop (string-append headers ln CRLF) - (read-line in 'any))]))) - -(define (make-default-disposition) - (make-disposition - 'inline ;; type - "" ;; filename - #f ;; creation - #f ;; modification - #f ;; read - #f ;; size - null ;; params - )) - -(define (make-default-entity) - (make-entity - 'text ;; type - 'plain ;; subtype - 'us-ascii ;; charset - '7bit ;; encoding - (make-default-disposition) ;; disposition - null ;; params - "" ;; id - "" ;; description - null ;; other MIME fields (MIME-extension-fields) - null ;; fields - null ;; parts - null ;; body - )) - -(define (make-default-message) - (make-message 1.0 (make-default-entity) null)) - -(define (mime-decode entity input) - (set-entity-body! - entity - (case (entity-encoding entity) - [(quoted-printable) - (lambda (output) - (qp-decode-stream input output))] - [(base64) - (lambda (output) - (base64-decode-stream input output))] - [else ;; 7bit, 8bit, binary - (lambda (output) - (copy-port input output))]))) - -(define (mime-analyze input [part #f]) - (let* ([iport (if (bytes? input) - (open-input-bytes input) - input)] - [headers (get-headers iport)] - [msg (if part - (MIME-part-headers headers) - (MIME-message-headers headers))] - [entity (message-entity msg)]) - ;; OK we have in msg a MIME-message structure, lets see what we have: - (case (entity-type entity) - [(text image audio video application) - ;; decode part, and save port and thunk - (mime-decode entity iport)] - [(message multipart) - (let ([boundary (entity-boundary entity)]) - (when (not boundary) - (when (eq? 'multipart (entity-type entity)) - (raise (make-missing-multipart-boundary-parameter)))) - (set-entity-parts! entity - (map (lambda (part) - (mime-analyze part #t)) - (if boundary - (multipart-body iport boundary) - (list iport)))))] - [else - ;; Unrecognized type, you're on your own! (sorry) - (mime-decode entity iport)]) - ;; return mime structure - msg)) - -(define (entity-boundary entity) - (let* ([params (entity-params entity)] - [ans (assoc "boundary" params)]) - (and ans (cdr ans)))) - -;; ************************************************* -;; MIME Specific: rfc2045-2049, and rfc0822, rfc2183 -;; ************************************************* - -;;multipart-body := [preamble CRLF] -;; dash-boundary transport-padding CRLF -;; body-part *encapsulation -;; close-delimiter transport-padding -;; [CRLF epilogue] -;; Returns a list of input ports, each one containing the correspongind part. -(define (multipart-body input boundary) - (let* ([make-re (lambda (prefix) - (regexp (string-append prefix "--" (regexp-quote boundary) "(--)?\r\n")))] - [re (make-re "\r\n")]) - (letrec ([eat-part (lambda () - (let-values ([(pin pout) (make-pipe)]) - (let ([m (regexp-match re input 0 #f pout)]) - (cond - [(not m) - (close-output-port pout) - (values pin ;; part - #f ;; close-delimiter? - #t ;; eof reached? - )] - [(cadr m) - (close-output-port pout) - (values pin #t #f)] - [else - (close-output-port pout) - (values pin #f #f)]))))]) - ;; pre-amble is allowed to be completely empty: - (if (regexp-match-peek (make-re "^") input) - ;; No \r\f before first separator: - (read-line input) - ;; non-empty preamble: - (eat-part)) - (let loop () - (let-values ([(part close? eof?) (eat-part)]) - (cond [close? (list part)] - [eof? (list part)] - [else (cons part (loop))])))))) - -;; MIME-message-headers := entity-headers -;; fields -;; version CRLF -;; ; The ordering of the header -;; ; fields implied by this BNF -;; ; definition should be ignored. -(define (MIME-message-headers headers) - (let ([message (make-default-message)]) - (entity-headers headers message #t) - message)) - -;; MIME-part-headers := entity-headers -;; [ fields ] -;; ; Any field not beginning with -;; ; "content-" can have no defined -;; ; meaning and may be ignored. -;; ; The ordering of the header -;; ; fields implied by this BNF -;; ; definition should be ignored. -(define (MIME-part-headers headers) - (let ([message (make-default-message)]) - (entity-headers headers message #f) - message)) - -;; entity-headers := [ content CRLF ] -;; [ encoding CRLF ] -;; [ id CRLF ] -;; [ description CRLF ] -;; *( MIME-extension-field CRLF ) -(define (entity-headers headers message version?) - (let ([entity (message-entity message)]) - (let-values ([(mime non-mime) (get-fields headers)]) - (let loop ([fields mime]) - (unless (null? fields) - ;; Process MIME field - (let ([trimmed-h (trim-comments (car fields))]) - (or (and version? (version trimmed-h message)) - (content trimmed-h entity) - (encoding trimmed-h entity) - (dispositione trimmed-h entity) - (id trimmed-h entity) - (description trimmed-h entity) - (MIME-extension-field trimmed-h entity)) - ;; keep going - (loop (cdr fields))))) - ;; NON-mime headers (or semantically incorrect). In order to make - ;; this implementation of rfc2045 robuts, we will save the header in - ;; the fields field of the message struct: - (set-message-fields! message non-mime) - ;; Return message - message))) - -(define (get-fields headers) - (let ([mime null] [non-mime null]) - (letrec ([store-field - (lambda (f) - (unless (string=? f "") - (if (mime-header? f) - (set! mime (append mime (list (trim-spaces f)))) - (set! non-mime (append non-mime (list (trim-spaces f)))))))]) - (let ([fields (extract-all-fields headers)]) - (for-each (lambda (p) - (store-field (format "~a: ~a" (car p) (cdr p)))) - fields)) - (values mime non-mime)))) - -(define re:content #rx"^(?i:content-)") -(define re:mime #rx"^(?i:mime-version):") - -(define (mime-header? h) - (or (regexp-match? re:content h) - (regexp-match? re:mime h))) - -;;; Headers -;;; Content-type follows this BNF syntax: -;; content := "Content-Type" ":" type "/" subtype -;; *(";" parameter) -;; ; Matching of media type and subtype -;; ; is ALWAYS case-insensitive. -(define re:content-type #rx"^(?i:content-type):([^/]+)/([^/]+)$") -(define (content header entity) - (let* ([params (string-tokenizer #\; header)] - [one re:content-type] - [h (trim-all-spaces (car params))] - [target (regexp-match one h)] - [old-param (entity-params entity)]) - (and target - (set-entity-type! entity - (type (regexp-replace one h "\\1"))) ;; type - (set-entity-subtype! entity - (subtype (regexp-replace one h "\\2"))) ;; subtype - (set-entity-params! - entity - (append old-param - (let loop ([p (cdr params)] ;; parameters - [ans null]) - (cond [(null? p) ans] - [else - (let ([par-pair (parameter (trim-all-spaces (car p)))]) - (cond [par-pair - (when (string=? (car par-pair) "charset") - (set-entity-charset! entity (cdr par-pair))) - (loop (cdr p) (append ans (list par-pair)))] - [else - (warning "Invalid parameter for Content-Type: `~a'" (car p)) - ;; go on... - (loop (cdr p) ans)]))]))))))) - -;; From rfc2183 Content-Disposition -;; disposition := "Content-Disposition" ":" -;; disposition-type -;; *(";" disposition-parm) -(define re:content-disposition #rx"^(?i:content-disposition):(.+)$") -(define (dispositione header entity) - (let* ([params (string-tokenizer #\; header)] - [reg re:content-disposition] - [h (trim-all-spaces (car params))] - [target (regexp-match reg h)] - [disp-struct (entity-disposition entity)]) - (and target - (set-disposition-type! - disp-struct - (disp-type (regexp-replace reg h "\\1"))) - (disp-params (cdr params) disp-struct)))) - -;; version := "MIME-Version" ":" 1*DIGIT "." 1*DIGIT -(define re:mime-version #rx"^(?i:MIME-Version):([0-9]+)\\.([0-9]+)$") -(define (version header message) - (let* ([reg re:mime-version] - [h (trim-all-spaces header)] - [target (regexp-match reg h)]) - (and target - (set-message-version! - message - (string->number (regexp-replace reg h "\\1.\\2")))))) - -;; description := "Content-Description" ":" *text -(define re:content-description #rx"^(?i:content-description):[ \t\r\n]*(.*)$") -(define (description header entity) - (let* ([reg re:content-description] - [target (regexp-match reg header)]) - (and target - (set-entity-description! - entity - (trim-spaces (regexp-replace reg header "\\1")))))) - -;; encoding := "Content-Transfer-Encoding" ":" mechanism -(define re:content-transfer-encoding #rx"^(?i:content-transfer-encoding):(.+)$") -(define (encoding header entity) - (let* ([reg re:content-transfer-encoding] - [h (trim-all-spaces header)] - [target (regexp-match reg h)]) - (and target - (set-entity-encoding! - entity - (mechanism (regexp-replace reg h "\\1")))))) - -;; id := "Content-ID" ":" msg-id -(define re:content-id #rx"^(?i:content-id):(.+)$") -(define (id header entity) - (let* ([reg re:content-id] - [h (trim-all-spaces header)] - [target (regexp-match reg h)]) - (and target - (set-entity-id! - entity - (msg-id (regexp-replace reg h "\\1")))))) - -;; From rfc822: -;; msg-id = "<" addr-spec ">" ; Unique message id -;; addr-spec = local-part "@" domain ; global address -;; local-part = word *("." word) ; uninterpreted -;; ; case-preserved -;; domain = sub-domain *("." sub-domain) -;; sub-domain = domain-ref / domain-literal -;; domain-literal = "[" *(dtext / quoted-pair) "]" -;; domain-ref = atom ; symbolic reference -(define (msg-id str) - (let* ([r (regexp "^<[^@>]+@[^.]+(\\.[^.]+)*>$")] - [ans (regexp-match r str)]) - (if ans - str - (begin (warning "Invalid msg-id: ~a" str) str)))) - -;; mechanism := "7bit" / "8bit" / "binary" / -;; "quoted-printable" / "base64" / -;; ietf-token / x-token -(define (mechanism mech) - (if (not mech) - (raise (make-empty-mechanism)) - (let ([val (assoc (lowercase mech) mechanism-alist)]) - (or (and val (cdr val)) - (ietf-token mech) - (x-token mech))))) - -;; MIME-extension-field := -;; -(define (MIME-extension-field header entity) - (let* ([reg (regexp "^[Cc]ontent-(.+):[ \t]*(.+)$")] - [target (regexp-match reg header)]) - (and target - (set-entity-other! - entity - (append (entity-other entity) - (list (cons (regexp-replace reg header "\\1") - (trim-spaces (regexp-replace reg header "\\2"))))))))) - -;; type := discrete-type / composite-type -(define (type value) - (if (not value) - (raise (make-empty-type)) - (or (discrete-type value) - (composite-type value)))) - -;; disposition-type := "inline" / "attachment" / extension-token -(define (disp-type value) - (if (not value) - (raise (make-empty-disposition-type)) - (let ([val (assoc (lowercase (trim-spaces value)) disposition-alist)]) - (if val (cdr val) (extension-token value))))) - -;; discrete-type := "text" / "image" / "audio" / "video" / -;; "application" / extension-token -(define (discrete-type value) - (let ([val (assoc (lowercase (trim-spaces value)) discrete-alist)]) - (if val (cdr val) (extension-token value)))) - -;; composite-type := "message" / "multipart" / extension-token -(define (composite-type value) - (let ([val (assoc (lowercase (trim-spaces value)) composite-alist)]) - (if val (cdr val) (extension-token value)))) - -;; extension-token := ietf-token / x-token -(define (extension-token value) - (or (ietf-token value) - (x-token value))) - -;; ietf-token := -(define (ietf-token value) - (let ([ans (assoc (lowercase (trim-spaces value)) ietf-extensions)]) - (and ans (cdr ans)))) - -;; Directly from RFC 1700: -;; Type Subtype Description Reference -;; ---- ------- ----------- --------- -;; text plain [RFC1521,NSB] -;; richtext [RFC1521,NSB] -;; tab-separated-values [Paul Lindner] -;; -;; multipart mixed [RFC1521,NSB] -;; alternative [RFC1521,NSB] -;; digest [RFC1521,NSB] -;; parallel [RFC1521,NSB] -;; appledouble [MacMime,Patrik Faltstrom] -;; header-set [Dave Crocker] -;; -;; message rfc822 [RFC1521,NSB] -;; partial [RFC1521,NSB] -;; external-body [RFC1521,NSB] -;; news [RFC 1036, Henry Spencer] -;; -;; application octet-stream [RFC1521,NSB] -;; postscript [RFC1521,NSB] -;; oda [RFC1521,NSB] -;; atomicmail [atomicmail,NSB] -;; andrew-inset [andrew-inset,NSB] -;; slate [slate,terry crowley] -;; wita [Wang Info Transfer,Larry Campbell] -;; dec-dx [Digital Doc Trans, Larry Campbell] -;; dca-rft [IBM Doc Content Arch, Larry Campbell] -;; activemessage [Ehud Shapiro] -;; rtf [Paul Lindner] -;; applefile [MacMime,Patrik Faltstrom] -;; mac-binhex40 [MacMime,Patrik Faltstrom] -;; news-message-id [RFC1036, Henry Spencer] -;; news-transmission [RFC1036, Henry Spencer] -;; wordperfect5.1 [Paul Lindner] -;; pdf [Paul Lindner] -;; zip [Paul Lindner] -;; macwriteii [Paul Lindner] -;; msword [Paul Lindner] -;; remote-printing [RFC1486,MTR] -;; -;; image jpeg [RFC1521,NSB] -;; gif [RFC1521,NSB] -;; ief Image Exchange Format [RFC1314] -;; tiff Tag Image File Format [MTR] -;; -;; audio basic [RFC1521,NSB] -;; -;; video mpeg [RFC1521,NSB] -;; quicktime [Paul Lindner] - -;; x-token := -(define (x-token value) - (let* ([r #rx"^[xX]-(.*)"] - [h (trim-spaces value)] - [ans (regexp-match r h)]) - (and ans - (token (regexp-replace r h "\\1")) - h))) - -;; subtype := extension-token / iana-token -(define (subtype value) - (if (not value) - (raise (make-empty-subtype)) - (or (extension-token value) - (iana-token value)))) - -;; iana-token := -(define (iana-token value) - (let ([ans (assoc (lowercase (trim-spaces value)) iana-extensions)]) - (and ans (cdr ans)))) - -;; parameter := attribute "=" value -(define re:parameter (regexp "([^=]+)=(.+)")) -(define (parameter par) - (let* ([r re:parameter] - [att (attribute (regexp-replace r par "\\1"))] - [val (value (regexp-replace r par "\\2"))]) - (if (regexp-match r par) - (cons (if att (lowercase att) "???") val) - (cons "???" par)))) - -;; value := token / quoted-string -(define (value val) - (or (token val) - (quoted-string val) - val)) - -;; token := 1* -;; tspecials := "(" / ")" / "<" / ">" / "@" / -;; "," / ";" / ":" / "\" / <"> -;; "/" / "[" / "]" / "?" / "=" -;; ; Must be in quoted-string, -;; ; to use within parameter values -(define (token value) - (let* ([tspecials (regexp "[^][()<>@,;:\\\"/?= ]+")] - [ans (regexp-match tspecials value)]) - (and ans - (string=? value (car ans)) - (car ans)))) - -;; attribute := token -;; ; Matching of attributes -;; ; is ALWAYS case-insensitive. -(define attribute token) - -(define re:quotes (regexp "\"(.+)\"")) -(define (quoted-string str) - (let* ([quotes re:quotes] - [ans (regexp-match quotes str)]) - (and ans (regexp-replace quotes str "\\1")))) - -;; disposition-parm := filename-parm -;; / creation-date-parm -;; / modification-date-parm -;; / read-date-parm -;; / size-parm -;; / parameter -;; -;; filename-parm := "filename" "=" value -;; -;; creation-date-parm := "creation-date" "=" quoted-date-time -;; -;; modification-date-parm := "modification-date" "=" quoted-date-time -;; -;; read-date-parm := "read-date" "=" quoted-date-time -;; -;; size-parm := "size" "=" 1*DIGIT -(define (disp-params lst disp) - (let loop ([lst lst]) - (unless (null? lst) - (let* ([p (parameter (trim-all-spaces (car lst)))] - [parm (car p)] - [value (cdr p)]) - (cond [(string=? parm "filename") - (set-disposition-filename! disp value)] - [(string=? parm "creation-date") - (set-disposition-creation! - disp - (disp-quoted-data-time value))] - [(string=? parm "modification-date") - (set-disposition-modification! - disp - (disp-quoted-data-time value))] - [(string=? parm "read-date") - (set-disposition-read! - disp - (disp-quoted-data-time value))] - [(string=? parm "size") - (set-disposition-size! - disp - (string->number value))] - [else - (set-disposition-params! - disp - (append (disposition-params disp) (list p)))]) - (loop (cdr lst)))))) - -;; date-time = [ day "," ] date time ; dd mm yy -;; ; hh:mm:ss zzz -;; -;; day = "Mon" / "Tue" / "Wed" / "Thu" -;; / "Fri" / "Sat" / "Sun" -;; -;; date = 1*2DIGIT month 2DIGIT ; day month year -;; ; e.g. 20 Jun 82 -;; -;; month = "Jan" / "Feb" / "Mar" / "Apr" -;; / "May" / "Jun" / "Jul" / "Aug" -;; / "Sep" / "Oct" / "Nov" / "Dec" -;; -;; time = hour zone ; ANSI and Military -;; -;; hour = 2DIGIT ":" 2DIGIT [":" 2DIGIT] -;; ; 00:00:00 - 23:59:59 -;; -;; zone = "UT" / "GMT" ; Universal Time -;; ; North American : UT -;; / "EST" / "EDT" ; Eastern: - 5/ - 4 -;; / "CST" / "CDT" ; Central: - 6/ - 5 -;; / "MST" / "MDT" ; Mountain: - 7/ - 6 -;; / "PST" / "PDT" ; Pacific: - 8/ - 7 -;; / 1ALPHA ; Military: Z = UT; -;; ; A:-1; (J not used) -;; ; M:-12; N:+1; Y:+12 -;; / ( ("+" / "-") 4DIGIT ) ; Local differential -;; ; hours+min. (HHMM) -(define date-time - (lambda (str) - ;; Fix Me: I have to return a date structure, or time in seconds. - str)) - -;; quoted-date-time := quoted-string -;; ; contents MUST be an RFC 822 `date-time' -;; ; numeric timezones (+HHMM or -HHMM) MUST be used - -(define disp-quoted-data-time date-time) +(provide mime@) diff --git a/collects/net/mime.rkt b/collects/net/mime.rkt index 9714637433..508a656597 100644 --- a/collects/net/mime.rkt +++ b/collects/net/mime.rkt @@ -23,21 +23,725 @@ ;;; Author: Francisco Solsona ;; -;; -;; Commentary: +;; Commentary: MIME support for PLT Scheme: an implementation of +;; rfc2045, rfc2046, rfc2047, rfc2048, and rfc2049. #lang racket/base -(require racket/unit - "mime-sig.rkt" "mime-unit.rkt" "qp.rkt" "base64.rkt" "head.rkt") -;(define-unit-from-context base64@ base64^) -;(define-unit-from-context qp@ qp^) -;(define-unit-from-context head@ head^) +(require racket/port "mime-util.rkt" "qp.rkt" "base64.rkt" "head.rkt") -(define-values/invoke-unit/infer - (export mime^) - (link mime@)) +(provide + ;; -- exceptions raised -- + (struct-out mime-error) + (struct-out unexpected-termination) + (struct-out missing-multipart-boundary-parameter) + (struct-out malformed-multipart-entity) + (struct-out empty-mechanism) + (struct-out empty-type) + (struct-out empty-subtype) + (struct-out empty-disposition-type) -(provide-signature-elements mime^) + ;; -- basic mime structures -- + (struct-out message) + (struct-out entity) + (struct-out disposition) -;;; mime.rkt ends here + ;; -- mime methods -- + mime-analyze) + +;; Constants: +(define discrete-alist + '(("text" . text) + ("image" . image) + ("audio" . audio) + ("video" . video) + ("application" . application))) + +(define disposition-alist + '(("inline" . inline) + ("attachment" . attachment) + ("file" . attachment) ;; This is used (don't know why) by + ;; multipart/form-data + ("messagetext" . inline) + ("form-data" . form-data))) + +(define composite-alist + '(("message" . message) + ("multipart" . multipart))) + +(define mechanism-alist + '(("7bit" . 7bit) + ("8bit" . 8bit) + ("binary" . binary) + ("quoted-printable" . quoted-printable) + ("base64" . base64))) + +(define ietf-extensions '()) +(define iana-extensions + '(;; text + ("plain" . plain) + ("html" . html) + ("enriched" . enriched) ; added 5/2005 - probably not iana + ("richtext" . richtext) + ("tab-separated-values" . tab-separated-values) + ;; Multipart + ("mixed" . mixed) + ("alternative" . alternative) + ("digest" . digest) + ("parallel" . parallel) + ("appledouble" . appledouble) + ("header-set" . header-set) + ("form-data" . form-data) + ;; Message + ("rfc822" . rfc822) + ("partial" . partial) + ("external-body" . external-body) + ("news" . news) + ;; Application + ("octet-stream" . octet-stream) + ("postscript" . postscript) + ("oda" . oda) + ("atomicmail" . atomicmail) + ("andrew-inset" . andrew-inset) + ("slate" . slate) + ("wita" . wita) + ("dec-dx" . dec-dx) + ("dca-rf" . dca-rf) + ("activemessage" . activemessage) + ("rtf" . rtf) + ("applefile" . applefile) + ("mac-binhex40" . mac-binhex40) + ("news-message-id" . news-message-id) + ("news-transmissio" . news-transmissio) + ("wordperfect5.1" . wordperfect5.1) + ("pdf" . pdf) + ("zip" . zip) + ("macwritei" . macwritei) + ;; "image" + ("jpeg" . jpeg) + ("gif" . gif) + ("ief" . ief) + ("tiff" . tiff) + ;; "audio" + ("basic" . basic) + ;; "video" . + ("mpeg" . mpeg) + ("quicktime" . quicktime))) + +;; Basic structures +(define-struct message (version entity fields) + #:mutable) +(define-struct entity + (type subtype charset encoding disposition params id description other + fields parts body) + #:mutable) +(define-struct disposition + (type filename creation modification read size params) + #:mutable) + +;; Exceptions +(define-struct mime-error ()) +(define-struct (unexpected-termination mime-error) (msg)) +(define-struct (missing-multipart-boundary-parameter mime-error) ()) +(define-struct (malformed-multipart-entity mime-error) (msg)) +(define-struct (empty-mechanism mime-error) ()) +(define-struct (empty-type mime-error) ()) +(define-struct (empty-subtype mime-error) ()) +(define-struct (empty-disposition-type mime-error) ()) + +;; ************************************* +;; Practical stuff, aka MIME in action: +;; ************************************* +(define CRLF (format "~a~a" #\return #\newline)) +(define CRLF-binary "=0D=0A") ;; quoted printable representation + +;; get-headers : input-port -> string +;; returns the header part of a message/part conforming to rfc822, and +;; rfc2045. +(define (get-headers in) + (let loop ([headers ""] [ln (read-line in 'any)]) + (cond [(eof-object? ln) + ;; (raise (make-unexpected-termination "eof reached! while parsing headers")) + (warning "premature eof while parsing headers") + headers] + [(string=? ln "") headers] + [else + ;; Quoting rfc822: + ;; " Headers occur before the message body and are + ;; terminated by a null line (i.e., two contiguous + ;; CRLFs)." + ;; That is: Two empty lines. But most MUAs seem to count + ;; the CRLF ending the last field (header) as the first + ;; CRLF of the null line. + (loop (string-append headers ln CRLF) + (read-line in 'any))]))) + +(define (make-default-disposition) + (make-disposition + 'inline ;; type + "" ;; filename + #f ;; creation + #f ;; modification + #f ;; read + #f ;; size + null ;; params + )) + +(define (make-default-entity) + (make-entity + 'text ;; type + 'plain ;; subtype + 'us-ascii ;; charset + '7bit ;; encoding + (make-default-disposition) ;; disposition + null ;; params + "" ;; id + "" ;; description + null ;; other MIME fields (MIME-extension-fields) + null ;; fields + null ;; parts + null ;; body + )) + +(define (make-default-message) + (make-message 1.0 (make-default-entity) null)) + +(define (mime-decode entity input) + (set-entity-body! + entity + (case (entity-encoding entity) + [(quoted-printable) + (lambda (output) + (qp-decode-stream input output))] + [(base64) + (lambda (output) + (base64-decode-stream input output))] + [else ;; 7bit, 8bit, binary + (lambda (output) + (copy-port input output))]))) + +(define (mime-analyze input [part #f]) + (let* ([iport (if (bytes? input) + (open-input-bytes input) + input)] + [headers (get-headers iport)] + [msg (if part + (MIME-part-headers headers) + (MIME-message-headers headers))] + [entity (message-entity msg)]) + ;; OK we have in msg a MIME-message structure, lets see what we have: + (case (entity-type entity) + [(text image audio video application) + ;; decode part, and save port and thunk + (mime-decode entity iport)] + [(message multipart) + (let ([boundary (entity-boundary entity)]) + (when (not boundary) + (when (eq? 'multipart (entity-type entity)) + (raise (make-missing-multipart-boundary-parameter)))) + (set-entity-parts! entity + (map (lambda (part) + (mime-analyze part #t)) + (if boundary + (multipart-body iport boundary) + (list iport)))))] + [else + ;; Unrecognized type, you're on your own! (sorry) + (mime-decode entity iport)]) + ;; return mime structure + msg)) + +(define (entity-boundary entity) + (let* ([params (entity-params entity)] + [ans (assoc "boundary" params)]) + (and ans (cdr ans)))) + +;; ************************************************* +;; MIME Specific: rfc2045-2049, and rfc0822, rfc2183 +;; ************************************************* + +;;multipart-body := [preamble CRLF] +;; dash-boundary transport-padding CRLF +;; body-part *encapsulation +;; close-delimiter transport-padding +;; [CRLF epilogue] +;; Returns a list of input ports, each one containing the correspongind part. +(define (multipart-body input boundary) + (let* ([make-re (lambda (prefix) + (regexp (string-append prefix "--" (regexp-quote boundary) "(--)?\r\n")))] + [re (make-re "\r\n")]) + (letrec ([eat-part (lambda () + (let-values ([(pin pout) (make-pipe)]) + (let ([m (regexp-match re input 0 #f pout)]) + (cond + [(not m) + (close-output-port pout) + (values pin ;; part + #f ;; close-delimiter? + #t ;; eof reached? + )] + [(cadr m) + (close-output-port pout) + (values pin #t #f)] + [else + (close-output-port pout) + (values pin #f #f)]))))]) + ;; pre-amble is allowed to be completely empty: + (if (regexp-match-peek (make-re "^") input) + ;; No \r\f before first separator: + (read-line input) + ;; non-empty preamble: + (eat-part)) + (let loop () + (let-values ([(part close? eof?) (eat-part)]) + (cond [close? (list part)] + [eof? (list part)] + [else (cons part (loop))])))))) + +;; MIME-message-headers := entity-headers +;; fields +;; version CRLF +;; ; The ordering of the header +;; ; fields implied by this BNF +;; ; definition should be ignored. +(define (MIME-message-headers headers) + (let ([message (make-default-message)]) + (entity-headers headers message #t) + message)) + +;; MIME-part-headers := entity-headers +;; [ fields ] +;; ; Any field not beginning with +;; ; "content-" can have no defined +;; ; meaning and may be ignored. +;; ; The ordering of the header +;; ; fields implied by this BNF +;; ; definition should be ignored. +(define (MIME-part-headers headers) + (let ([message (make-default-message)]) + (entity-headers headers message #f) + message)) + +;; entity-headers := [ content CRLF ] +;; [ encoding CRLF ] +;; [ id CRLF ] +;; [ description CRLF ] +;; *( MIME-extension-field CRLF ) +(define (entity-headers headers message version?) + (let ([entity (message-entity message)]) + (let-values ([(mime non-mime) (get-fields headers)]) + (let loop ([fields mime]) + (unless (null? fields) + ;; Process MIME field + (let ([trimmed-h (trim-comments (car fields))]) + (or (and version? (version trimmed-h message)) + (content trimmed-h entity) + (encoding trimmed-h entity) + (dispositione trimmed-h entity) + (id trimmed-h entity) + (description trimmed-h entity) + (MIME-extension-field trimmed-h entity)) + ;; keep going + (loop (cdr fields))))) + ;; NON-mime headers (or semantically incorrect). In order to make + ;; this implementation of rfc2045 robuts, we will save the header in + ;; the fields field of the message struct: + (set-message-fields! message non-mime) + ;; Return message + message))) + +(define (get-fields headers) + (let ([mime null] [non-mime null]) + (letrec ([store-field + (lambda (f) + (unless (string=? f "") + (if (mime-header? f) + (set! mime (append mime (list (trim-spaces f)))) + (set! non-mime (append non-mime (list (trim-spaces f)))))))]) + (let ([fields (extract-all-fields headers)]) + (for-each (lambda (p) + (store-field (format "~a: ~a" (car p) (cdr p)))) + fields)) + (values mime non-mime)))) + +(define re:content #rx"^(?i:content-)") +(define re:mime #rx"^(?i:mime-version):") + +(define (mime-header? h) + (or (regexp-match? re:content h) + (regexp-match? re:mime h))) + +;;; Headers +;;; Content-type follows this BNF syntax: +;; content := "Content-Type" ":" type "/" subtype +;; *(";" parameter) +;; ; Matching of media type and subtype +;; ; is ALWAYS case-insensitive. +(define re:content-type #rx"^(?i:content-type):([^/]+)/([^/]+)$") +(define (content header entity) + (let* ([params (string-tokenizer #\; header)] + [one re:content-type] + [h (trim-all-spaces (car params))] + [target (regexp-match one h)] + [old-param (entity-params entity)]) + (and target + (set-entity-type! entity + (type (regexp-replace one h "\\1"))) ;; type + (set-entity-subtype! entity + (subtype (regexp-replace one h "\\2"))) ;; subtype + (set-entity-params! + entity + (append old-param + (let loop ([p (cdr params)] ;; parameters + [ans null]) + (cond [(null? p) ans] + [else + (let ([par-pair (parameter (trim-all-spaces (car p)))]) + (cond [par-pair + (when (string=? (car par-pair) "charset") + (set-entity-charset! entity (cdr par-pair))) + (loop (cdr p) (append ans (list par-pair)))] + [else + (warning "Invalid parameter for Content-Type: `~a'" (car p)) + ;; go on... + (loop (cdr p) ans)]))]))))))) + +;; From rfc2183 Content-Disposition +;; disposition := "Content-Disposition" ":" +;; disposition-type +;; *(";" disposition-parm) +(define re:content-disposition #rx"^(?i:content-disposition):(.+)$") +(define (dispositione header entity) + (let* ([params (string-tokenizer #\; header)] + [reg re:content-disposition] + [h (trim-all-spaces (car params))] + [target (regexp-match reg h)] + [disp-struct (entity-disposition entity)]) + (and target + (set-disposition-type! + disp-struct + (disp-type (regexp-replace reg h "\\1"))) + (disp-params (cdr params) disp-struct)))) + +;; version := "MIME-Version" ":" 1*DIGIT "." 1*DIGIT +(define re:mime-version #rx"^(?i:MIME-Version):([0-9]+)\\.([0-9]+)$") +(define (version header message) + (let* ([reg re:mime-version] + [h (trim-all-spaces header)] + [target (regexp-match reg h)]) + (and target + (set-message-version! + message + (string->number (regexp-replace reg h "\\1.\\2")))))) + +;; description := "Content-Description" ":" *text +(define re:content-description #rx"^(?i:content-description):[ \t\r\n]*(.*)$") +(define (description header entity) + (let* ([reg re:content-description] + [target (regexp-match reg header)]) + (and target + (set-entity-description! + entity + (trim-spaces (regexp-replace reg header "\\1")))))) + +;; encoding := "Content-Transfer-Encoding" ":" mechanism +(define re:content-transfer-encoding #rx"^(?i:content-transfer-encoding):(.+)$") +(define (encoding header entity) + (let* ([reg re:content-transfer-encoding] + [h (trim-all-spaces header)] + [target (regexp-match reg h)]) + (and target + (set-entity-encoding! + entity + (mechanism (regexp-replace reg h "\\1")))))) + +;; id := "Content-ID" ":" msg-id +(define re:content-id #rx"^(?i:content-id):(.+)$") +(define (id header entity) + (let* ([reg re:content-id] + [h (trim-all-spaces header)] + [target (regexp-match reg h)]) + (and target + (set-entity-id! + entity + (msg-id (regexp-replace reg h "\\1")))))) + +;; From rfc822: +;; msg-id = "<" addr-spec ">" ; Unique message id +;; addr-spec = local-part "@" domain ; global address +;; local-part = word *("." word) ; uninterpreted +;; ; case-preserved +;; domain = sub-domain *("." sub-domain) +;; sub-domain = domain-ref / domain-literal +;; domain-literal = "[" *(dtext / quoted-pair) "]" +;; domain-ref = atom ; symbolic reference +(define (msg-id str) + (let* ([r (regexp "^<[^@>]+@[^.]+(\\.[^.]+)*>$")] + [ans (regexp-match r str)]) + (if ans + str + (begin (warning "Invalid msg-id: ~a" str) str)))) + +;; mechanism := "7bit" / "8bit" / "binary" / +;; "quoted-printable" / "base64" / +;; ietf-token / x-token +(define (mechanism mech) + (if (not mech) + (raise (make-empty-mechanism)) + (let ([val (assoc (lowercase mech) mechanism-alist)]) + (or (and val (cdr val)) + (ietf-token mech) + (x-token mech))))) + +;; MIME-extension-field := +;; +(define (MIME-extension-field header entity) + (let* ([reg (regexp "^[Cc]ontent-(.+):[ \t]*(.+)$")] + [target (regexp-match reg header)]) + (and target + (set-entity-other! + entity + (append (entity-other entity) + (list (cons (regexp-replace reg header "\\1") + (trim-spaces (regexp-replace reg header "\\2"))))))))) + +;; type := discrete-type / composite-type +(define (type value) + (if (not value) + (raise (make-empty-type)) + (or (discrete-type value) + (composite-type value)))) + +;; disposition-type := "inline" / "attachment" / extension-token +(define (disp-type value) + (if (not value) + (raise (make-empty-disposition-type)) + (let ([val (assoc (lowercase (trim-spaces value)) disposition-alist)]) + (if val (cdr val) (extension-token value))))) + +;; discrete-type := "text" / "image" / "audio" / "video" / +;; "application" / extension-token +(define (discrete-type value) + (let ([val (assoc (lowercase (trim-spaces value)) discrete-alist)]) + (if val (cdr val) (extension-token value)))) + +;; composite-type := "message" / "multipart" / extension-token +(define (composite-type value) + (let ([val (assoc (lowercase (trim-spaces value)) composite-alist)]) + (if val (cdr val) (extension-token value)))) + +;; extension-token := ietf-token / x-token +(define (extension-token value) + (or (ietf-token value) + (x-token value))) + +;; ietf-token := +(define (ietf-token value) + (let ([ans (assoc (lowercase (trim-spaces value)) ietf-extensions)]) + (and ans (cdr ans)))) + +;; Directly from RFC 1700: +;; Type Subtype Description Reference +;; ---- ------- ----------- --------- +;; text plain [RFC1521,NSB] +;; richtext [RFC1521,NSB] +;; tab-separated-values [Paul Lindner] +;; +;; multipart mixed [RFC1521,NSB] +;; alternative [RFC1521,NSB] +;; digest [RFC1521,NSB] +;; parallel [RFC1521,NSB] +;; appledouble [MacMime,Patrik Faltstrom] +;; header-set [Dave Crocker] +;; +;; message rfc822 [RFC1521,NSB] +;; partial [RFC1521,NSB] +;; external-body [RFC1521,NSB] +;; news [RFC 1036, Henry Spencer] +;; +;; application octet-stream [RFC1521,NSB] +;; postscript [RFC1521,NSB] +;; oda [RFC1521,NSB] +;; atomicmail [atomicmail,NSB] +;; andrew-inset [andrew-inset,NSB] +;; slate [slate,terry crowley] +;; wita [Wang Info Transfer,Larry Campbell] +;; dec-dx [Digital Doc Trans, Larry Campbell] +;; dca-rft [IBM Doc Content Arch, Larry Campbell] +;; activemessage [Ehud Shapiro] +;; rtf [Paul Lindner] +;; applefile [MacMime,Patrik Faltstrom] +;; mac-binhex40 [MacMime,Patrik Faltstrom] +;; news-message-id [RFC1036, Henry Spencer] +;; news-transmission [RFC1036, Henry Spencer] +;; wordperfect5.1 [Paul Lindner] +;; pdf [Paul Lindner] +;; zip [Paul Lindner] +;; macwriteii [Paul Lindner] +;; msword [Paul Lindner] +;; remote-printing [RFC1486,MTR] +;; +;; image jpeg [RFC1521,NSB] +;; gif [RFC1521,NSB] +;; ief Image Exchange Format [RFC1314] +;; tiff Tag Image File Format [MTR] +;; +;; audio basic [RFC1521,NSB] +;; +;; video mpeg [RFC1521,NSB] +;; quicktime [Paul Lindner] + +;; x-token := +(define (x-token value) + (let* ([r #rx"^[xX]-(.*)"] + [h (trim-spaces value)] + [ans (regexp-match r h)]) + (and ans + (token (regexp-replace r h "\\1")) + h))) + +;; subtype := extension-token / iana-token +(define (subtype value) + (if (not value) + (raise (make-empty-subtype)) + (or (extension-token value) + (iana-token value)))) + +;; iana-token := +(define (iana-token value) + (let ([ans (assoc (lowercase (trim-spaces value)) iana-extensions)]) + (and ans (cdr ans)))) + +;; parameter := attribute "=" value +(define re:parameter (regexp "([^=]+)=(.+)")) +(define (parameter par) + (let* ([r re:parameter] + [att (attribute (regexp-replace r par "\\1"))] + [val (value (regexp-replace r par "\\2"))]) + (if (regexp-match r par) + (cons (if att (lowercase att) "???") val) + (cons "???" par)))) + +;; value := token / quoted-string +(define (value val) + (or (token val) + (quoted-string val) + val)) + +;; token := 1* +;; tspecials := "(" / ")" / "<" / ">" / "@" / +;; "," / ";" / ":" / "\" / <"> +;; "/" / "[" / "]" / "?" / "=" +;; ; Must be in quoted-string, +;; ; to use within parameter values +(define (token value) + (let* ([tspecials (regexp "[^][()<>@,;:\\\"/?= ]+")] + [ans (regexp-match tspecials value)]) + (and ans + (string=? value (car ans)) + (car ans)))) + +;; attribute := token +;; ; Matching of attributes +;; ; is ALWAYS case-insensitive. +(define attribute token) + +(define re:quotes (regexp "\"(.+)\"")) +(define (quoted-string str) + (let* ([quotes re:quotes] + [ans (regexp-match quotes str)]) + (and ans (regexp-replace quotes str "\\1")))) + +;; disposition-parm := filename-parm +;; / creation-date-parm +;; / modification-date-parm +;; / read-date-parm +;; / size-parm +;; / parameter +;; +;; filename-parm := "filename" "=" value +;; +;; creation-date-parm := "creation-date" "=" quoted-date-time +;; +;; modification-date-parm := "modification-date" "=" quoted-date-time +;; +;; read-date-parm := "read-date" "=" quoted-date-time +;; +;; size-parm := "size" "=" 1*DIGIT +(define (disp-params lst disp) + (let loop ([lst lst]) + (unless (null? lst) + (let* ([p (parameter (trim-all-spaces (car lst)))] + [parm (car p)] + [value (cdr p)]) + (cond [(string=? parm "filename") + (set-disposition-filename! disp value)] + [(string=? parm "creation-date") + (set-disposition-creation! + disp + (disp-quoted-data-time value))] + [(string=? parm "modification-date") + (set-disposition-modification! + disp + (disp-quoted-data-time value))] + [(string=? parm "read-date") + (set-disposition-read! + disp + (disp-quoted-data-time value))] + [(string=? parm "size") + (set-disposition-size! + disp + (string->number value))] + [else + (set-disposition-params! + disp + (append (disposition-params disp) (list p)))]) + (loop (cdr lst)))))) + +;; date-time = [ day "," ] date time ; dd mm yy +;; ; hh:mm:ss zzz +;; +;; day = "Mon" / "Tue" / "Wed" / "Thu" +;; / "Fri" / "Sat" / "Sun" +;; +;; date = 1*2DIGIT month 2DIGIT ; day month year +;; ; e.g. 20 Jun 82 +;; +;; month = "Jan" / "Feb" / "Mar" / "Apr" +;; / "May" / "Jun" / "Jul" / "Aug" +;; / "Sep" / "Oct" / "Nov" / "Dec" +;; +;; time = hour zone ; ANSI and Military +;; +;; hour = 2DIGIT ":" 2DIGIT [":" 2DIGIT] +;; ; 00:00:00 - 23:59:59 +;; +;; zone = "UT" / "GMT" ; Universal Time +;; ; North American : UT +;; / "EST" / "EDT" ; Eastern: - 5/ - 4 +;; / "CST" / "CDT" ; Central: - 6/ - 5 +;; / "MST" / "MDT" ; Mountain: - 7/ - 6 +;; / "PST" / "PDT" ; Pacific: - 8/ - 7 +;; / 1ALPHA ; Military: Z = UT; +;; ; A:-1; (J not used) +;; ; M:-12; N:+1; Y:+12 +;; / ( ("+" / "-") 4DIGIT ) ; Local differential +;; ; hours+min. (HHMM) +(define date-time + (lambda (str) + ;; Fix Me: I have to return a date structure, or time in seconds. + str)) + +;; quoted-date-time := quoted-string +;; ; contents MUST be an RFC 822 `date-time' +;; ; numeric timezones (+HHMM or -HHMM) MUST be used + +(define disp-quoted-data-time date-time) diff --git a/collects/net/scribblings/mime.scrbl b/collects/net/scribblings/mime.scrbl index 30b8c38026..f611e1e641 100644 --- a/collects/net/scribblings/mime.scrbl +++ b/collects/net/scribblings/mime.scrbl @@ -236,6 +236,10 @@ field, or when the specification is incorrectly formatted.} @section{MIME Unit} +@margin-note{@racket[mime@] and @racket[mime^] are deprecated. +They exist for backward-compatibility and will likely be removed in +the future. New code should use the @racketmodname[net/mime] module.} + @defmodule[net/mime-unit] @defthing[mime@ unit?]{ From df5fef0c95631daca92d5dbbe5822765b43e8e5b Mon Sep 17 00:00:00 2001 From: Jon Zeppieri Date: Mon, 29 Aug 2011 21:46:03 -0400 Subject: [PATCH 152/235] Moved `net/nntp' code from unit to module. --- collects/net/nntp-unit.rkt | 312 +------------------------- collects/net/nntp.rkt | 325 +++++++++++++++++++++++++++- collects/net/scribblings/nntp.scrbl | 4 + 3 files changed, 331 insertions(+), 310 deletions(-) diff --git a/collects/net/nntp-unit.rkt b/collects/net/nntp-unit.rkt index 408f0a9059..0650418617 100644 --- a/collects/net/nntp-unit.rkt +++ b/collects/net/nntp-unit.rkt @@ -1,310 +1,8 @@ -#lang racket/unit +#lang racket/base -(require racket/tcp "nntp-sig.rkt") +(require racket/unit + "nntp-sig.rkt" "nntp.rkt") -(import) -(export nntp^) +(define-unit-from-context nntp@ nntp^) -;; sender : oport -;; receiver : iport -;; server : string -;; port : number - -(define-struct communicator (sender receiver server port)) - -;; code : number -;; text : string -;; line : string -;; communicator : communicator -;; group : string -;; article : number - -(define-struct (nntp exn) ()) -(define-struct (unexpected-response nntp) (code text)) -(define-struct (bad-status-line nntp) (line)) -(define-struct (premature-close nntp) (communicator)) -(define-struct (bad-newsgroup-line nntp) (line)) -(define-struct (non-existent-group nntp) (group)) -(define-struct (article-not-in-group nntp) (article)) -(define-struct (no-group-selected nntp) ()) -(define-struct (article-not-found nntp) (article)) -(define-struct (authentication-rejected nntp) ()) - -;; signal-error : -;; (exn-args ... -> exn) x format-string x values ... -> -;; exn-args -> () - -;; - throws an exception - -(define (signal-error constructor format-string . args) - (lambda exn-args - (raise (apply constructor - (apply format format-string args) - (current-continuation-marks) - exn-args)))) - -;; default-nntpd-port-number : -;; number - -(define default-nntpd-port-number 119) - -;; connect-to-server*: -;; input-port output-port -> communicator - -(define connect-to-server* - (case-lambda - [(receiver sender) - (connect-to-server* receiver sender "unspecified" "unspecified")] - [(receiver sender server-name port-number) - (file-stream-buffer-mode sender 'line) - (let ([communicator (make-communicator sender receiver server-name - port-number)]) - (let-values ([(code response) - (get-single-line-response communicator)]) - (case code - [(200 201) communicator] - [else ((signal-error make-unexpected-response - "unexpected connection response: ~s ~s" - code response) - code response)])))])) - -;; connect-to-server : -;; string [x number] -> commnicator - -(define connect-to-server - (lambda (server-name (port-number default-nntpd-port-number)) - (let-values ([(receiver sender) - (tcp-connect server-name port-number)]) - (connect-to-server* receiver sender server-name port-number)))) - -;; close-communicator : -;; communicator -> () - -(define (close-communicator communicator) - (close-input-port (communicator-receiver communicator)) - (close-output-port (communicator-sender communicator))) - -;; disconnect-from-server : -;; communicator -> () - -(define (disconnect-from-server communicator) - (send-to-server communicator "QUIT") - (let-values ([(code response) - (get-single-line-response communicator)]) - (case code - [(205) - (close-communicator communicator)] - [else - ((signal-error make-unexpected-response - "unexpected dis-connect response: ~s ~s" - code response) - code response)]))) - -;; authenticate-user : -;; communicator x user-name x password -> () -;; the password is not used if the server does not ask for it. - -(define (authenticate-user communicator user password) - (define (reject code response) - ((signal-error make-authentication-rejected - "authentication rejected (~s ~s)" - code response))) - (define (unexpected code response) - ((signal-error make-unexpected-response - "unexpected response for authentication: ~s ~s" - code response) - code response)) - (send-to-server communicator "AUTHINFO USER ~a" user) - (let-values ([(code response) (get-single-line-response communicator)]) - (case code - [(281) (void)] ; server doesn't ask for a password - [(381) - (send-to-server communicator "AUTHINFO PASS ~a" password) - (let-values ([(code response) - (get-single-line-response communicator)]) - (case code - [(281) (void)] ; done - [(502) (reject code response)] - [else (unexpected code response)]))] - [(502) (reject code response)] - [else (reject code response) - (unexpected code response)]))) - -;; send-to-server : -;; communicator x format-string x list (values) -> () - -(define (send-to-server communicator message-template . rest) - (let ([sender (communicator-sender communicator)]) - (apply fprintf sender - (string-append message-template "\r\n") - rest) - (flush-output sender))) - -;; parse-status-line : -;; string -> number x string - -(define (parse-status-line line) - (if (eof-object? line) - ((signal-error make-bad-status-line "eof instead of a status line") - line) - (let ([match (cdr (or (regexp-match #rx"([0-9]+) (.*)" line) - ((signal-error make-bad-status-line - "malformed status line: ~s" line) - line)))]) - (values (string->number (car match)) - (cadr match))))) - -;; get-one-line-from-server : -;; iport -> string - -(define (get-one-line-from-server server->client-port) - (read-line server->client-port 'return-linefeed)) - -;; get-single-line-response : -;; communicator -> number x string - -(define (get-single-line-response communicator) - (let* ([receiver (communicator-receiver communicator)] - [status-line (get-one-line-from-server receiver)]) - (parse-status-line status-line))) - -;; get-rest-of-multi-line-response : -;; communicator -> list (string) - -(define (get-rest-of-multi-line-response communicator) - (let ([receiver (communicator-receiver communicator)]) - (let loop ([r '()]) - (let ([l (get-one-line-from-server receiver)]) - (cond - [(eof-object? l) - ((signal-error make-premature-close - "port prematurely closed during multi-line response") - communicator)] - [(string=? l ".") (reverse r)] - [(string=? l "..") (loop (cons "." r))] - [else (loop (cons l r))]))))) - -;; get-multi-line-response : -;; communicator -> number x string x list (string) - -;; -- The returned values are the status code, the rest of the status -;; response line, and the remaining lines. - -(define (get-multi-line-response communicator) - (let* ([receiver (communicator-receiver communicator)] - [status-line (get-one-line-from-server receiver)]) - (let-values ([(code rest-of-line) - (parse-status-line status-line)]) - (values code rest-of-line (get-rest-of-multi-line-response communicator))))) - -;; open-news-group : -;; communicator x string -> number x number x number - -;; -- The returned values are the number of articles, the first -;; article number, and the last article number for that group. - -(define (open-news-group communicator group-name) - (send-to-server communicator "GROUP ~a" group-name) - (let-values ([(code rest-of-line) - (get-single-line-response communicator)]) - (case code - [(211) - (let ([match (map string->number - (cdr - (or (regexp-match #rx"([0-9]+) ([0-9]+) ([0-9]+)" rest-of-line) - ((signal-error make-bad-newsgroup-line - "malformed newsgroup open response: ~s" - rest-of-line) - rest-of-line))))]) - (let ([number-of-articles (car match)] - [first-article-number (cadr match)] - [last-article-number (caddr match)]) - (values number-of-articles - first-article-number - last-article-number)))] - [(411) - ((signal-error make-non-existent-group - "group ~s does not exist on server ~s" - group-name (communicator-server communicator)) - group-name)] - [else - ((signal-error make-unexpected-response - "unexpected group opening response: ~s" code) - code rest-of-line)]))) - -;; generic-message-command : -;; string x number -> communicator x (number U string) -> list (string) - -(define (generic-message-command command ok-code) - (lambda (communicator message-index) - (send-to-server communicator (string-append command " ~a") - (if (number? message-index) - (number->string message-index) - message-index)) - (let-values ([(code response) - (get-single-line-response communicator)]) - (if (= code ok-code) - (get-rest-of-multi-line-response communicator) - (case code - [(423) - ((signal-error make-article-not-in-group - "article id ~s not in group" message-index) - message-index)] - [(412) - ((signal-error make-no-group-selected - "no group selected"))] - [(430) - ((signal-error make-article-not-found - "no article id ~s found" message-index) - message-index)] - [else - ((signal-error make-unexpected-response - "unexpected message access response: ~s" code) - code response)]))))) - -;; head-of-message : -;; communicator x (number U string) -> list (string) - -(define head-of-message - (generic-message-command "HEAD" 221)) - -;; body-of-message : -;; communicator x (number U string) -> list (string) - -(define body-of-message - (generic-message-command "BODY" 222)) - -;; newnews-since : -;; communicator x (number U string) -> list (string) - -(define newnews-since - (generic-message-command "NEWNEWS" 230)) - -;; make-desired-header : -;; string -> desired - -(define (make-desired-header raw-header) - (regexp - (string-append - "^" - (list->string - (apply append - (map (lambda (c) - (cond - [(char-lower-case? c) - (list #\[ (char-upcase c) c #\])] - [(char-upper-case? c) - (list #\[ c (char-downcase c) #\])] - [else - (list c)])) - (string->list raw-header)))) - ":"))) - -;; extract-desired-headers : -;; list (string) x list (desired) -> list (string) - -(define (extract-desired-headers headers desireds) - (filter (lambda (header) - (ormap (lambda (matcher) (regexp-match matcher header)) - desireds)) - headers)) +(provide nntp@) diff --git a/collects/net/nntp.rkt b/collects/net/nntp.rkt index 816aa5047d..da8ae8dfdb 100644 --- a/collects/net/nntp.rkt +++ b/collects/net/nntp.rkt @@ -1,6 +1,325 @@ #lang racket/base -(require racket/unit "nntp-sig.rkt" "nntp-unit.rkt") -(define-values/invoke-unit/infer nntp@) +(require racket/tcp) -(provide-signature-elements nntp^) +(provide (struct-out communicator) + connect-to-server connect-to-server* disconnect-from-server + authenticate-user open-news-group + head-of-message body-of-message + newnews-since generic-message-command + make-desired-header extract-desired-headers + + (struct-out nntp) + (struct-out unexpected-response) + (struct-out bad-status-line) + (struct-out premature-close) + (struct-out bad-newsgroup-line) + (struct-out non-existent-group) + (struct-out article-not-in-group) + (struct-out no-group-selected) + (struct-out article-not-found) + (struct-out authentication-rejected)) + +;; sender : oport +;; receiver : iport +;; server : string +;; port : number + +(define-struct communicator (sender receiver server port)) + +;; code : number +;; text : string +;; line : string +;; communicator : communicator +;; group : string +;; article : number + +(define-struct (nntp exn) ()) +(define-struct (unexpected-response nntp) (code text)) +(define-struct (bad-status-line nntp) (line)) +(define-struct (premature-close nntp) (communicator)) +(define-struct (bad-newsgroup-line nntp) (line)) +(define-struct (non-existent-group nntp) (group)) +(define-struct (article-not-in-group nntp) (article)) +(define-struct (no-group-selected nntp) ()) +(define-struct (article-not-found nntp) (article)) +(define-struct (authentication-rejected nntp) ()) + +;; signal-error : +;; (exn-args ... -> exn) x format-string x values ... -> +;; exn-args -> () + +;; - throws an exception + +(define (signal-error constructor format-string . args) + (lambda exn-args + (raise (apply constructor + (apply format format-string args) + (current-continuation-marks) + exn-args)))) + +;; default-nntpd-port-number : +;; number + +(define default-nntpd-port-number 119) + +;; connect-to-server*: +;; input-port output-port -> communicator + +(define connect-to-server* + (case-lambda + [(receiver sender) + (connect-to-server* receiver sender "unspecified" "unspecified")] + [(receiver sender server-name port-number) + (file-stream-buffer-mode sender 'line) + (let ([communicator (make-communicator sender receiver server-name + port-number)]) + (let-values ([(code response) + (get-single-line-response communicator)]) + (case code + [(200 201) communicator] + [else ((signal-error make-unexpected-response + "unexpected connection response: ~s ~s" + code response) + code response)])))])) + +;; connect-to-server : +;; string [x number] -> commnicator + +(define connect-to-server + (lambda (server-name (port-number default-nntpd-port-number)) + (let-values ([(receiver sender) + (tcp-connect server-name port-number)]) + (connect-to-server* receiver sender server-name port-number)))) + +;; close-communicator : +;; communicator -> () + +(define (close-communicator communicator) + (close-input-port (communicator-receiver communicator)) + (close-output-port (communicator-sender communicator))) + +;; disconnect-from-server : +;; communicator -> () + +(define (disconnect-from-server communicator) + (send-to-server communicator "QUIT") + (let-values ([(code response) + (get-single-line-response communicator)]) + (case code + [(205) + (close-communicator communicator)] + [else + ((signal-error make-unexpected-response + "unexpected dis-connect response: ~s ~s" + code response) + code response)]))) + +;; authenticate-user : +;; communicator x user-name x password -> () +;; the password is not used if the server does not ask for it. + +(define (authenticate-user communicator user password) + (define (reject code response) + ((signal-error make-authentication-rejected + "authentication rejected (~s ~s)" + code response))) + (define (unexpected code response) + ((signal-error make-unexpected-response + "unexpected response for authentication: ~s ~s" + code response) + code response)) + (send-to-server communicator "AUTHINFO USER ~a" user) + (let-values ([(code response) (get-single-line-response communicator)]) + (case code + [(281) (void)] ; server doesn't ask for a password + [(381) + (send-to-server communicator "AUTHINFO PASS ~a" password) + (let-values ([(code response) + (get-single-line-response communicator)]) + (case code + [(281) (void)] ; done + [(502) (reject code response)] + [else (unexpected code response)]))] + [(502) (reject code response)] + [else (reject code response) + (unexpected code response)]))) + +;; send-to-server : +;; communicator x format-string x list (values) -> () + +(define (send-to-server communicator message-template . rest) + (let ([sender (communicator-sender communicator)]) + (apply fprintf sender + (string-append message-template "\r\n") + rest) + (flush-output sender))) + +;; parse-status-line : +;; string -> number x string + +(define (parse-status-line line) + (if (eof-object? line) + ((signal-error make-bad-status-line "eof instead of a status line") + line) + (let ([match (cdr (or (regexp-match #rx"([0-9]+) (.*)" line) + ((signal-error make-bad-status-line + "malformed status line: ~s" line) + line)))]) + (values (string->number (car match)) + (cadr match))))) + +;; get-one-line-from-server : +;; iport -> string + +(define (get-one-line-from-server server->client-port) + (read-line server->client-port 'return-linefeed)) + +;; get-single-line-response : +;; communicator -> number x string + +(define (get-single-line-response communicator) + (let* ([receiver (communicator-receiver communicator)] + [status-line (get-one-line-from-server receiver)]) + (parse-status-line status-line))) + +;; get-rest-of-multi-line-response : +;; communicator -> list (string) + +(define (get-rest-of-multi-line-response communicator) + (let ([receiver (communicator-receiver communicator)]) + (let loop ([r '()]) + (let ([l (get-one-line-from-server receiver)]) + (cond + [(eof-object? l) + ((signal-error make-premature-close + "port prematurely closed during multi-line response") + communicator)] + [(string=? l ".") (reverse r)] + [(string=? l "..") (loop (cons "." r))] + [else (loop (cons l r))]))))) + +;; get-multi-line-response : +;; communicator -> number x string x list (string) + +;; -- The returned values are the status code, the rest of the status +;; response line, and the remaining lines. + +(define (get-multi-line-response communicator) + (let* ([receiver (communicator-receiver communicator)] + [status-line (get-one-line-from-server receiver)]) + (let-values ([(code rest-of-line) + (parse-status-line status-line)]) + (values code rest-of-line (get-rest-of-multi-line-response communicator))))) + +;; open-news-group : +;; communicator x string -> number x number x number + +;; -- The returned values are the number of articles, the first +;; article number, and the last article number for that group. + +(define (open-news-group communicator group-name) + (send-to-server communicator "GROUP ~a" group-name) + (let-values ([(code rest-of-line) + (get-single-line-response communicator)]) + (case code + [(211) + (let ([match (map string->number + (cdr + (or (regexp-match #rx"([0-9]+) ([0-9]+) ([0-9]+)" rest-of-line) + ((signal-error make-bad-newsgroup-line + "malformed newsgroup open response: ~s" + rest-of-line) + rest-of-line))))]) + (let ([number-of-articles (car match)] + [first-article-number (cadr match)] + [last-article-number (caddr match)]) + (values number-of-articles + first-article-number + last-article-number)))] + [(411) + ((signal-error make-non-existent-group + "group ~s does not exist on server ~s" + group-name (communicator-server communicator)) + group-name)] + [else + ((signal-error make-unexpected-response + "unexpected group opening response: ~s" code) + code rest-of-line)]))) + +;; generic-message-command : +;; string x number -> communicator x (number U string) -> list (string) + +(define (generic-message-command command ok-code) + (lambda (communicator message-index) + (send-to-server communicator (string-append command " ~a") + (if (number? message-index) + (number->string message-index) + message-index)) + (let-values ([(code response) + (get-single-line-response communicator)]) + (if (= code ok-code) + (get-rest-of-multi-line-response communicator) + (case code + [(423) + ((signal-error make-article-not-in-group + "article id ~s not in group" message-index) + message-index)] + [(412) + ((signal-error make-no-group-selected + "no group selected"))] + [(430) + ((signal-error make-article-not-found + "no article id ~s found" message-index) + message-index)] + [else + ((signal-error make-unexpected-response + "unexpected message access response: ~s" code) + code response)]))))) + +;; head-of-message : +;; communicator x (number U string) -> list (string) + +(define head-of-message + (generic-message-command "HEAD" 221)) + +;; body-of-message : +;; communicator x (number U string) -> list (string) + +(define body-of-message + (generic-message-command "BODY" 222)) + +;; newnews-since : +;; communicator x (number U string) -> list (string) + +(define newnews-since + (generic-message-command "NEWNEWS" 230)) + +;; make-desired-header : +;; string -> desired + +(define (make-desired-header raw-header) + (regexp + (string-append + "^" + (list->string + (apply append + (map (lambda (c) + (cond + [(char-lower-case? c) + (list #\[ (char-upcase c) c #\])] + [(char-upper-case? c) + (list #\[ c (char-downcase c) #\])] + [else + (list c)])) + (string->list raw-header)))) + ":"))) + +;; extract-desired-headers : +;; list (string) x list (desired) -> list (string) + +(define (extract-desired-headers headers desireds) + (filter (lambda (header) + (ormap (lambda (matcher) (regexp-match matcher header)) + desireds)) + headers)) diff --git a/collects/net/scribblings/nntp.scrbl b/collects/net/scribblings/nntp.scrbl index d63ceca3c2..dbace6999d 100644 --- a/collects/net/scribblings/nntp.scrbl +++ b/collects/net/scribblings/nntp.scrbl @@ -135,6 +135,10 @@ Raised when the server reject an authentication attempt.} @section{NNTP Unit} +@margin-note{@racket[nntp@] and @racket[nntp^] are deprecated. +They exist for backward-compatibility and will likely be removed in +the future. New code should use the @racketmodname[net/nntp] module.} + @defmodule[net/nntp-unit] @defthing[nntp@ unit?]{ From 54deaac318f2bb76d9be56193aa4a1e83c1828f9 Mon Sep 17 00:00:00 2001 From: Jon Zeppieri Date: Mon, 29 Aug 2011 21:47:59 -0400 Subject: [PATCH 153/235] Moved `net/pop3' code from unit to module. --- collects/net/pop3-unit.rkt | 392 +------------------------- collects/net/pop3.rkt | 413 +++++++++++++++++++++++++++- collects/net/scribblings/pop3.scrbl | 4 + 3 files changed, 416 insertions(+), 393 deletions(-) diff --git a/collects/net/pop3-unit.rkt b/collects/net/pop3-unit.rkt index 204a0c0c9d..5c5cc7c8f0 100644 --- a/collects/net/pop3-unit.rkt +++ b/collects/net/pop3-unit.rkt @@ -1,390 +1,8 @@ -#lang racket/unit +#lang racket/base -(require racket/tcp "pop3-sig.rkt") +(require racket/unit + "pop3-sig.rkt" "pop3.rkt") -(import) -(export pop3^) +(define-unit-from-context pop3@ pop3^) -;; Implements RFC 1939, Post Office Protocol - Version 3, Myers & Rose - -;; sender : oport -;; receiver : iport -;; server : string -;; port : number -;; state : symbol = (disconnected, authorization, transaction) - -(define-struct communicator (sender receiver server port [state #:mutable])) - -(define-struct (pop3 exn) ()) -(define-struct (cannot-connect pop3) ()) -(define-struct (username-rejected pop3) ()) -(define-struct (password-rejected pop3) ()) -(define-struct (not-ready-for-transaction pop3) (communicator)) -(define-struct (not-given-headers pop3) (communicator message)) -(define-struct (illegal-message-number pop3) (communicator message)) -(define-struct (cannot-delete-message exn) (communicator message)) -(define-struct (disconnect-not-quiet pop3) (communicator)) -(define-struct (malformed-server-response pop3) (communicator)) - -;; signal-error : -;; (exn-args ... -> exn) x format-string x values ... -> -;; exn-args -> () - -(define (signal-error constructor format-string . args) - (lambda exn-args - (raise (apply constructor - (apply format format-string args) - (current-continuation-marks) - exn-args)))) - -;; signal-malformed-response-error : -;; exn-args -> () - -;; -- in practice, it takes only one argument: a communicator. - -(define signal-malformed-response-error - (signal-error make-malformed-server-response - "malformed response from server")) - -;; confirm-transaction-mode : -;; communicator x string -> () - -;; -- signals an error otherwise. - -(define (confirm-transaction-mode communicator error-message) - (unless (eq? (communicator-state communicator) 'transaction) - ((signal-error make-not-ready-for-transaction error-message) - communicator))) - -;; default-pop-port-number : -;; number - -(define default-pop-port-number 110) - -(define-struct server-responses ()) -(define-struct (+ok server-responses) ()) -(define-struct (-err server-responses) ()) - -;; connect-to-server*: -;; input-port output-port -> communicator - -(define connect-to-server* - (case-lambda - [(receiver sender) (connect-to-server* receiver sender "unspecified" "unspecified")] - [(receiver sender server-name port-number) - (let ([communicator (make-communicator sender receiver server-name port-number - 'authorization)]) - (let ([response (get-status-response/basic communicator)]) - (cond - [(+ok? response) communicator] - [(-err? response) - ((signal-error make-cannot-connect - "cannot connect to ~a on port ~a" - server-name port-number))])))])) - -;; connect-to-server : -;; string [x number] -> communicator - -(define connect-to-server - (lambda (server-name (port-number default-pop-port-number)) - (let-values ([(receiver sender) (tcp-connect server-name port-number)]) - (connect-to-server* receiver sender server-name port-number)))) - -;; authenticate/plain-text : -;; string x string x communicator -> () - -;; -- if authentication succeeds, sets the communicator's state to -;; transaction. - -(define (authenticate/plain-text username password communicator) - (let ([sender (communicator-sender communicator)]) - (send-to-server communicator "USER ~a" username) - (let ([status (get-status-response/basic communicator)]) - (cond - [(+ok? status) - (send-to-server communicator "PASS ~a" password) - (let ([status (get-status-response/basic communicator)]) - (cond - [(+ok? status) - (set-communicator-state! communicator 'transaction)] - [(-err? status) - ((signal-error make-password-rejected - "password was rejected"))]))] - [(-err? status) - ((signal-error make-username-rejected - "username was rejected"))])))) - -;; get-mailbox-status : -;; communicator -> number x number - -;; -- returns number of messages and number of octets. - -(define (get-mailbox-status communicator) - (confirm-transaction-mode - communicator - "cannot get mailbox status unless in transaction mode") - (send-to-server communicator "STAT") - (apply values - (map string->number - (let-values ([(status result) - (get-status-response/match - communicator - #rx"([0-9]+) ([0-9]+)" - #f)]) - result)))) - -;; get-message/complete : -;; communicator x number -> list (string) x list (string) - -(define (get-message/complete communicator message) - (confirm-transaction-mode - communicator - "cannot get message headers unless in transaction state") - (send-to-server communicator "RETR ~a" message) - (let ([status (get-status-response/basic communicator)]) - (cond - [(+ok? status) - (split-header/body (get-multi-line-response communicator))] - [(-err? status) - ((signal-error make-illegal-message-number - "not given message ~a" message) - communicator message)]))) - -;; get-message/headers : -;; communicator x number -> list (string) - -(define (get-message/headers communicator message) - (confirm-transaction-mode - communicator - "cannot get message headers unless in transaction state") - (send-to-server communicator "TOP ~a 0" message) - (let ([status (get-status-response/basic communicator)]) - (cond - [(+ok? status) - (let-values ([(headers body) - (split-header/body - (get-multi-line-response communicator))]) - headers)] - [(-err? status) - ((signal-error make-not-given-headers - "not given headers to message ~a" message) - communicator message)]))) - -;; get-message/body : -;; communicator x number -> list (string) - -(define (get-message/body communicator message) - (let-values ([(headers body) (get-message/complete communicator message)]) - body)) - -;; split-header/body : -;; list (string) -> list (string) x list (string) - -;; -- returns list of headers and list of body lines. - -(define (split-header/body lines) - (let loop ([lines lines] [header null]) - (if (null? lines) - (values (reverse header) null) - (let ([first (car lines)] - [rest (cdr lines)]) - (if (string=? first "") - (values (reverse header) rest) - (loop rest (cons first header))))))) - -;; delete-message : -;; communicator x number -> () - -(define (delete-message communicator message) - (confirm-transaction-mode - communicator - "cannot delete message unless in transaction state") - (send-to-server communicator "DELE ~a" message) - (let ([status (get-status-response/basic communicator)]) - (cond - [(-err? status) - ((signal-error make-cannot-delete-message - "no message numbered ~a available to be deleted" message) - communicator message)] - [(+ok? status) - 'deleted]))) - -;; regexp for UIDL responses - -(define uidl-regexp #rx"([0-9]+) (.*)") - -;; get-unique-id/single : -;; communicator x number -> string - -(define (get-unique-id/single communicator message) - (confirm-transaction-mode - communicator - "cannot get unique message id unless in transaction state") - (send-to-server communicator "UIDL ~a" message) - (let-values ([(status result) - (get-status-response/match communicator uidl-regexp ".*")]) - ;; The server response is of the form - ;; +OK 2 QhdPYR:00WBw1Ph7x7 - (cond - [(-err? status) - ((signal-error make-illegal-message-number - "no message numbered ~a available for unique id" message) - communicator message)] - [(+ok? status) - (cadr result)]))) - -;; get-unique-id/all : -;; communicator -> list(number x string) - -(define (get-unique-id/all communicator) - (confirm-transaction-mode communicator - "cannot get unique message ids unless in transaction state") - (send-to-server communicator "UIDL") - (let ([status (get-status-response/basic communicator)]) - ;; The server response is of the form - ;; +OK - ;; 1 whqtswO00WBw418f9t5JxYwZ - ;; 2 QhdPYR:00WBw1Ph7x7 - ;; . - (map (lambda (l) - (let ([m (regexp-match uidl-regexp l)]) - (cons (string->number (cadr m)) (caddr m)))) - (get-multi-line-response communicator)))) - -;; close-communicator : -;; communicator -> () - -(define (close-communicator communicator) - (close-input-port (communicator-receiver communicator)) - (close-output-port (communicator-sender communicator))) - -;; disconnect-from-server : -;; communicator -> () - -(define (disconnect-from-server communicator) - (send-to-server communicator "QUIT") - (set-communicator-state! communicator 'disconnected) - (let ([response (get-status-response/basic communicator)]) - (close-communicator communicator) - (cond - [(+ok? response) (void)] - [(-err? response) - ((signal-error make-disconnect-not-quiet - "got error status upon disconnect") - communicator)]))) - -;; send-to-server : -;; communicator x format-string x list (values) -> () - -(define (send-to-server communicator message-template . rest) - (apply fprintf (communicator-sender communicator) - (string-append message-template "\r\n") - rest) - (flush-output (communicator-sender communicator))) - -;; get-one-line-from-server : -;; iport -> string - -(define (get-one-line-from-server server->client-port) - (read-line server->client-port 'return-linefeed)) - -;; get-server-status-response : -;; communicator -> server-responses x string - -;; -- provides the low-level functionality of checking for +OK -;; and -ERR, returning an appropriate structure, and returning the -;; rest of the status response as a string to be used for further -;; parsing, if necessary. - -(define (get-server-status-response communicator) - (let* ([receiver (communicator-receiver communicator)] - [status-line (get-one-line-from-server receiver)] - [r (regexp-match #rx"^\\+OK(.*)" status-line)]) - (if r - (values (make-+ok) (cadr r)) - (let ([r (regexp-match #rx"^\\-ERR(.*)" status-line)]) - (if r - (values (make--err) (cadr r)) - (signal-malformed-response-error communicator)))))) - -;; get-status-response/basic : -;; communicator -> server-responses - -;; -- when the only thing to determine is whether the response -;; was +OK or -ERR. - -(define (get-status-response/basic communicator) - (let-values ([(response rest) - (get-server-status-response communicator)]) - response)) - -;; get-status-response/match : -;; communicator x regexp x regexp -> (status x list (string)) - -;; -- when further parsing of the status response is necessary. -;; Strips off the car of response from regexp-match. - -(define (get-status-response/match communicator +regexp -regexp) - (let-values ([(response rest) - (get-server-status-response communicator)]) - (if (and +regexp (+ok? response)) - (let ([r (regexp-match +regexp rest)]) - (if r (values response (cdr r)) - (signal-malformed-response-error communicator))) - (if (and -regexp (-err? response)) - (let ([r (regexp-match -regexp rest)]) - (if r (values response (cdr r)) - (signal-malformed-response-error communicator))) - (signal-malformed-response-error communicator))))) - -;; get-multi-line-response : -;; communicator -> list (string) - -(define (get-multi-line-response communicator) - (let ([receiver (communicator-receiver communicator)]) - (let loop () - (let ([l (get-one-line-from-server receiver)]) - (cond - [(eof-object? l) - (signal-malformed-response-error communicator)] - [(string=? l ".") - '()] - [(and (> (string-length l) 1) - (char=? (string-ref l 0) #\.)) - (cons (substring l 1 (string-length l)) (loop))] - [else - (cons l (loop))]))))) - -;; make-desired-header : -;; string -> desired - -(define (make-desired-header raw-header) - (regexp - (string-append - "^" - (list->string - (apply append - (map (lambda (c) - (cond - [(char-lower-case? c) - (list #\[ (char-upcase c) c #\])] - [(char-upper-case? c) - (list #\[ c (char-downcase c) #\])] - [else - (list c)])) - (string->list raw-header)))) - ":"))) - -;; extract-desired-headers : -;; list (string) x list (desired) -> list (string) - -(define (extract-desired-headers headers desireds) - (let loop ([headers headers]) - (if (null? headers) null - (let ([first (car headers)] - [rest (cdr headers)]) - (if (ormap (lambda (matcher) - (regexp-match matcher first)) - desireds) - (cons first (loop rest)) - (loop rest)))))) +(provide pop3@) diff --git a/collects/net/pop3.rkt b/collects/net/pop3.rkt index 099a9fa14a..2142b8cd8d 100644 --- a/collects/net/pop3.rkt +++ b/collects/net/pop3.rkt @@ -1,13 +1,9 @@ #lang racket/base -(require racket/unit "pop3-sig.rkt" "pop3-unit.rkt") -(define-values/invoke-unit/infer pop3@) - -(provide-signature-elements pop3^) +;; Implements RFC 1939, Post Office Protocol - Version 3, Myers & Rose #| - -> (require-library "pop3.rkt" "net") +> (require net/pop3) > (define c (connect-to-server "cs.rice.edu")) > (authenticate/plain-text "scheme" "********" c) > (get-mailbox-status c) @@ -28,3 +24,408 @@ ("some body" "text" "goes" "." "here" "." "") > (disconnect-from-server c) |# + +(require racket/tcp) + +(provide (struct-out communicator) + connect-to-server connect-to-server* disconnect-from-server + authenticate/plain-text + get-mailbox-status + get-message/complete get-message/headers get-message/body + delete-message + get-unique-id/single get-unique-id/all + + make-desired-header extract-desired-headers + + (struct-out pop3) + (struct-out cannot-connect) + (struct-out username-rejected) + (struct-out password-rejected) + (struct-out not-ready-for-transaction) + (struct-out not-given-headers) + (struct-out illegal-message-number) + (struct-out cannot-delete-message) + (struct-out disconnect-not-quiet) + (struct-out malformed-server-response)) + +;; sender : oport +;; receiver : iport +;; server : string +;; port : number +;; state : symbol = (disconnected, authorization, transaction) + +(define-struct communicator (sender receiver server port [state #:mutable])) + +(define-struct (pop3 exn) ()) +(define-struct (cannot-connect pop3) ()) +(define-struct (username-rejected pop3) ()) +(define-struct (password-rejected pop3) ()) +(define-struct (not-ready-for-transaction pop3) (communicator)) +(define-struct (not-given-headers pop3) (communicator message)) +(define-struct (illegal-message-number pop3) (communicator message)) +(define-struct (cannot-delete-message exn) (communicator message)) +(define-struct (disconnect-not-quiet pop3) (communicator)) +(define-struct (malformed-server-response pop3) (communicator)) + +;; signal-error : +;; (exn-args ... -> exn) x format-string x values ... -> +;; exn-args -> () + +(define (signal-error constructor format-string . args) + (lambda exn-args + (raise (apply constructor + (apply format format-string args) + (current-continuation-marks) + exn-args)))) + +;; signal-malformed-response-error : +;; exn-args -> () + +;; -- in practice, it takes only one argument: a communicator. + +(define signal-malformed-response-error + (signal-error make-malformed-server-response + "malformed response from server")) + +;; confirm-transaction-mode : +;; communicator x string -> () + +;; -- signals an error otherwise. + +(define (confirm-transaction-mode communicator error-message) + (unless (eq? (communicator-state communicator) 'transaction) + ((signal-error make-not-ready-for-transaction error-message) + communicator))) + +;; default-pop-port-number : +;; number + +(define default-pop-port-number 110) + +(define-struct server-responses ()) +(define-struct (+ok server-responses) ()) +(define-struct (-err server-responses) ()) + +;; connect-to-server*: +;; input-port output-port -> communicator + +(define connect-to-server* + (case-lambda + [(receiver sender) (connect-to-server* receiver sender "unspecified" "unspecified")] + [(receiver sender server-name port-number) + (let ([communicator (make-communicator sender receiver server-name port-number + 'authorization)]) + (let ([response (get-status-response/basic communicator)]) + (cond + [(+ok? response) communicator] + [(-err? response) + ((signal-error make-cannot-connect + "cannot connect to ~a on port ~a" + server-name port-number))])))])) + +;; connect-to-server : +;; string [x number] -> communicator + +(define connect-to-server + (lambda (server-name (port-number default-pop-port-number)) + (let-values ([(receiver sender) (tcp-connect server-name port-number)]) + (connect-to-server* receiver sender server-name port-number)))) + +;; authenticate/plain-text : +;; string x string x communicator -> () + +;; -- if authentication succeeds, sets the communicator's state to +;; transaction. + +(define (authenticate/plain-text username password communicator) + (let ([sender (communicator-sender communicator)]) + (send-to-server communicator "USER ~a" username) + (let ([status (get-status-response/basic communicator)]) + (cond + [(+ok? status) + (send-to-server communicator "PASS ~a" password) + (let ([status (get-status-response/basic communicator)]) + (cond + [(+ok? status) + (set-communicator-state! communicator 'transaction)] + [(-err? status) + ((signal-error make-password-rejected + "password was rejected"))]))] + [(-err? status) + ((signal-error make-username-rejected + "username was rejected"))])))) + +;; get-mailbox-status : +;; communicator -> number x number + +;; -- returns number of messages and number of octets. + +(define (get-mailbox-status communicator) + (confirm-transaction-mode + communicator + "cannot get mailbox status unless in transaction mode") + (send-to-server communicator "STAT") + (apply values + (map string->number + (let-values ([(status result) + (get-status-response/match + communicator + #rx"([0-9]+) ([0-9]+)" + #f)]) + result)))) + +;; get-message/complete : +;; communicator x number -> list (string) x list (string) + +(define (get-message/complete communicator message) + (confirm-transaction-mode + communicator + "cannot get message headers unless in transaction state") + (send-to-server communicator "RETR ~a" message) + (let ([status (get-status-response/basic communicator)]) + (cond + [(+ok? status) + (split-header/body (get-multi-line-response communicator))] + [(-err? status) + ((signal-error make-illegal-message-number + "not given message ~a" message) + communicator message)]))) + +;; get-message/headers : +;; communicator x number -> list (string) + +(define (get-message/headers communicator message) + (confirm-transaction-mode + communicator + "cannot get message headers unless in transaction state") + (send-to-server communicator "TOP ~a 0" message) + (let ([status (get-status-response/basic communicator)]) + (cond + [(+ok? status) + (let-values ([(headers body) + (split-header/body + (get-multi-line-response communicator))]) + headers)] + [(-err? status) + ((signal-error make-not-given-headers + "not given headers to message ~a" message) + communicator message)]))) + +;; get-message/body : +;; communicator x number -> list (string) + +(define (get-message/body communicator message) + (let-values ([(headers body) (get-message/complete communicator message)]) + body)) + +;; split-header/body : +;; list (string) -> list (string) x list (string) + +;; -- returns list of headers and list of body lines. + +(define (split-header/body lines) + (let loop ([lines lines] [header null]) + (if (null? lines) + (values (reverse header) null) + (let ([first (car lines)] + [rest (cdr lines)]) + (if (string=? first "") + (values (reverse header) rest) + (loop rest (cons first header))))))) + +;; delete-message : +;; communicator x number -> () + +(define (delete-message communicator message) + (confirm-transaction-mode + communicator + "cannot delete message unless in transaction state") + (send-to-server communicator "DELE ~a" message) + (let ([status (get-status-response/basic communicator)]) + (cond + [(-err? status) + ((signal-error make-cannot-delete-message + "no message numbered ~a available to be deleted" message) + communicator message)] + [(+ok? status) + 'deleted]))) + +;; regexp for UIDL responses + +(define uidl-regexp #rx"([0-9]+) (.*)") + +;; get-unique-id/single : +;; communicator x number -> string + +(define (get-unique-id/single communicator message) + (confirm-transaction-mode + communicator + "cannot get unique message id unless in transaction state") + (send-to-server communicator "UIDL ~a" message) + (let-values ([(status result) + (get-status-response/match communicator uidl-regexp ".*")]) + ;; The server response is of the form + ;; +OK 2 QhdPYR:00WBw1Ph7x7 + (cond + [(-err? status) + ((signal-error make-illegal-message-number + "no message numbered ~a available for unique id" message) + communicator message)] + [(+ok? status) + (cadr result)]))) + +;; get-unique-id/all : +;; communicator -> list(number x string) + +(define (get-unique-id/all communicator) + (confirm-transaction-mode communicator + "cannot get unique message ids unless in transaction state") + (send-to-server communicator "UIDL") + (let ([status (get-status-response/basic communicator)]) + ;; The server response is of the form + ;; +OK + ;; 1 whqtswO00WBw418f9t5JxYwZ + ;; 2 QhdPYR:00WBw1Ph7x7 + ;; . + (map (lambda (l) + (let ([m (regexp-match uidl-regexp l)]) + (cons (string->number (cadr m)) (caddr m)))) + (get-multi-line-response communicator)))) + +;; close-communicator : +;; communicator -> () + +(define (close-communicator communicator) + (close-input-port (communicator-receiver communicator)) + (close-output-port (communicator-sender communicator))) + +;; disconnect-from-server : +;; communicator -> () + +(define (disconnect-from-server communicator) + (send-to-server communicator "QUIT") + (set-communicator-state! communicator 'disconnected) + (let ([response (get-status-response/basic communicator)]) + (close-communicator communicator) + (cond + [(+ok? response) (void)] + [(-err? response) + ((signal-error make-disconnect-not-quiet + "got error status upon disconnect") + communicator)]))) + +;; send-to-server : +;; communicator x format-string x list (values) -> () + +(define (send-to-server communicator message-template . rest) + (apply fprintf (communicator-sender communicator) + (string-append message-template "\r\n") + rest) + (flush-output (communicator-sender communicator))) + +;; get-one-line-from-server : +;; iport -> string + +(define (get-one-line-from-server server->client-port) + (read-line server->client-port 'return-linefeed)) + +;; get-server-status-response : +;; communicator -> server-responses x string + +;; -- provides the low-level functionality of checking for +OK +;; and -ERR, returning an appropriate structure, and returning the +;; rest of the status response as a string to be used for further +;; parsing, if necessary. + +(define (get-server-status-response communicator) + (let* ([receiver (communicator-receiver communicator)] + [status-line (get-one-line-from-server receiver)] + [r (regexp-match #rx"^\\+OK(.*)" status-line)]) + (if r + (values (make-+ok) (cadr r)) + (let ([r (regexp-match #rx"^\\-ERR(.*)" status-line)]) + (if r + (values (make--err) (cadr r)) + (signal-malformed-response-error communicator)))))) + +;; get-status-response/basic : +;; communicator -> server-responses + +;; -- when the only thing to determine is whether the response +;; was +OK or -ERR. + +(define (get-status-response/basic communicator) + (let-values ([(response rest) + (get-server-status-response communicator)]) + response)) + +;; get-status-response/match : +;; communicator x regexp x regexp -> (status x list (string)) + +;; -- when further parsing of the status response is necessary. +;; Strips off the car of response from regexp-match. + +(define (get-status-response/match communicator +regexp -regexp) + (let-values ([(response rest) + (get-server-status-response communicator)]) + (if (and +regexp (+ok? response)) + (let ([r (regexp-match +regexp rest)]) + (if r (values response (cdr r)) + (signal-malformed-response-error communicator))) + (if (and -regexp (-err? response)) + (let ([r (regexp-match -regexp rest)]) + (if r (values response (cdr r)) + (signal-malformed-response-error communicator))) + (signal-malformed-response-error communicator))))) + +;; get-multi-line-response : +;; communicator -> list (string) + +(define (get-multi-line-response communicator) + (let ([receiver (communicator-receiver communicator)]) + (let loop () + (let ([l (get-one-line-from-server receiver)]) + (cond + [(eof-object? l) + (signal-malformed-response-error communicator)] + [(string=? l ".") + '()] + [(and (> (string-length l) 1) + (char=? (string-ref l 0) #\.)) + (cons (substring l 1 (string-length l)) (loop))] + [else + (cons l (loop))]))))) + +;; make-desired-header : +;; string -> desired + +(define (make-desired-header raw-header) + (regexp + (string-append + "^" + (list->string + (apply append + (map (lambda (c) + (cond + [(char-lower-case? c) + (list #\[ (char-upcase c) c #\])] + [(char-upper-case? c) + (list #\[ c (char-downcase c) #\])] + [else + (list c)])) + (string->list raw-header)))) + ":"))) + +;; extract-desired-headers : +;; list (string) x list (desired) -> list (string) + +(define (extract-desired-headers headers desireds) + (let loop ([headers headers]) + (if (null? headers) null + (let ([first (car headers)] + [rest (cdr headers)]) + (if (ormap (lambda (matcher) + (regexp-match matcher first)) + desireds) + (cons first (loop rest)) + (loop rest)))))) diff --git a/collects/net/scribblings/pop3.scrbl b/collects/net/scribblings/pop3.scrbl index 99b3669c32..9a78f86769 100644 --- a/collects/net/scribblings/pop3.scrbl +++ b/collects/net/scribblings/pop3.scrbl @@ -184,6 +184,10 @@ Raised when the server produces a malformed response.} @section{POP3 Unit} +@margin-note{@racket[pop3@] and @racket[pop3^] are deprecated. +They exist for backward-compatibility and will likely be removed in +the future. New code should use the @racketmodname[net/pop3] module.} + @defmodule[net/pop3-unit] @defthing[pop3@ unit?]{ From d034297c768145a90f5d7527e557fcb6f892a62e Mon Sep 17 00:00:00 2001 From: Jon Zeppieri Date: Mon, 29 Aug 2011 21:51:41 -0400 Subject: [PATCH 154/235] Moved `net/qp' code from unit to module. --- collects/net/qp-unit.rkt | 167 +----------------------------- collects/net/qp.rkt | 149 ++++++++++++++++++++++++-- collects/net/scribblings/qp.scrbl | 4 + 3 files changed, 151 insertions(+), 169 deletions(-) diff --git a/collects/net/qp-unit.rkt b/collects/net/qp-unit.rkt index 8cbc457456..1d7f2ebd3e 100644 --- a/collects/net/qp-unit.rkt +++ b/collects/net/qp-unit.rkt @@ -1,165 +1,8 @@ -;;; -;;; ---- Quoted Printable Implementation -;;; -;;; Copyright (C) 2002 by PLT. -;;; Copyright (C) 2001 by Francisco Solsona. -;;; -;;; This file was part of mime-plt. +#lang racket/base -;;; mime-plt is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Lesser General Public -;;; License as published by the Free Software Foundation; either -;;; version 2.1 of the License, or (at your option) any later version. +(require racket/unit + "qp-sig.rkt" "qp.rkt") -;;; mime-plt is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. +(define-unit-from-context qp@ qp^) -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with mime-plt; if not, write to the Free Software -;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA -;;; 02110-1301 USA. - -;;; Author: Francisco Solsona -;; -;; -;; Commentary: - -#lang racket/unit - -(require "qp-sig.rkt") - -(import) -(export qp^) - -;; Exceptions: -;; String or input-port expected: -(define-struct qp-error ()) -(define-struct (qp-wrong-input qp-error) ()) -(define-struct (qp-wrong-line-size qp-error) (size)) - -;; qp-encode : bytes -> bytes -;; returns the quoted printable representation of STR. -(define (qp-encode str) - (let ([out (open-output-bytes)]) - (qp-encode-stream (open-input-bytes str) out #"\r\n") - (get-output-bytes out))) - -;; qp-decode : string -> string -;; returns STR unqp. -(define (qp-decode str) - (let ([out (open-output-bytes)]) - (qp-decode-stream (open-input-bytes str) out) - (get-output-bytes out))) - -(define (qp-decode-stream in out) - (let loop ([ch (read-byte in)]) - (unless (eof-object? ch) - (case ch - [(61) ;; A "=", which is quoted-printable stuff - (let ([next (read-byte in)]) - (cond - [(eq? next 10) - ;; Soft-newline -- drop it - (void)] - [(eq? next 13) - ;; Expect a newline for a soft CRLF... - (let ([next-next (read-byte in)]) - (if (eq? next-next 10) - ;; Good. - (loop (read-byte in)) - ;; Not a LF? Well, ok. - (loop next-next)))] - [(hex-digit? next) - (let ([next-next (read-byte in)]) - (cond [(eof-object? next-next) - (warning "Illegal qp sequence: `=~a'" next) - (display "=" out) - (display next out)] - [(hex-digit? next-next) - ;; qp-encoded - (write-byte (hex-bytes->byte next next-next) - out)] - [else - (warning "Illegal qp sequence: `=~a~a'" next next-next) - (write-byte 61 out) - (write-byte next out) - (write-byte next-next out)]))] - [else - ;; Warning: invalid - (warning "Illegal qp sequence: `=~a'" next) - (write-byte 61 out) - (write-byte next out)]) - (loop (read-byte in)))] - [else - (write-byte ch out) - (loop (read-byte in))])))) - -(define (warning msg . args) - (when #f - (fprintf (current-error-port) - (apply format msg args)) - (newline (current-error-port)))) - -(define (hex-digit? i) - (vector-ref hex-values i)) - -(define (hex-bytes->byte b1 b2) - (+ (* 16 (vector-ref hex-values b1)) - (vector-ref hex-values b2))) - -(define (write-hex-bytes byte p) - (write-byte 61 p) - (write-byte (vector-ref hex-bytes (arithmetic-shift byte -4)) p) - (write-byte (vector-ref hex-bytes (bitwise-and byte 15)) p)) - -(define (qp-encode-stream in out [newline-string #"\n"]) - (let loop ([col 0]) - (if (= col 75) - (begin - ;; Soft newline: - (write-byte 61 out) - (display newline-string out) - (loop 0)) - (let ([i (read-byte in)]) - (cond - [(eof-object? i) (void)] - [(or (= i 10) (= i 13)) - (write-byte i out) - (loop 0)] - [(or (<= 33 i 60) (<= 62 i 126) - (and (or (= i 32) (= i 9)) - (not (let ([next (peek-byte in)]) - (or (eof-object? next) (= next 10) (= next 13)))))) - ;; single-byte mode: - (write-byte i out) - (loop (add1 col))] - [(>= col 73) - ;; need a soft newline first - (write-byte 61 out) - (display newline-string out) - ;; now the octect - (write-hex-bytes i out) - (loop 3)] - [else - ;; an octect - (write-hex-bytes i out) - (loop (+ col 3))]))))) - -;; Tables -(define hex-values (make-vector 256 #f)) -(define hex-bytes (make-vector 16)) -(let loop ([i 0]) - (unless (= i 10) - (vector-set! hex-values (+ i 48) i) - (vector-set! hex-bytes i (+ i 48)) - (loop (add1 i)))) -(let loop ([i 0]) - (unless (= i 6) - (vector-set! hex-values (+ i 65) (+ 10 i)) - (vector-set! hex-values (+ i 97) (+ 10 i)) - (vector-set! hex-bytes (+ 10 i) (+ i 65)) - (loop (add1 i)))) - -;;; qp-unit.rkt ends here +(provide qp@) diff --git a/collects/net/qp.rkt b/collects/net/qp.rkt index c5267fb6b1..7522a6c863 100644 --- a/collects/net/qp.rkt +++ b/collects/net/qp.rkt @@ -6,31 +6,166 @@ ;;; ;;; This file is part of mime-plt. -;;; mime-plt is free software; you can redistribute it and/or +;;; qp is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public ;;; License as published by the Free Software Foundation; either ;;; version 2.1 of the License, or (at your option) any later version. -;;; mime-plt is distributed in the hope that it will be useful, +;;; qp is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Lesser General Public License for more details. ;;; You should have received a copy of the GNU Lesser General Public -;;; License along with mime-plt; if not, write to the Free Software +;;; License along with qp; if not, write to the Free Software ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA ;;; 02110-1301 USA. ;;; Author: Francisco Solsona ;; -;; ;; Commentary: #lang racket/base -(require racket/unit "qp-sig.rkt" "qp-unit.rkt") -(define-values/invoke-unit/infer qp@) +(provide + ;; -- exceptions raised -- + (struct-out qp-error) + (struct-out qp-wrong-input) + (struct-out qp-wrong-line-size) -(provide-signature-elements qp^) + ;; -- qp methods -- + qp-encode + qp-decode + qp-encode-stream + qp-decode-stream) + +;; Exceptions: +;; String or input-port expected: +(define-struct qp-error ()) +(define-struct (qp-wrong-input qp-error) ()) +(define-struct (qp-wrong-line-size qp-error) (size)) + +;; qp-encode : bytes -> bytes +;; returns the quoted printable representation of STR. +(define (qp-encode str) + (let ([out (open-output-bytes)]) + (qp-encode-stream (open-input-bytes str) out #"\r\n") + (get-output-bytes out))) + +;; qp-decode : string -> string +;; returns STR unqp. +(define (qp-decode str) + (let ([out (open-output-bytes)]) + (qp-decode-stream (open-input-bytes str) out) + (get-output-bytes out))) + +(define (qp-decode-stream in out) + (let loop ([ch (read-byte in)]) + (unless (eof-object? ch) + (case ch + [(61) ;; A "=", which is quoted-printable stuff + (let ([next (read-byte in)]) + (cond + [(eq? next 10) + ;; Soft-newline -- drop it + (void)] + [(eq? next 13) + ;; Expect a newline for a soft CRLF... + (let ([next-next (read-byte in)]) + (if (eq? next-next 10) + ;; Good. + (loop (read-byte in)) + ;; Not a LF? Well, ok. + (loop next-next)))] + [(hex-digit? next) + (let ([next-next (read-byte in)]) + (cond [(eof-object? next-next) + (warning "Illegal qp sequence: `=~a'" next) + (display "=" out) + (display next out)] + [(hex-digit? next-next) + ;; qp-encoded + (write-byte (hex-bytes->byte next next-next) + out)] + [else + (warning "Illegal qp sequence: `=~a~a'" next next-next) + (write-byte 61 out) + (write-byte next out) + (write-byte next-next out)]))] + [else + ;; Warning: invalid + (warning "Illegal qp sequence: `=~a'" next) + (write-byte 61 out) + (write-byte next out)]) + (loop (read-byte in)))] + [else + (write-byte ch out) + (loop (read-byte in))])))) + +(define (warning msg . args) + (when #f + (fprintf (current-error-port) + (apply format msg args)) + (newline (current-error-port)))) + +(define (hex-digit? i) + (vector-ref hex-values i)) + +(define (hex-bytes->byte b1 b2) + (+ (* 16 (vector-ref hex-values b1)) + (vector-ref hex-values b2))) + +(define (write-hex-bytes byte p) + (write-byte 61 p) + (write-byte (vector-ref hex-bytes (arithmetic-shift byte -4)) p) + (write-byte (vector-ref hex-bytes (bitwise-and byte 15)) p)) + +(define (qp-encode-stream in out [newline-string #"\n"]) + (let loop ([col 0]) + (if (= col 75) + (begin + ;; Soft newline: + (write-byte 61 out) + (display newline-string out) + (loop 0)) + (let ([i (read-byte in)]) + (cond + [(eof-object? i) (void)] + [(or (= i 10) (= i 13)) + (write-byte i out) + (loop 0)] + [(or (<= 33 i 60) (<= 62 i 126) + (and (or (= i 32) (= i 9)) + (not (let ([next (peek-byte in)]) + (or (eof-object? next) (= next 10) (= next 13)))))) + ;; single-byte mode: + (write-byte i out) + (loop (add1 col))] + [(>= col 73) + ;; need a soft newline first + (write-byte 61 out) + (display newline-string out) + ;; now the octect + (write-hex-bytes i out) + (loop 3)] + [else + ;; an octect + (write-hex-bytes i out) + (loop (+ col 3))]))))) + +;; Tables +(define hex-values (make-vector 256 #f)) +(define hex-bytes (make-vector 16)) +(let loop ([i 0]) + (unless (= i 10) + (vector-set! hex-values (+ i 48) i) + (vector-set! hex-bytes i (+ i 48)) + (loop (add1 i)))) +(let loop ([i 0]) + (unless (= i 6) + (vector-set! hex-values (+ i 65) (+ 10 i)) + (vector-set! hex-values (+ i 97) (+ 10 i)) + (vector-set! hex-bytes (+ 10 i) (+ i 65)) + (loop (add1 i)))) ;;; qp.rkt ends here diff --git a/collects/net/scribblings/qp.scrbl b/collects/net/scribblings/qp.scrbl index c5f0a6d608..18ef49e957 100644 --- a/collects/net/scribblings/qp.scrbl +++ b/collects/net/scribblings/qp.scrbl @@ -66,6 +66,10 @@ backward compatibility.} @section{Quoted-Printable Unit} +@margin-note{@racket[qp@] and @racket[qp^] are deprecated. +They exist for backward-compatibility and will likely be removed in +the future. New code should use the @racketmodname[net/qp] module.} + @defmodule[net/qp-unit] @defthing[qp@ unit?]{ From 9ab674fd0cf1d857534e402f7867cd54412c0dc8 Mon Sep 17 00:00:00 2001 From: Jon Zeppieri Date: Mon, 29 Aug 2011 21:53:26 -0400 Subject: [PATCH 155/235] Moved `net/sendmail' code from unit to module. --- collects/net/scribblings/sendmail.scrbl | 4 + collects/net/sendmail-unit.rkt | 121 +----------------------- collects/net/sendmail.rkt | 120 ++++++++++++++++++++++- 3 files changed, 126 insertions(+), 119 deletions(-) diff --git a/collects/net/scribblings/sendmail.scrbl b/collects/net/scribblings/sendmail.scrbl index cef43caa42..d034f15662 100644 --- a/collects/net/scribblings/sendmail.scrbl +++ b/collects/net/scribblings/sendmail.scrbl @@ -63,6 +63,10 @@ Raised when no mail recipients were specified for @section{Sendmail Unit} +@margin-note{@racket[sendmail@] and @racket[sendmail^] are deprecated. +They exist for backward-compatibility and will likely be removed in +the future. New code should use the @racketmodname[net/sendmail] module.} + @defmodule[net/sendmail-unit] @defthing[sendmail@ unit?]{ diff --git a/collects/net/sendmail-unit.rkt b/collects/net/sendmail-unit.rkt index bca94df243..2fd97068e9 100644 --- a/collects/net/sendmail-unit.rkt +++ b/collects/net/sendmail-unit.rkt @@ -1,119 +1,8 @@ -#lang racket/unit +#lang racket/base -(require racket/system "sendmail-sig.rkt") +(require racket/unit + "sendmail-sig.rkt" "sendmail.rkt") -(import) -(export sendmail^) +(define-unit-from-context sendmail@ sendmail^) -(define-struct (no-mail-recipients exn) ()) - -(define sendmail-search-path - '("/usr/lib" "/usr/sbin")) - -(define sendmail-program-file - (if (or (eq? (system-type) 'unix) - (eq? (system-type) 'macosx)) - (let loop ([paths sendmail-search-path]) - (if (null? paths) - (raise (make-exn:fail:unsupported - "unable to find sendmail on this Unix variant" - (current-continuation-marks))) - (let ([p (build-path (car paths) "sendmail")]) - (if (and (file-exists? p) - (memq 'execute (file-or-directory-permissions p))) - p - (loop (cdr paths)))))) - (raise (make-exn:fail:unsupported - "sendmail only available under Unix" - (current-continuation-marks))))) - -;; send-mail-message/port : -;; string x string x list (string) x list (string) x list (string) -;; [x list (string)] -> oport - -;; -- sender can be anything, though spoofing is not recommended. -;; The recipients must all be pure email addresses. Note that -;; everything is expected to follow RFC conventions. If any other -;; headers are specified, they are expected to be completely -;; formatted already. Clients are urged to use close-output-port on -;; the port returned by this procedure as soon as the necessary text -;; has been written, so that the sendmail process can complete. - -(define (send-mail-message/port - sender subject to-recipients cc-recipients bcc-recipients - . other-headers) - (when (and (null? to-recipients) (null? cc-recipients) - (null? bcc-recipients)) - (raise (make-no-mail-recipients - "no mail recipients were specified" - (current-continuation-marks)))) - (let ([return (apply process* sendmail-program-file "-i" - (append to-recipients cc-recipients bcc-recipients))]) - (let ([reader (car return)] - [writer (cadr return)] - [pid (caddr return)] - [error-reader (cadddr return)]) - (close-input-port reader) - (close-input-port error-reader) - (fprintf writer "From: ~a\n" sender) - (letrec ([write-recipient-header - (lambda (header-string recipients) - (let ([header-space - (+ (string-length header-string) 2)]) - (fprintf writer "~a: " header-string) - (let loop ([to recipients] [indent header-space]) - (if (null? to) - (newline writer) - (let ([first (car to)] - [rest (cdr to)]) - (let ([len (string-length first)]) - (if (>= (+ len indent) 80) - (begin - (fprintf writer - (if (null? rest) - "\n ~a" - "\n ~a, ") - first) - (loop (cdr to) - (+ len header-space 2))) - (begin - (fprintf writer - (if (null? rest) - "~a " - "~a, ") - first) - (loop (cdr to) - (+ len indent 2))))))))))]) - (write-recipient-header "To" to-recipients) - (unless (null? cc-recipients) - (write-recipient-header "CC" cc-recipients))) - (fprintf writer "Subject: ~a\n" subject) - (fprintf writer "X-Mailer: Racket (racket-lang.org)\n") - (for-each (lambda (s) - (display s writer) - (newline writer)) - other-headers) - (newline writer) - writer))) - -;; send-mail-message : -;; string x string x list (string) x list (string) x list (string) x -;; list (string) [x list (string)] -> () - -;; -- sender can be anything, though spoofing is not recommended. The -;; recipients must all be pure email addresses. The text is expected -;; to be pre-formatted. Note that everything is expected to follow -;; RFC conventions. If any other headers are specified, they are -;; expected to be completely formatted already. - -(define (send-mail-message - sender subject to-recipients cc-recipients bcc-recipients text - . other-headers) - (let ([writer (apply send-mail-message/port sender subject - to-recipients cc-recipients bcc-recipients - other-headers)]) - (for-each (lambda (s) - (display s writer) ; We use -i, so "." is not a problem - (newline writer)) - text) - (close-output-port writer))) +(provide sendmail@) diff --git a/collects/net/sendmail.rkt b/collects/net/sendmail.rkt index e759519616..025aec0454 100644 --- a/collects/net/sendmail.rkt +++ b/collects/net/sendmail.rkt @@ -1,6 +1,120 @@ #lang racket/base -(require racket/unit "sendmail-sig.rkt" "sendmail-unit.rkt") -(define-values/invoke-unit/infer sendmail@) +(require racket/system) -(provide-signature-elements sendmail^) +(provide send-mail-message/port + send-mail-message + (struct-out no-mail-recipients)) + +(define-struct (no-mail-recipients exn) ()) + +(define sendmail-search-path + '("/usr/lib" "/usr/sbin")) + +(define sendmail-program-file + (if (or (eq? (system-type) 'unix) + (eq? (system-type) 'macosx)) + (let loop ([paths sendmail-search-path]) + (if (null? paths) + (raise (make-exn:fail:unsupported + "unable to find sendmail on this Unix variant" + (current-continuation-marks))) + (let ([p (build-path (car paths) "sendmail")]) + (if (and (file-exists? p) + (memq 'execute (file-or-directory-permissions p))) + p + (loop (cdr paths)))))) + (raise (make-exn:fail:unsupported + "sendmail only available under Unix" + (current-continuation-marks))))) + +;; send-mail-message/port : +;; string x string x list (string) x list (string) x list (string) +;; [x list (string)] -> oport + +;; -- sender can be anything, though spoofing is not recommended. +;; The recipients must all be pure email addresses. Note that +;; everything is expected to follow RFC conventions. If any other +;; headers are specified, they are expected to be completely +;; formatted already. Clients are urged to use close-output-port on +;; the port returned by this procedure as soon as the necessary text +;; has been written, so that the sendmail process can complete. + +(define (send-mail-message/port + sender subject to-recipients cc-recipients bcc-recipients + . other-headers) + (when (and (null? to-recipients) (null? cc-recipients) + (null? bcc-recipients)) + (raise (make-no-mail-recipients + "no mail recipients were specified" + (current-continuation-marks)))) + (let ([return (apply process* sendmail-program-file "-i" + (append to-recipients cc-recipients bcc-recipients))]) + (let ([reader (car return)] + [writer (cadr return)] + [pid (caddr return)] + [error-reader (cadddr return)]) + (close-input-port reader) + (close-input-port error-reader) + (fprintf writer "From: ~a\n" sender) + (letrec ([write-recipient-header + (lambda (header-string recipients) + (let ([header-space + (+ (string-length header-string) 2)]) + (fprintf writer "~a: " header-string) + (let loop ([to recipients] [indent header-space]) + (if (null? to) + (newline writer) + (let ([first (car to)] + [rest (cdr to)]) + (let ([len (string-length first)]) + (if (>= (+ len indent) 80) + (begin + (fprintf writer + (if (null? rest) + "\n ~a" + "\n ~a, ") + first) + (loop (cdr to) + (+ len header-space 2))) + (begin + (fprintf writer + (if (null? rest) + "~a " + "~a, ") + first) + (loop (cdr to) + (+ len indent 2))))))))))]) + (write-recipient-header "To" to-recipients) + (unless (null? cc-recipients) + (write-recipient-header "CC" cc-recipients))) + (fprintf writer "Subject: ~a\n" subject) + (fprintf writer "X-Mailer: Racket (racket-lang.org)\n") + (for-each (lambda (s) + (display s writer) + (newline writer)) + other-headers) + (newline writer) + writer))) + +;; send-mail-message : +;; string x string x list (string) x list (string) x list (string) x +;; list (string) [x list (string)] -> () + +;; -- sender can be anything, though spoofing is not recommended. The +;; recipients must all be pure email addresses. The text is expected +;; to be pre-formatted. Note that everything is expected to follow +;; RFC conventions. If any other headers are specified, they are +;; expected to be completely formatted already. + +(define (send-mail-message + sender subject to-recipients cc-recipients bcc-recipients text + . other-headers) + (let ([writer (apply send-mail-message/port sender subject + to-recipients cc-recipients bcc-recipients + other-headers)]) + (for-each (lambda (s) + (display s writer) ; We use -i, so "." is not a problem + (newline writer)) + text) + (close-output-port writer))) From 647d3fb3657ec8f44dfcff74f0b5aebc3882e286 Mon Sep 17 00:00:00 2001 From: Jon Zeppieri Date: Mon, 29 Aug 2011 21:55:27 -0400 Subject: [PATCH 156/235] Moved `net/smtp' code from unit to module. --- collects/net/scribblings/smtp.scrbl | 4 + collects/net/smtp-unit.rkt | 166 +--------------------------- collects/net/smtp.rkt | 166 +++++++++++++++++++++++++++- 3 files changed, 172 insertions(+), 164 deletions(-) diff --git a/collects/net/scribblings/smtp.scrbl b/collects/net/scribblings/smtp.scrbl index 46cc382838..a6f768f300 100644 --- a/collects/net/scribblings/smtp.scrbl +++ b/collects/net/scribblings/smtp.scrbl @@ -102,6 +102,10 @@ probably will not).} @section{SMTP Unit} +@margin-note{@racket[smtp@] and @racket[smtp^] are deprecated. +They exist for backward-compatibility and will likely be removed in +the future. New code should use the @racketmodname[net/smtp] module.} + @defmodule[net/smtp-unit] @defthing[smtp@ unit?]{ diff --git a/collects/net/smtp-unit.rkt b/collects/net/smtp-unit.rkt index fae6c4bc42..98adc51b2f 100644 --- a/collects/net/smtp-unit.rkt +++ b/collects/net/smtp-unit.rkt @@ -1,164 +1,8 @@ -#lang racket/unit +#lang racket/base -(require racket/tcp "base64.rkt" "smtp-sig.rkt") +(require racket/unit + "smtp-sig.rkt" "smtp.rkt") -(import) -(export smtp^) +(define-unit-from-context smtp@ smtp^) -(define smtp-sending-server (make-parameter "localhost")) - -(define debug-via-stdio? #f) - -;; (define log printf) -(define log void) - -(define (starts-with? l n) - (and (>= (string-length l) (string-length n)) - (string=? n (substring l 0 (string-length n))))) - -(define (check-reply/accum r v w a) - (flush-output w) - (let ([l (read-line r (if debug-via-stdio? 'linefeed 'return-linefeed))]) - (log "server: ~a\n" l) - (if (eof-object? l) - (error 'check-reply "got EOF") - (let ([n (number->string v)]) - (unless (starts-with? l n) - (error 'check-reply "expected reply ~a; got: ~a" v l)) - (let ([n- (string-append n "-")]) - (if (starts-with? l n-) - ;; Multi-line reply. Go again. - (check-reply/accum r v w (if a (cons (substring l 4) a) #f)) - ;; We're finished, so add the last and reverse the result - (when a - (reverse (cons (substring l 4) a))))))))) - -(define (check-reply/commands r v w . commands) - ;; drop the first response, which is just the flavor text -- we expect the rest to - ;; be a list of supported ESMTP commands. - (let ([cmdlist (cdr (check-reply/accum r v w '()))]) - (for-each (lambda (c1) - (unless (findf (lambda (c2) (string=? c1 c2)) cmdlist) - (error "expected advertisement of ESMTP command ~a" c1))) - commands))) - -(define (check-reply r v w) - (check-reply/accum r v w #f)) - -(define (protect-line l) - ;; If begins with a dot, add one more - (if (or (equal? l #"") - (equal? l "") - (and (string? l) - (not (char=? #\. (string-ref l 0)))) - (and (bytes? l) - (not (= (char->integer #\.) (bytes-ref l 0))))) - l - (if (bytes? l) - (bytes-append #"." l) - (string-append "." l)))) - -(define smtp-sending-end-of-message - (make-parameter void - (lambda (f) - (unless (and (procedure? f) - (procedure-arity-includes? f 0)) - (raise-type-error 'smtp-sending-end-of-message "thunk" f)) - f))) - -(define (smtp-send-message* r w sender recipients header message-lines - auth-user auth-passwd tls-encode) - (with-handlers ([void (lambda (x) - (close-input-port r) - (close-output-port w) - (raise x))]) - (check-reply r 220 w) - (log "hello\n") - (fprintf w "EHLO ~a\r\n" (smtp-sending-server)) - (when tls-encode - (check-reply/commands r 250 w "STARTTLS") - (log "starttls\n") - (fprintf w "STARTTLS\r\n") - (check-reply r 220 w) - (let-values ([(ssl-r ssl-w) - (tls-encode r w - #:mode 'connect - #:encrypt 'tls - #:close-original? #t)]) - (set! r ssl-r) - (set! w ssl-w)) - ;; According to RFC 3207 Sec 4.2, we must start anew with the EHLO. - (log "tls hello\n") - (fprintf w "EHLO ~a\r\n" (smtp-sending-server))) - (check-reply r 250 w) - - (when auth-user - (log "auth\n") - (fprintf w "AUTH PLAIN ~a" - ;; Encoding adds CRLF - (base64-encode - (string->bytes/latin-1 - (format "~a\0~a\0~a" auth-user auth-user auth-passwd)))) - (check-reply r 235 w)) - - (log "from\n") - (fprintf w "MAIL FROM:<~a>\r\n" sender) - (check-reply r 250 w) - - (log "to\n") - (for-each - (lambda (dest) - (fprintf w "RCPT TO:<~a>\r\n" dest) - (check-reply r 250 w)) - recipients) - - (log "header\n") - (fprintf w "DATA\r\n") - (check-reply r 354 w) - (fprintf w "~a" header) - (for-each - (lambda (l) - (log "body: ~a\n" l) - (fprintf w "~a\r\n" (protect-line l))) - message-lines) - - ;; After we send the ".", then only break in an emergency - ((smtp-sending-end-of-message)) - - (log "dot\n") - (fprintf w ".\r\n") - (flush-output w) - (check-reply r 250 w) - - ;; Once a 250 has been received in response to the . at the end of - ;; the DATA block, the email has been sent successfully and out of our - ;; hands. This function should thus indicate success at this point - ;; no matter what else happens. - ;; - ;; Some servers (like smtp.gmail.com) will just close the connection - ;; on a QUIT, so instead of causing any QUIT errors to look like the - ;; email failed, we'll just log them. - (with-handlers ([void (lambda (x) - (log "error after send: ~a\n" (exn-message x)))]) - (log "quit\n") - (fprintf w "QUIT\r\n") - (check-reply r 221 w)) - - (close-output-port w) - (close-input-port r))) - -(define smtp-send-message - (lambda (server sender recipients header message-lines - #:port-no [port-no 25] - #:auth-user [auth-user #f] - #:auth-passwd [auth-passwd #f] - #:tcp-connect [tcp-connect tcp-connect] - #:tls-encode [tls-encode #f] - [opt-port-no port-no]) - (when (null? recipients) - (error 'send-smtp-message "no receivers")) - (let-values ([(r w) (if debug-via-stdio? - (values (current-input-port) (current-output-port)) - (tcp-connect server opt-port-no))]) - (smtp-send-message* r w sender recipients header message-lines - auth-user auth-passwd tls-encode)))) +(provide smtp@) diff --git a/collects/net/smtp.rkt b/collects/net/smtp.rkt index 4e213d4701..c635a4580b 100644 --- a/collects/net/smtp.rkt +++ b/collects/net/smtp.rkt @@ -1,6 +1,166 @@ #lang racket/base -(require racket/unit "smtp-sig.rkt" "smtp-unit.rkt") -(define-values/invoke-unit/infer smtp@) +(require racket/tcp "base64.rkt") -(provide-signature-elements smtp^) +(provide smtp-sending-server + smtp-send-message + smtp-send-message* + smtp-sending-end-of-message) + +(define smtp-sending-server (make-parameter "localhost")) + +(define debug-via-stdio? #f) + +;; (define log printf) +(define log void) + +(define (starts-with? l n) + (and (>= (string-length l) (string-length n)) + (string=? n (substring l 0 (string-length n))))) + +(define (check-reply/accum r v w a) + (flush-output w) + (let ([l (read-line r (if debug-via-stdio? 'linefeed 'return-linefeed))]) + (log "server: ~a\n" l) + (if (eof-object? l) + (error 'check-reply "got EOF") + (let ([n (number->string v)]) + (unless (starts-with? l n) + (error 'check-reply "expected reply ~a; got: ~a" v l)) + (let ([n- (string-append n "-")]) + (if (starts-with? l n-) + ;; Multi-line reply. Go again. + (check-reply/accum r v w (if a (cons (substring l 4) a) #f)) + ;; We're finished, so add the last and reverse the result + (when a + (reverse (cons (substring l 4) a))))))))) + +(define (check-reply/commands r v w . commands) + ;; drop the first response, which is just the flavor text -- we expect the rest to + ;; be a list of supported ESMTP commands. + (let ([cmdlist (cdr (check-reply/accum r v w '()))]) + (for-each (lambda (c1) + (unless (findf (lambda (c2) (string=? c1 c2)) cmdlist) + (error "expected advertisement of ESMTP command ~a" c1))) + commands))) + +(define (check-reply r v w) + (check-reply/accum r v w #f)) + +(define (protect-line l) + ;; If begins with a dot, add one more + (if (or (equal? l #"") + (equal? l "") + (and (string? l) + (not (char=? #\. (string-ref l 0)))) + (and (bytes? l) + (not (= (char->integer #\.) (bytes-ref l 0))))) + l + (if (bytes? l) + (bytes-append #"." l) + (string-append "." l)))) + +(define smtp-sending-end-of-message + (make-parameter void + (lambda (f) + (unless (and (procedure? f) + (procedure-arity-includes? f 0)) + (raise-type-error 'smtp-sending-end-of-message "thunk" f)) + f))) + +(define (smtp-send-message* r w sender recipients header message-lines + auth-user auth-passwd tls-encode) + (with-handlers ([void (lambda (x) + (close-input-port r) + (close-output-port w) + (raise x))]) + (check-reply r 220 w) + (log "hello\n") + (fprintf w "EHLO ~a\r\n" (smtp-sending-server)) + (when tls-encode + (check-reply/commands r 250 w "STARTTLS") + (log "starttls\n") + (fprintf w "STARTTLS\r\n") + (check-reply r 220 w) + (let-values ([(ssl-r ssl-w) + (tls-encode r w + #:mode 'connect + #:encrypt 'tls + #:close-original? #t)]) + (set! r ssl-r) + (set! w ssl-w)) + ;; According to RFC 3207 Sec 4.2, we must start anew with the EHLO. + (log "tls hello\n") + (fprintf w "EHLO ~a\r\n" (smtp-sending-server))) + (check-reply r 250 w) + + (when auth-user + (log "auth\n") + (fprintf w "AUTH PLAIN ~a" + ;; Encoding adds CRLF + (base64-encode + (string->bytes/latin-1 + (format "~a\0~a\0~a" auth-user auth-user auth-passwd)))) + (check-reply r 235 w)) + + (log "from\n") + (fprintf w "MAIL FROM:<~a>\r\n" sender) + (check-reply r 250 w) + + (log "to\n") + (for-each + (lambda (dest) + (fprintf w "RCPT TO:<~a>\r\n" dest) + (check-reply r 250 w)) + recipients) + + (log "header\n") + (fprintf w "DATA\r\n") + (check-reply r 354 w) + (fprintf w "~a" header) + (for-each + (lambda (l) + (log "body: ~a\n" l) + (fprintf w "~a\r\n" (protect-line l))) + message-lines) + + ;; After we send the ".", then only break in an emergency + ((smtp-sending-end-of-message)) + + (log "dot\n") + (fprintf w ".\r\n") + (flush-output w) + (check-reply r 250 w) + + ;; Once a 250 has been received in response to the . at the end of + ;; the DATA block, the email has been sent successfully and out of our + ;; hands. This function should thus indicate success at this point + ;; no matter what else happens. + ;; + ;; Some servers (like smtp.gmail.com) will just close the connection + ;; on a QUIT, so instead of causing any QUIT errors to look like the + ;; email failed, we'll just log them. + (with-handlers ([void (lambda (x) + (log "error after send: ~a\n" (exn-message x)))]) + (log "quit\n") + (fprintf w "QUIT\r\n") + (check-reply r 221 w)) + + (close-output-port w) + (close-input-port r))) + +(define smtp-send-message + (lambda (server sender recipients header message-lines + #:port-no [port-no 25] + #:auth-user [auth-user #f] + #:auth-passwd [auth-passwd #f] + #:tcp-connect [tcp-connect tcp-connect] + #:tls-encode [tls-encode #f] + [opt-port-no port-no]) + (when (null? recipients) + (error 'send-smtp-message "no receivers")) + (let-values ([(r w) (if debug-via-stdio? + (values (current-input-port) (current-output-port)) + (tcp-connect server opt-port-no))]) + (smtp-send-message* r w sender recipients header message-lines + auth-user auth-passwd tls-encode)))) From 3f69d4c8e86a9ccd4732e6f4ebb8ec905009c979 Mon Sep 17 00:00:00 2001 From: Jon Zeppieri Date: Mon, 29 Aug 2011 22:03:39 -0400 Subject: [PATCH 157/235] Moved `net/uri-codec' code from unit to module. --- collects/net/scribblings/uri-codec.scrbl | 24 ++ collects/net/uri-codec-unit.rkt | 292 +--------------------- collects/net/uri-codec.rkt | 294 ++++++++++++++++++++++- 3 files changed, 320 insertions(+), 290 deletions(-) diff --git a/collects/net/scribblings/uri-codec.scrbl b/collects/net/scribblings/uri-codec.scrbl index 57f3c30ebc..17a8da688c 100644 --- a/collects/net/scribblings/uri-codec.scrbl +++ b/collects/net/scribblings/uri-codec.scrbl @@ -154,3 +154,27 @@ use/recognize only of the separators. (form-urlencoded->alist "x=foo;y=bar;z=baz") (alist->form-urlencoded ex) ]} + +@; ---------------------------------------- + +@section{URI Codec Unit} + +@margin-note{@racket[uri-codec@] and @racket[uri-codec^] are deprecated. +They exist for backward-compatibility and will likely be removed in +the future. New code should use the @racketmodname[net/uri-codec] module.} + +@defmodule[net/uri-codec-unit] + +@defthing[uri-codec@ unit?]{ + +Imports nothing, exports @racket[uri-codec^].} + +@; ---------------------------------------- + +@section{URI Codec Signature} + +@defmodule[net/uri-codec-sig] + +@defsignature[uri-codec^ ()]{} + +Includes everything exported by the @racketmodname[net/uri-codec] module. diff --git a/collects/net/uri-codec-unit.rkt b/collects/net/uri-codec-unit.rkt index 42a2ff3148..f680d8ac12 100644 --- a/collects/net/uri-codec-unit.rkt +++ b/collects/net/uri-codec-unit.rkt @@ -1,290 +1,8 @@ -#| +#lang racket/base -People used to wonder why semicolons were the default. We then -decided to switch the default back to ampersands -- +(require racket/unit + "uri-codec-sig.rkt" "uri-codec.rkt") - http://www.w3.org/TR/html401/appendix/notes.html#h-B.2.2 +(define-unit-from-context uri-codec@ uri-codec^) - We recommend that HTTP server implementors, and in particular, CGI - implementors support the use of ";" in place of "&" to save authors - the trouble of escaping "&" characters in this manner. - -See more in PR8831. - -|# - - -;;; -;;; ---- En/Decode URLs and form-urlencoded data -;;; Time-stamp: <03/04/25 10:31:31 noel> -;;; -;;; Copyright (C) 2002 by Noel Welsh. -;;; -;;; This file is part of Net. - -;;; Net is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU Lesser General Public -;;; License as published by the Free Software Foundation; either -;;; version 2.1 of the License, or (at your option) any later version. - -;;; Net is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. - -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with Net; if not, write to the Free Software -;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA -;;; 02110-1301 USA. - -;;; Author: Noel Welsh -;; -;; -;; Commentary: - -;; The module provides functions to encode and decode strings using -;; the URI encoding rules given in RFC 2396, and to encode and decode -;; name/value pairs using the application/x-www-form-urlencoded -;; mimetype given the in HTML 4.0 specification. There are minor -;; differences between the two encodings. - -;; The URI encoding uses allows a few characters to be represented `as -;; is': a-Z, A-Z, 0-9, -, _, ., !, ~, *, ', ( and ). The remaining -;; characters are encoded as %xx, where xx is the hex representation -;; of the integer value of the character (where the mapping -;; character<->integer is determined by US-ASCII if the integer is -;; <128). - -;; The encoding, inline with RFC 2396's recommendation, represents a -;; character as is, if possible. The decoding allows any characters -;; to be represented by their hex values, and allows characters to be -;; incorrectly represented `as is'. - -;; The rules for the application/x-www-form-urlencoded mimetype given -;; in the HTML 4.0 spec are: - -;; 1. Control names and values are escaped. Space characters are -;; replaced by `+', and then reserved characters are escaped as -;; described in [RFC1738], section 2.2: Non-alphanumeric characters -;; are replaced by `%HH', a percent sign and two hexadecimal digits -;; representing the ASCII code of the character. Line breaks are -;; represented as "CR LF" pairs (i.e., `%0D%0A'). - -;; 2. The control names/values are listed in the order they appear -;; in the document. The name is separated from the value by `=' and -;; name/value pairs are separated from each other by `&'. - -;; NB: RFC 2396 supersedes RFC 1738. - -;; This differs slightly from the straight encoding in RFC 2396 in -;; that `+' is allowed, and represents a space. We follow this -;; convention, encoding a space as `+' and decoding `+' as a space. -;; There appear to be some brain-dead decoders on the web, so we also -;; encode `!', `~', `'', `(' and ')' using their hex representation. -;; This is the same choice as made by the Java URLEncoder. - -;; Draws inspiration from encode-decode.scm by Kurt Normark and a code -;; sample provided by Eli Barzilay - -#lang racket/unit - -(require racket/match racket/string racket/list "uri-codec-sig.rkt") - -(import) -(export uri-codec^) - -(define (self-map-char ch) (cons ch ch)) -(define (self-map-chars str) (map self-map-char (string->list str))) - -;; The characters that always map to themselves -(define alphanumeric-mapping - (self-map-chars - "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")) - -;; Characters that sometimes map to themselves -;; called 'mark' in RFC 3986 -(define safe-mapping (self-map-chars "-_.!~*'()")) - -;; The strict URI mapping -(define uri-mapping (append alphanumeric-mapping safe-mapping)) - -;; The uri path segment mapping from RFC 3986 -(define uri-path-segment-mapping - (append alphanumeric-mapping - safe-mapping - (self-map-chars "@+,=$&:"))) - -;; from RFC 3986 -(define unreserved-mapping - (append alphanumeric-mapping - (self-map-chars "-._~"))) - -;; from RFC 3986 -(define sub-delims-mapping - (self-map-chars "!$&'()*+,;=")) - -;; The uri userinfo mapping from RFC 3986 -(define uri-userinfo-mapping - (append unreserved-mapping - sub-delims-mapping - (self-map-chars ":"))) - -;; The form-urlencoded mapping -(define form-urlencoded-mapping - `(,@(self-map-chars ".-*_") (#\space . #\+) ,@alphanumeric-mapping)) - -(define (number->hex-string number) - (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)) -(define (make-codec-tables alist) - (let ([encoding-table (build-vector ascii-size number->hex-string)] - [decoding-table (build-vector ascii-size values)]) - (for-each (match-lambda - [(cons orig enc) - (vector-set! encoding-table - (char->integer orig) - (string enc)) - (vector-set! decoding-table - (char->integer enc) - (char->integer orig))]) - alist) - (values encoding-table decoding-table))) - -(define-values (uri-encoding-vector uri-decoding-vector) - (make-codec-tables uri-mapping)) - -(define-values (uri-path-segment-encoding-vector - uri-path-segment-decoding-vector) - (make-codec-tables uri-path-segment-mapping)) - -(define-values (uri-userinfo-encoding-vector - uri-userinfo-decoding-vector) - (make-codec-tables uri-userinfo-mapping)) - - -(define-values (form-urlencoded-encoding-vector - form-urlencoded-decoding-vector) - (make-codec-tables form-urlencoded-mapping)) - -;; vector string -> string -(define (encode table str) - (apply string-append (map (lambda (byte) - (if (< byte ascii-size) - (vector-ref table byte) - (number->hex-string byte))) - (bytes->list (string->bytes/utf-8 str))))) - -;; vector string -> string -(define (decode table str) - (define internal-decode - (match-lambda [(list) (list)] - [(list* #\% (? hex-digit? char1) (? hex-digit? char2) rest) - ;; This used to consult the table again, but I think that's - ;; wrong. For example %2b should produce +, not a space. - (cons (string->number (string char1 char2) 16) - (internal-decode rest))] - [(cons (? ascii-char? char) rest) - (cons (vector-ref table (char->integer char)) - (internal-decode rest))] - [(cons char rest) - (append - (bytes->list (string->bytes/utf-8 (string char))) - (internal-decode rest))])) - (bytes->string/utf-8 (apply bytes (internal-decode (string->list str))))) - -(define (ascii-char? c) - (< (char->integer c) ascii-size)) - -(define (hex-digit? c) - (or (char<=? #\0 c #\9) - (char<=? #\a c #\f) - (char<=? #\A c #\F))) - -;; string -> string -(define (uri-encode str) - (encode uri-encoding-vector str)) - -;; string -> string -(define (uri-decode str) - (decode uri-decoding-vector str)) - -;; string -> string -(define (uri-path-segment-encode str) - (encode uri-path-segment-encoding-vector str)) - -;; string -> string -(define (uri-path-segment-decode str) - (decode uri-path-segment-decoding-vector str)) - -;; string -> string -(define (uri-userinfo-encode str) - (encode uri-userinfo-encoding-vector str)) - -;; string -> string -(define (uri-userinfo-decode str) - (decode uri-userinfo-decoding-vector str)) - - -;; string -> string -(define (form-urlencoded-encode str) - (encode form-urlencoded-encoding-vector str)) - -;; string -> string -(define (form-urlencoded-decode str) - (decode form-urlencoded-decoding-vector str)) - -;; listof (cons string string) -> string -;; http://www.w3.org/TR/html401/appendix/notes.html#ampersands-in-uris -;; listof (cons symbol string) -> string -(define (alist->form-urlencoded args) - (let* ([sep (if (memq (current-alist-separator-mode) '(semi semi-or-amp)) - ";" "&")] - [format-one - (lambda (arg) - (let* ([name (car arg)] - [value (cdr arg)] - [name (form-urlencoded-encode (symbol->string name))] - [value (and value (form-urlencoded-encode value))]) - (if value (string-append name "=" value) name)))] - [strs (if (null? args) - '() - (cons (format-one (car args)) - (apply append - (map (lambda (a) (list sep (format-one a))) - (cdr args)))))]) - (apply string-append strs))) - -;; string -> listof (cons string string) -;; http://www.w3.org/TR/html401/appendix/notes.html#ampersands-in-uris -(define (form-urlencoded->alist str) - (define keyval-regexp #rx"=") - (define value-regexp - (case (current-alist-separator-mode) - [(semi) #rx"[;]"] - [(amp) #rx"[&]"] - [else #rx"[&;]"])) - (define (parse-keyval keyval) - (let (;; m = #f => no "=..." part - [m (regexp-match-positions keyval-regexp keyval)]) - (cons (string->symbol (form-urlencoded-decode - (if m (substring keyval 0 (caar m)) keyval))) - (and m (form-urlencoded-decode (substring keyval (cdar m))))))) - (if (equal? "" str) '() (map parse-keyval (regexp-split value-regexp str)))) - -(define current-alist-separator-mode - (make-parameter 'amp-or-semi - (lambda (s) - (unless (memq s '(amp semi amp-or-semi semi-or-amp)) - (raise-type-error 'current-alist-separator-mode - "'amp, 'semi, 'amp-or-semi, or 'semi-or-amp" - s)) - s))) - -;;; uri-codec-unit.rkt ends here +(provide uri-codec@) diff --git a/collects/net/uri-codec.rkt b/collects/net/uri-codec.rkt index 2ab56b22d8..7c0c53ae64 100644 --- a/collects/net/uri-codec.rkt +++ b/collects/net/uri-codec.rkt @@ -1,6 +1,294 @@ #lang racket/base -(require racket/unit "uri-codec-sig.rkt" "uri-codec-unit.rkt") -(provide-signature-elements uri-codec^) +#| +People used to wonder why semicolons were the default. We then +decided to switch the default back to ampersands -- -(define-values/invoke-unit/infer uri-codec@) + http://www.w3.org/TR/html401/appendix/notes.html#h-B.2.2 + + We recommend that HTTP server implementors, and in particular, CGI + implementors support the use of ";" in place of "&" to save authors + the trouble of escaping "&" characters in this manner. + +See more in PR8831. +|# + +;;; ---- En/Decode URLs and form-urlencoded data +;;; Time-stamp: <03/04/25 10:31:31 noel> +;;; +;;; Copyright (C) 2002 by Noel Welsh. +;;; +;;; This file is part of Net. + +;;; Net is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 2.1 of the License, or (at your option) any later version. + +;;; Net is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. + +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with Net; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;;; 02110-1301 USA. + +;;; Author: Noel Welsh +;; +;; Commentary: + +;; The module provides functions to encode and decode strings using +;; the URI encoding rules given in RFC 2396, and to encode and decode +;; name/value pairs using the application/x-www-form-urlencoded +;; mimetype given the in HTML 4.0 specification. There are minor +;; differences between the two encodings. + +;; The URI encoding uses allows a few characters to be represented `as +;; is': a-Z, A-Z, 0-9, -, _, ., !, ~, *, ', ( and ). The remaining +;; characters are encoded as %xx, where xx is the hex representation +;; of the integer value of the character (where the mapping +;; character<->integer is determined by US-ASCII if the integer is +;; <128). + +;; The encoding, inline with RFC 2396's recommendation, represents a +;; character as is, if possible. The decoding allows any characters +;; to be represented by their hex values, and allows characters to be +;; incorrectly represented `as is'. + +;; The rules for the application/x-www-form-urlencoded mimetype given +;; in the HTML 4.0 spec are: + +;; 1. Control names and values are escaped. Space characters are +;; replaced by `+', and then reserved characters are escaped as +;; described in [RFC1738], section 2.2: Non-alphanumeric characters +;; are replaced by `%HH', a percent sign and two hexadecimal digits +;; representing the ASCII code of the character. Line breaks are +;; represented as "CR LF" pairs (i.e., `%0D%0A'). + +;; 2. The control names/values are listed in the order they appear +;; in the document. The name is separated from the value by `=' and +;; name/value pairs are separated from each other by `&'. + +;; NB: RFC 2396 supersedes RFC 1738. + +;; This differs slightly from the straight encoding in RFC 2396 in +;; that `+' is allowed, and represents a space. We follow this +;; convention, encoding a space as `+' and decoding `+' as a space. +;; There appear to be some brain-dead decoders on the web, so we also +;; encode `!', `~', `'', `(' and ')' using their hex representation. +;; This is the same choice as made by the Java URLEncoder. + +;; Draws inspiration from encode-decode.scm by Kurt Normark and a code +;; sample provided by Eli Barzilay + +(require racket/match racket/string racket/list) + +(provide uri-encode + uri-decode + uri-path-segment-encode + uri-path-segment-decode + uri-userinfo-encode + uri-userinfo-decode + form-urlencoded-encode + form-urlencoded-decode + alist->form-urlencoded + form-urlencoded->alist + current-alist-separator-mode) + +(define (self-map-char ch) (cons ch ch)) +(define (self-map-chars str) (map self-map-char (string->list str))) + +;; The characters that always map to themselves +(define alphanumeric-mapping + (self-map-chars + "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")) + +;; Characters that sometimes map to themselves +;; called 'mark' in RFC 3986 +(define safe-mapping (self-map-chars "-_.!~*'()")) + +;; The strict URI mapping +(define uri-mapping (append alphanumeric-mapping safe-mapping)) + +;; The uri path segment mapping from RFC 3986 +(define uri-path-segment-mapping + (append alphanumeric-mapping + safe-mapping + (self-map-chars "@+,=$&:"))) + +;; from RFC 3986 +(define unreserved-mapping + (append alphanumeric-mapping + (self-map-chars "-._~"))) + +;; from RFC 3986 +(define sub-delims-mapping + (self-map-chars "!$&'()*+,;=")) + +;; The uri userinfo mapping from RFC 3986 +(define uri-userinfo-mapping + (append unreserved-mapping + sub-delims-mapping + (self-map-chars ":"))) + +;; The form-urlencoded mapping +(define form-urlencoded-mapping + `(,@(self-map-chars ".-*_") (#\space . #\+) ,@alphanumeric-mapping)) + +(define (number->hex-string number) + (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)) +(define (make-codec-tables alist) + (let ([encoding-table (build-vector ascii-size number->hex-string)] + [decoding-table (build-vector ascii-size values)]) + (for-each (match-lambda + [(cons orig enc) + (vector-set! encoding-table + (char->integer orig) + (string enc)) + (vector-set! decoding-table + (char->integer enc) + (char->integer orig))]) + alist) + (values encoding-table decoding-table))) + +(define-values (uri-encoding-vector uri-decoding-vector) + (make-codec-tables uri-mapping)) + +(define-values (uri-path-segment-encoding-vector + uri-path-segment-decoding-vector) + (make-codec-tables uri-path-segment-mapping)) + +(define-values (uri-userinfo-encoding-vector + uri-userinfo-decoding-vector) + (make-codec-tables uri-userinfo-mapping)) + + +(define-values (form-urlencoded-encoding-vector + form-urlencoded-decoding-vector) + (make-codec-tables form-urlencoded-mapping)) + +;; vector string -> string +(define (encode table str) + (apply string-append (map (lambda (byte) + (if (< byte ascii-size) + (vector-ref table byte) + (number->hex-string byte))) + (bytes->list (string->bytes/utf-8 str))))) + +;; vector string -> string +(define (decode table str) + (define internal-decode + (match-lambda [(list) (list)] + [(list* #\% (? hex-digit? char1) (? hex-digit? char2) rest) + ;; This used to consult the table again, but I think that's + ;; wrong. For example %2b should produce +, not a space. + (cons (string->number (string char1 char2) 16) + (internal-decode rest))] + [(cons (? ascii-char? char) rest) + (cons (vector-ref table (char->integer char)) + (internal-decode rest))] + [(cons char rest) + (append + (bytes->list (string->bytes/utf-8 (string char))) + (internal-decode rest))])) + (bytes->string/utf-8 (apply bytes (internal-decode (string->list str))))) + +(define (ascii-char? c) + (< (char->integer c) ascii-size)) + +(define (hex-digit? c) + (or (char<=? #\0 c #\9) + (char<=? #\a c #\f) + (char<=? #\A c #\F))) + +;; string -> string +(define (uri-encode str) + (encode uri-encoding-vector str)) + +;; string -> string +(define (uri-decode str) + (decode uri-decoding-vector str)) + +;; string -> string +(define (uri-path-segment-encode str) + (encode uri-path-segment-encoding-vector str)) + +;; string -> string +(define (uri-path-segment-decode str) + (decode uri-path-segment-decoding-vector str)) + +;; string -> string +(define (uri-userinfo-encode str) + (encode uri-userinfo-encoding-vector str)) + +;; string -> string +(define (uri-userinfo-decode str) + (decode uri-userinfo-decoding-vector str)) + + +;; string -> string +(define (form-urlencoded-encode str) + (encode form-urlencoded-encoding-vector str)) + +;; string -> string +(define (form-urlencoded-decode str) + (decode form-urlencoded-decoding-vector str)) + +;; listof (cons string string) -> string +;; http://www.w3.org/TR/html401/appendix/notes.html#ampersands-in-uris +;; listof (cons symbol string) -> string +(define (alist->form-urlencoded args) + (let* ([sep (if (memq (current-alist-separator-mode) '(semi semi-or-amp)) + ";" "&")] + [format-one + (lambda (arg) + (let* ([name (car arg)] + [value (cdr arg)] + [name (form-urlencoded-encode (symbol->string name))] + [value (and value (form-urlencoded-encode value))]) + (if value (string-append name "=" value) name)))] + [strs (if (null? args) + '() + (cons (format-one (car args)) + (apply append + (map (lambda (a) (list sep (format-one a))) + (cdr args)))))]) + (apply string-append strs))) + +;; string -> listof (cons string string) +;; http://www.w3.org/TR/html401/appendix/notes.html#ampersands-in-uris +(define (form-urlencoded->alist str) + (define keyval-regexp #rx"=") + (define value-regexp + (case (current-alist-separator-mode) + [(semi) #rx"[;]"] + [(amp) #rx"[&]"] + [else #rx"[&;]"])) + (define (parse-keyval keyval) + (let (;; m = #f => no "=..." part + [m (regexp-match-positions keyval-regexp keyval)]) + (cons (string->symbol (form-urlencoded-decode + (if m (substring keyval 0 (caar m)) keyval))) + (and m (form-urlencoded-decode (substring keyval (cdar m))))))) + (if (equal? "" str) '() (map parse-keyval (regexp-split value-regexp str)))) + +(define current-alist-separator-mode + (make-parameter 'amp-or-semi + (lambda (s) + (unless (memq s '(amp semi amp-or-semi semi-or-amp)) + (raise-type-error 'current-alist-separator-mode + "'amp, 'semi, 'amp-or-semi, or 'semi-or-amp" + s)) + s))) + +;;; uri-codec.rkt ends here From d44a7a480a162f413e6f1f761c96f8aa14b5be58 Mon Sep 17 00:00:00 2001 From: Jon Zeppieri Date: Mon, 29 Aug 2011 22:30:39 -0400 Subject: [PATCH 158/235] Moved `net/url' code from unit to module. --- collects/net/scribblings/url.scrbl | 4 + collects/net/url-connect.rkt | 24 ++ collects/net/url-unit.rkt | 610 +--------------------------- collects/net/url.rkt | 625 +++++++++++++++++++++++++++-- 4 files changed, 631 insertions(+), 632 deletions(-) create mode 100644 collects/net/url-connect.rkt diff --git a/collects/net/scribblings/url.scrbl b/collects/net/scribblings/url.scrbl index ed8ca9b98b..e1b2db5f32 100644 --- a/collects/net/scribblings/url.scrbl +++ b/collects/net/scribblings/url.scrbl @@ -361,6 +361,10 @@ as described with @racket[get-pure-port].} @section{URL Unit} +@margin-note{@racket[url@], @racket[url^], and @racket[url+scheme^] are deprecated. +They exist for backward-compatibility and will likely be removed in +the future. New code should use the @racketmodname[net/url] module.} + @defmodule[net/url-unit] @defthing[url@ unit?]{ diff --git a/collects/net/url-connect.rkt b/collects/net/url-connect.rkt new file mode 100644 index 0000000000..5f80bb4188 --- /dev/null +++ b/collects/net/url-connect.rkt @@ -0,0 +1,24 @@ +#lang racket/base + +(require (rename-in racket/tcp + [tcp-connect plain-tcp-connect] + [tcp-abandon-port plain-tcp-abandon-port]) + openssl) + +(provide (all-defined-out)) + +(define current-connect-scheme (make-parameter "http")) + +(define current-https-protocol (make-parameter 'sslv2-or-v3)) + +;; Define `tcp-connect' and `tcp-abandon-port' to fit with +;; `current-connect-scheme' +(define (tcp-connect host port) + (cond [(equal? (current-connect-scheme) "https") + (ssl-connect host port (current-https-protocol))] + [else + (plain-tcp-connect host port)])) + +(define (tcp-abandon-port port) + (cond [(ssl-port? port) (ssl-abandon-port port)] + [else (plain-tcp-abandon-port port)])) diff --git a/collects/net/url-unit.rkt b/collects/net/url-unit.rkt index a4b4acbb59..98fe4d33dc 100644 --- a/collects/net/url-unit.rkt +++ b/collects/net/url-unit.rkt @@ -1,608 +1,8 @@ -#lang racket/unit +#lang racket/base -;; To do: -;; Handle HTTP/file errors. -;; Not throw away MIME headers. -;; Determine file type. +(require racket/unit + "url-sig.rkt" "url.rkt" "url-connect.rkt") -;; ---------------------------------------------------------------------- +(define-unit-from-context url@ url+scheme^) -;; Input ports have two statuses: -;; "impure" = they have text waiting -;; "pure" = the MIME headers have been read - -(require racket/port racket/string - "url-structs.rkt" "uri-codec.rkt" "url-sig.rkt" "tcp-sig.rkt") - -(import tcp^) -(export url+scheme^) - -(define-struct (url-exception exn:fail) ()) - -(define file-url-path-convention-type (make-parameter (system-path-convention-type))) - -(define current-proxy-servers - (make-parameter null - (lambda (v) - (unless (and (list? v) - (andmap (lambda (v) - (and (list? v) - (= 3 (length v)) - (equal? (car v) "http") - (string? (car v)) - (exact-integer? (caddr v)) - (<= 1 (caddr v) 65535))) - v)) - (raise-type-error - 'current-proxy-servers - "list of list of scheme, string, and exact integer in [1,65535]" - v)) - (map (lambda (v) - (list (string->immutable-string (car v)) - (string->immutable-string (cadr v)) - (caddr v))) - v)))) - -(define (url-error fmt . args) - (raise (make-url-exception - (apply format fmt - (map (lambda (arg) (if (url? arg) (url->string arg) arg)) - args)) - (current-continuation-marks)))) - -(define (url->string url) - (let ([scheme (url-scheme url)] - [user (url-user url)] - [host (url-host url)] - [port (url-port url)] - [path (url-path url)] - [query (url-query url)] - [fragment (url-fragment url)] - [sa string-append]) - (when (and (equal? scheme "file") - (not (url-path-absolute? url))) - (raise-mismatch-error 'url->string - "cannot convert relative file URL to a string: " - url)) - (sa (if scheme (sa scheme ":") "") - (if (or user host port) - (sa "//" - (if user (sa (uri-userinfo-encode user) "@") "") - (if host host "") - (if port (sa ":" (number->string port)) "") - ;; There used to be a "/" here, but that causes an - ;; extra leading slash -- wonder why it ever worked! - ) - (if (equal? "file" scheme) ; always need "//" for "file" URLs - "//" - "")) - (combine-path-strings (url-path-absolute? url) path) - ;; (if query (sa "?" (uri-encode query)) "") - (if (null? query) "" (sa "?" (alist->form-urlencoded query))) - (if fragment (sa "#" (uri-encode fragment)) "")))) - -;; url->default-port : url -> num -(define (url->default-port url) - (let ([scheme (url-scheme url)]) - (cond [(not scheme) 80] - [(string=? scheme "http") 80] - [(string=? scheme "https") 443] - [else (url-error "URL scheme ~s not supported" scheme)]))) - -(define current-connect-scheme (make-parameter "http")) - -;; make-ports : url -> in-port x out-port -(define (make-ports url proxy) - (let ([port-number (if proxy - (caddr proxy) - (or (url-port url) (url->default-port url)))] - [host (if proxy (cadr proxy) (url-host url))]) - (parameterize ([current-connect-scheme (url-scheme url)]) - (tcp-connect host port-number)))) - -;; http://getpost-impure-port : bool x url x union (str, #f) x list (str) -> in-port -(define (http://getpost-impure-port get? url post-data strings) - (define proxy (assoc (url-scheme url) (current-proxy-servers))) - (define-values (server->client client->server) (make-ports url proxy)) - (define access-string - (url->string - (if proxy - url - ;; RFCs 1945 and 2616 say: - ;; Note that the absolute path cannot be empty; if none is present in - ;; the original URI, it must be given as "/" (the server root). - (let-values ([(abs? path) - (if (null? (url-path url)) - (values #t (list (make-path/param "" '()))) - (values (url-path-absolute? url) (url-path url)))]) - (make-url #f #f #f #f abs? path (url-query url) (url-fragment url)))))) - (define (println . xs) - (for-each (lambda (x) (display x client->server)) xs) - (display "\r\n" client->server)) - (println (if get? "GET " "POST ") access-string " HTTP/1.0") - (println "Host: " (url-host url) - (let ([p (url-port url)]) (if p (format ":~a" p) ""))) - (when post-data (println "Content-Length: " (bytes-length post-data))) - (for-each println strings) - (println) - (when post-data (display post-data client->server)) - (flush-output client->server) - (tcp-abandon-port client->server) - server->client) - -(define (file://->path url [kind (system-path-convention-type)]) - (let ([strs (map path/param-path (url-path url))] - [string->path-element/same - (lambda (e) - (if (symbol? e) - e - (if (string=? e "") - 'same - (bytes->path-element (string->bytes/locale e) kind))))] - [string->path/win (lambda (s) - (bytes->path (string->bytes/utf-8 s) 'windows))]) - (if (and (url-path-absolute? url) - (eq? 'windows kind)) - ;; If initial path is "", then build UNC path. - (cond - [(not (url-path-absolute? url)) - (apply build-path (map string->path-element/same strs))] - [(and ((length strs) . >= . 3) - (equal? (car strs) "")) - (apply build-path - (string->path/win - (string-append "\\\\" (cadr strs) "\\" (caddr strs) "\\")) - (map string->path-element/same (cdddr strs)))] - [(pair? strs) - (apply build-path (string->path/win (car strs)) - (map string->path-element/same (cdr strs)))] - [else (error 'file://->path "no path elements: ~e" url)]) - (let ([elems (map string->path-element/same strs)]) - (if (url-path-absolute? url) - (apply build-path (bytes->path #"/" 'unix) elems) - (apply build-path elems)))))) - -;; file://get-pure-port : url -> in-port -(define (file://get-pure-port url) - (open-input-file (file://->path url))) - -(define (schemeless-url url) - (url-error "Missing protocol (usually \"http:\") at the beginning of URL: ~a" url)) - -;; getpost-impure-port : bool x url x list (str) -> in-port -(define (getpost-impure-port get? url post-data strings) - (let ([scheme (url-scheme url)]) - (cond [(not scheme) - (schemeless-url url)] - [(or (string=? scheme "http") (string=? scheme "https")) - (http://getpost-impure-port get? url post-data strings)] - [(string=? scheme "file") - (url-error "There are no impure file: ports")] - [else (url-error "Scheme ~a unsupported" scheme)]))) - -;; get-impure-port : url [x list (str)] -> in-port -(define (get-impure-port url [strings '()]) - (getpost-impure-port #t url #f strings)) - -;; post-impure-port : url x bytes [x list (str)] -> in-port -(define (post-impure-port url post-data [strings '()]) - (getpost-impure-port #f url post-data strings)) - -;; getpost-pure-port : bool x url x list (str) -> in-port -(define (getpost-pure-port get? url post-data strings) - (let ([scheme (url-scheme url)]) - (cond [(not scheme) - (schemeless-url url)] - [(or (string=? scheme "http") - (string=? scheme "https")) - (let ([port (http://getpost-impure-port - get? url post-data strings)]) - (purify-http-port port))] - [(string=? scheme "file") - (file://get-pure-port url)] - [else (url-error "Scheme ~a unsupported" scheme)]))) - -;; get-pure-port : url [x list (str)] -> in-port -(define (get-pure-port url [strings '()]) - (getpost-pure-port #t url #f strings)) - -;; post-pure-port : url bytes [x list (str)] -> in-port -(define (post-pure-port url post-data [strings '()]) - (getpost-pure-port #f url post-data strings)) - -;; display-pure-port : in-port -> () -(define (display-pure-port server->client) - (copy-port server->client (current-output-port)) - (close-input-port server->client)) - -;; transliteration of code in rfc 3986, section 5.2.2 -(define (combine-url/relative Base string) - (let ([R (string->url string)] - [T (make-url #f #f #f #f #f '() '() #f)]) - (if (url-scheme R) - (begin - (set-url-scheme! T (url-scheme R)) - (set-url-user! T (url-user R)) ;; authority - (set-url-host! T (url-host R)) ;; authority - (set-url-port! T (url-port R)) ;; authority - (set-url-path-absolute?! T (url-path-absolute? R)) - (set-url-path! T (remove-dot-segments (url-path R))) - (set-url-query! T (url-query R))) - (begin - (if (url-host R) ;; => authority is defined - (begin - (set-url-user! T (url-user R)) ;; authority - (set-url-host! T (url-host R)) ;; authority - (set-url-port! T (url-port R)) ;; authority - (set-url-path-absolute?! T (url-path-absolute? R)) - (set-url-path! T (remove-dot-segments (url-path R))) - (set-url-query! T (url-query R))) - (begin - (if (null? (url-path R)) ;; => R has empty path - (begin - (set-url-path-absolute?! T (url-path-absolute? Base)) - (set-url-path! T (url-path Base)) - (if (not (null? (url-query R))) - (set-url-query! T (url-query R)) - (set-url-query! T (url-query Base)))) - (begin - (cond - [(url-path-absolute? R) - (set-url-path-absolute?! T #t) - (set-url-path! T (remove-dot-segments (url-path R)))] - [(and (null? (url-path Base)) - (url-host Base)) - (set-url-path-absolute?! T #t) - (set-url-path! T (remove-dot-segments (url-path R)))] - [else - (set-url-path-absolute?! T (url-path-absolute? Base)) - (set-url-path! T (remove-dot-segments - (append (all-but-last (url-path Base)) - (url-path R))))]) - (set-url-query! T (url-query R)))) - (set-url-user! T (url-user Base)) ;; authority - (set-url-host! T (url-host Base)) ;; authority - (set-url-port! T (url-port Base)))) ;; authority - (set-url-scheme! T (url-scheme Base)))) - (set-url-fragment! T (url-fragment R)) - T)) - -(define (all-but-last lst) - (cond [(null? lst) null] - [(null? (cdr lst)) null] - [else (cons (car lst) (all-but-last (cdr lst)))])) - -;; cribbed from 5.2.4 in rfc 3986 -;; the strange [*] cases implicitly change urls -;; with paths segments "." and ".." at the end -;; into "./" and "../" respectively -(define (remove-dot-segments path) - (let loop ([path path] [result '()]) - (if (null? path) - (reverse result) - (let ([fst (path/param-path (car path))] - [rst (cdr path)]) - (loop rst - (cond - [(and (eq? fst 'same) (null? rst)) - (cons (make-path/param "" '()) result)] ; [*] - [(eq? fst 'same) - result] - [(and (eq? fst 'up) (null? rst) (not (null? result))) - (cons (make-path/param "" '()) (cdr result))] ; [*] - [(and (eq? fst 'up) (not (null? result))) - (cdr result)] - [(and (eq? fst 'up) (null? result)) - ;; when we go up too far, just drop the "up"s. - result] - [else - (cons (car path) result)])))))) - -;; call/input-url : url x (url -> in-port) x (in-port -> T) -;; [x list (str)] -> T -(define call/input-url - (let ([handle-port - (lambda (server->client handler) - (dynamic-wind (lambda () 'do-nothing) - (lambda () (handler server->client)) - (lambda () (close-input-port server->client))))]) - (case-lambda - [(url getter handler) - (handle-port (getter url) handler)] - [(url getter handler params) - (handle-port (getter url params) handler)]))) - -;; purify-port : in-port -> header-string -(define (purify-port port) - (let ([m (regexp-match-peek-positions - #rx"^HTTP/.*?(?:\r\n\r\n|\n\n|\r\r)" port)]) - (if m (read-string (cdar m) port) ""))) - -;; purify-http-port : in-port -> in-port -;; returns a new port, closes the old one when done pumping -(define (purify-http-port in-port) - (define-values (in-pipe out-pipe) (make-pipe)) - (thread - (λ () - (define status (http-read-status in-port)) - (define chunked? (http-read-headers in-port)) - (http-pipe-data chunked? in-port out-pipe) - (close-input-port in-port))) - in-pipe) - -(define (http-read-status ip) - (read-line ip 'return-linefeed)) - -(define (http-read-headers ip) - (define l (read-line ip 'return-linefeed)) - (when (eof-object? l) - (error 'purify-http-port "Connection ended before headers ended")) - (if (string=? l "") - #f - (if (string=? l "Transfer-Encoding: chunked") - (begin (http-read-headers ip) - #t) - (http-read-headers ip)))) - -(define (http-pipe-data chunked? ip op) - (if chunked? - (http-pipe-chunk ip op) - (begin - (copy-port ip op) - (flush-output op) - (close-output-port op)))) - -(define (http-pipe-chunk ip op) - (define size-str (read-line ip 'return-linefeed)) - (define chunk-size (string->number size-str 16)) - (unless chunk-size - (error 'http-pipe-chunk "Could not parse ~S as hexadecimal number" size-str)) - (if (zero? chunk-size) - (begin (flush-output op) - (close-output-port op)) - (let* ([bs (read-bytes chunk-size ip)] - [crlf (read-bytes 2 ip)]) - (write-bytes bs op) - (http-pipe-chunk ip op)))) - -(define character-set-size 256) - -;; netscape/string->url : str -> url -(define (netscape/string->url string) - (let ([url (string->url string)]) - (cond [(url-scheme url) url] - [(string=? string "") - (url-error "Can't resolve empty string as URL")] - [else (set-url-scheme! url - (if (char=? (string-ref string 0) #\/) "file" "http")) - url]))) - -;; URL parsing regexp -;; this is following the regexp in Appendix B of rfc 3986, except for using -;; `*' instead of `+' for the scheme part (it is checked later anyway, and -;; we don't want to parse it as a path element), and the user@host:port is -;; parsed here. -(define url-rx - (regexp (string-append - "^" - "(?:" ; / scheme-colon-opt - "([^:/?#]*)" ; | #1 = scheme-opt - ":)?" ; \ - "(?://" ; / slash-slash-authority-opt - "(?:" ; | / user-at-opt - "([^/?#@]*)" ; | | #2 = user-opt - "@)?" ; | \ - "([^/?#:]*)?" ; | #3 = host-opt - "(?::" ; | / colon-port-opt - "([0-9]*)" ; | | #4 = port-opt - ")?" ; | \ - ")?" ; \ - "([^?#]*)" ; #5 = path - "(?:\\?" ; / question-query-opt - "([^#]*)" ; | #6 = query-opt - ")?" ; \ - "(?:#" ; / hash-fragment-opt - "(.*)" ; | #7 = fragment-opt - ")?" ; \ - "$"))) - -;; string->url : str -> url -;; Original version by Neil Van Dyke -(define (string->url str) - (apply - (lambda (scheme user host port path query fragment) - (when (and scheme (not (regexp-match? #rx"^[a-zA-Z][a-zA-Z0-9+.-]*$" - scheme))) - (url-error "Invalid URL string; bad scheme ~e: ~e" scheme str)) - ;; Windows => "file://xxx:/...." specifies a "xxx:/..." path - (let ([win-file? (and (or (equal? "" port) (not port)) - (equal? "file" scheme) - (eq? 'windows (file-url-path-convention-type)) - (not (equal? host "")))]) - (when win-file? - (set! path (cond [(equal? "" port) (string-append host ":" path)] - [(and path host) (string-append host "/" path)] - [else (or path host)])) - (set! port #f) - (set! host "")) - (let* ([scheme (and scheme (string-downcase scheme))] - [host (and host (string-downcase host))] - [user (uri-decode/maybe user)] - [port (and port (string->number port))] - [abs? (or (equal? "file" scheme) - (regexp-match? #rx"^/" path))] - [path (if win-file? - (separate-windows-path-strings path) - (separate-path-strings path))] - [query (if query (form-urlencoded->alist query) '())] - [fragment (uri-decode/maybe fragment)]) - (make-url scheme user host port abs? path query fragment)))) - (cdr (or (regexp-match url-rx str) - (url-error "Invalid URL string: ~e" str))))) - -(define (uri-decode/maybe f) (friendly-decode/maybe f uri-decode)) - -(define (friendly-decode/maybe f uri-decode) - ;; If #f, and leave unmolested any % that is followed by hex digit - ;; if a % is not followed by a hex digit, replace it with %25 - ;; in an attempt to be "friendly" - (and f (uri-decode (regexp-replace* #rx"%([^0-9a-fA-F])" f "%25\\1")))) - -;; separate-path-strings : string[starting with /] -> (listof path/param) -(define (separate-path-strings str) - (let ([strs (regexp-split #rx"/" str)]) - (map separate-params (if (string=? "" (car strs)) (cdr strs) strs)))) - -(define (separate-windows-path-strings str) - (url-path (path->url (bytes->path (string->bytes/utf-8 str) 'windows)))) - -(define (separate-params s) - (let ([lst (map path-segment-decode (regexp-split #rx";" s))]) - (make-path/param (car lst) (cdr lst)))) - -(define (path-segment-decode p) - (cond [(string=? p "..") 'up] - [(string=? p ".") 'same] - [else (uri-path-segment-decode p)])) - -(define (path-segment-encode p) - (cond [(eq? p 'up) ".."] - [(eq? p 'same) "."] - [(equal? p "..") "%2e%2e"] - [(equal? p ".") "%2e"] - [else (uri-path-segment-encode p)])) - -(define (combine-path-strings absolute? path/params) - (cond [(null? path/params) ""] - [else (let ([p (string-join (map join-params path/params) "/")]) - (if absolute? (string-append "/" p) p))])) - -(define (join-params s) - (string-join (map path-segment-encode - (cons (path/param-path s) (path/param-param s))) - ";")) - -(define (path->url path) - (let ([url-path - (let loop ([path (simplify-path path #f)][accum null]) - (let-values ([(base name dir?) (split-path path)]) - (cond - [(not base) - (append (map - (lambda (s) - (make-path/param s null)) - (if (eq? (path-convention-type path) 'windows) - ;; For Windows, massage the root: - (let ([s (regexp-replace - #rx"[/\\\\]$" - (bytes->string/utf-8 (path->bytes name)) - "")]) - (cond - [(regexp-match? #rx"^\\\\\\\\[?]\\\\[a-zA-Z]:" s) - ;; \\?\: path: - (regexp-split #rx"[/\\]+" (substring s 4))] - [(regexp-match? #rx"^\\\\\\\\[?]\\\\UNC" s) - ;; \\?\ UNC path: - (regexp-split #rx"[/\\]+" (substring s 7))] - [(regexp-match? #rx"^[/\\]" s) - ;; UNC path: - (regexp-split #rx"[/\\]+" s)] - [else - (list s)])) - ;; On other platforms, we drop the root: - null)) - accum)] - [else - (let ([accum (cons (make-path/param - (if (symbol? name) - name - (bytes->string/utf-8 - (path-element->bytes name))) - null) - accum)]) - (if (eq? base 'relative) - accum - (loop base accum)))])))]) - (make-url "file" #f "" #f (absolute-path? path) url-path '() #f))) - -(define (url->path url [kind (system-path-convention-type)]) - (file://->path url kind)) - -;; delete-pure-port : url [x list (str)] -> in-port -(define (delete-pure-port url [strings '()]) - (method-pure-port 'delete url #f strings)) - -;; delete-impure-port : url [x list (str)] -> in-port -(define (delete-impure-port url [strings '()]) - (method-impure-port 'delete url #f strings)) - -;; head-pure-port : url [x list (str)] -> in-port -(define (head-pure-port url [strings '()]) - (method-pure-port 'head url #f strings)) - -;; head-impure-port : url [x list (str)] -> in-port -(define (head-impure-port url [strings '()]) - (method-impure-port 'head url #f strings)) - -;; put-pure-port : url bytes [x list (str)] -> in-port -(define (put-pure-port url put-data [strings '()]) - (method-pure-port 'put url put-data strings)) - -;; put-impure-port : url x bytes [x list (str)] -> in-port -(define (put-impure-port url put-data [strings '()]) - (method-impure-port 'put url put-data strings)) - -;; method-impure-port : symbol x url x list (str) -> in-port -(define (method-impure-port method url data strings) - (let ([scheme (url-scheme url)]) - (cond [(not scheme) - (schemeless-url url)] - [(or (string=? scheme "http") (string=? scheme "https")) - (http://method-impure-port method url data strings)] - [(string=? scheme "file") - (url-error "There are no impure file: ports")] - [else (url-error "Scheme ~a unsupported" scheme)]))) - -;; method-pure-port : symbol x url x list (str) -> in-port -(define (method-pure-port method url data strings) - (let ([scheme (url-scheme url)]) - (cond [(not scheme) - (schemeless-url url)] - [(or (string=? scheme "http") (string=? scheme "https")) - (let ([port (http://method-impure-port - method url data strings)]) - (purify-http-port port))] - [(string=? scheme "file") - (file://get-pure-port url)] - [else (url-error "Scheme ~a unsupported" scheme)]))) - -;; http://metod-impure-port : symbol x url x union (str, #f) x list (str) -> in-port -(define (http://method-impure-port method url data strings) - (let*-values - ([(method) (case method - [(get) "GET"] [(post) "POST"] [(head) "HEAD"] - [(put) "PUT"] [(delete) "DELETE"] - [else (url-error "unsupported method: ~a" method)])] - [(proxy) (assoc (url-scheme url) (current-proxy-servers))] - [(server->client client->server) (make-ports url proxy)] - [(access-string) (url->string - (if proxy - url - (make-url #f #f #f #f - (url-path-absolute? url) - (url-path url) - (url-query url) - (url-fragment url))))]) - (define (println . xs) - (for-each (lambda (x) (display x client->server)) xs) - (display "\r\n" client->server)) - (println method " " access-string " HTTP/1.0") - (println "Host: " (url-host url) - (let ([p (url-port url)]) (if p (format ":~a" p) ""))) - (when data (println "Content-Length: " (bytes-length data))) - (for-each println strings) - (println) - (when data (display data client->server)) - (flush-output client->server) - (tcp-abandon-port client->server) - server->client)) +(provide url@) diff --git a/collects/net/url.rkt b/collects/net/url.rkt index 7ceea392c4..d2afbc9d8b 100644 --- a/collects/net/url.rkt +++ b/collects/net/url.rkt @@ -1,39 +1,610 @@ #lang racket/base -(require racket/unit racket/contract - (rename-in racket/tcp - [tcp-connect plain-tcp-connect] - [tcp-abandon-port plain-tcp-abandon-port]) - openssl - "tcp-sig.rkt" - "url-structs.rkt" "url-sig.rkt" "url-unit.rkt") +(require racket/unit racket/port racket/string racket/contract + "url-connect.rkt" + "url-structs.rkt" + "uri-codec.rkt") -;; Define `tcp-connect' and `tcp-abandon-port' to fit with -;; `current-connect-scheme' from `url-unt@' -(define (tcp-connect host port) - (cond - [(equal? (current-connect-scheme) "https") - (ssl-connect host port (current-https-protocol))] - [else - (plain-tcp-connect host port)])) +;; To do: +;; Handle HTTP/file errors. +;; Not throw away MIME headers. +;; Determine file type. -(define (tcp-abandon-port port) - (cond - [(ssl-port? port) (ssl-abandon-port port)] - [else (plain-tcp-abandon-port port)])) +;; ---------------------------------------------------------------------- -(define-unit-from-context tcp@ tcp^) +;; Input ports have two statuses: +;; "impure" = they have text waiting +;; "pure" = the MIME headers have been read -(define-compound-unit/infer url+tcp@ - (import) (export url^) - (link tcp@ url@)) +(define-struct (url-exception exn:fail) ()) -(define-values/invoke-unit/infer url+tcp@) +(define file-url-path-convention-type (make-parameter (system-path-convention-type))) + +(define current-proxy-servers + (make-parameter null + (lambda (v) + (unless (and (list? v) + (andmap (lambda (v) + (and (list? v) + (= 3 (length v)) + (equal? (car v) "http") + (string? (car v)) + (exact-integer? (caddr v)) + (<= 1 (caddr v) 65535))) + v)) + (raise-type-error + 'current-proxy-servers + "list of list of scheme, string, and exact integer in [1,65535]" + v)) + (map (lambda (v) + (list (string->immutable-string (car v)) + (string->immutable-string (cadr v)) + (caddr v))) + v)))) + +(define (url-error fmt . args) + (raise (make-url-exception + (apply format fmt + (map (lambda (arg) (if (url? arg) (url->string arg) arg)) + args)) + (current-continuation-marks)))) + +(define (url->string url) + (let ([scheme (url-scheme url)] + [user (url-user url)] + [host (url-host url)] + [port (url-port url)] + [path (url-path url)] + [query (url-query url)] + [fragment (url-fragment url)] + [sa string-append]) + (when (and (equal? scheme "file") + (not (url-path-absolute? url))) + (raise-mismatch-error 'url->string + "cannot convert relative file URL to a string: " + url)) + (sa (if scheme (sa scheme ":") "") + (if (or user host port) + (sa "//" + (if user (sa (uri-userinfo-encode user) "@") "") + (if host host "") + (if port (sa ":" (number->string port)) "") + ;; There used to be a "/" here, but that causes an + ;; extra leading slash -- wonder why it ever worked! + ) + (if (equal? "file" scheme) ; always need "//" for "file" URLs + "//" + "")) + (combine-path-strings (url-path-absolute? url) path) + ;; (if query (sa "?" (uri-encode query)) "") + (if (null? query) "" (sa "?" (alist->form-urlencoded query))) + (if fragment (sa "#" (uri-encode fragment)) "")))) + +;; url->default-port : url -> num +(define (url->default-port url) + (let ([scheme (url-scheme url)]) + (cond [(not scheme) 80] + [(string=? scheme "http") 80] + [(string=? scheme "https") 443] + [else (url-error "URL scheme ~s not supported" scheme)]))) + +;; make-ports : url -> in-port x out-port +(define (make-ports url proxy) + (let ([port-number (if proxy + (caddr proxy) + (or (url-port url) (url->default-port url)))] + [host (if proxy (cadr proxy) (url-host url))]) + (parameterize ([current-connect-scheme (url-scheme url)]) + (tcp-connect host port-number)))) + +;; http://getpost-impure-port : bool x url x union (str, #f) x list (str) -> in-port +(define (http://getpost-impure-port get? url post-data strings) + (define proxy (assoc (url-scheme url) (current-proxy-servers))) + (define-values (server->client client->server) (make-ports url proxy)) + (define access-string + (url->string + (if proxy + url + ;; RFCs 1945 and 2616 say: + ;; Note that the absolute path cannot be empty; if none is present in + ;; the original URI, it must be given as "/" (the server root). + (let-values ([(abs? path) + (if (null? (url-path url)) + (values #t (list (make-path/param "" '()))) + (values (url-path-absolute? url) (url-path url)))]) + (make-url #f #f #f #f abs? path (url-query url) (url-fragment url)))))) + (define (println . xs) + (for-each (lambda (x) (display x client->server)) xs) + (display "\r\n" client->server)) + (println (if get? "GET " "POST ") access-string " HTTP/1.0") + (println "Host: " (url-host url) + (let ([p (url-port url)]) (if p (format ":~a" p) ""))) + (when post-data (println "Content-Length: " (bytes-length post-data))) + (for-each println strings) + (println) + (when post-data (display post-data client->server)) + (flush-output client->server) + (tcp-abandon-port client->server) + server->client) + +(define (file://->path url [kind (system-path-convention-type)]) + (let ([strs (map path/param-path (url-path url))] + [string->path-element/same + (lambda (e) + (if (symbol? e) + e + (if (string=? e "") + 'same + (bytes->path-element (string->bytes/locale e) kind))))] + [string->path/win (lambda (s) + (bytes->path (string->bytes/utf-8 s) 'windows))]) + (if (and (url-path-absolute? url) + (eq? 'windows kind)) + ;; If initial path is "", then build UNC path. + (cond + [(not (url-path-absolute? url)) + (apply build-path (map string->path-element/same strs))] + [(and ((length strs) . >= . 3) + (equal? (car strs) "")) + (apply build-path + (string->path/win + (string-append "\\\\" (cadr strs) "\\" (caddr strs) "\\")) + (map string->path-element/same (cdddr strs)))] + [(pair? strs) + (apply build-path (string->path/win (car strs)) + (map string->path-element/same (cdr strs)))] + [else (error 'file://->path "no path elements: ~e" url)]) + (let ([elems (map string->path-element/same strs)]) + (if (url-path-absolute? url) + (apply build-path (bytes->path #"/" 'unix) elems) + (apply build-path elems)))))) + +;; file://get-pure-port : url -> in-port +(define (file://get-pure-port url) + (open-input-file (file://->path url))) + +(define (schemeless-url url) + (url-error "Missing protocol (usually \"http:\") at the beginning of URL: ~a" url)) + +;; getpost-impure-port : bool x url x list (str) -> in-port +(define (getpost-impure-port get? url post-data strings) + (let ([scheme (url-scheme url)]) + (cond [(not scheme) + (schemeless-url url)] + [(or (string=? scheme "http") (string=? scheme "https")) + (http://getpost-impure-port get? url post-data strings)] + [(string=? scheme "file") + (url-error "There are no impure file: ports")] + [else (url-error "Scheme ~a unsupported" scheme)]))) + +;; get-impure-port : url [x list (str)] -> in-port +(define (get-impure-port url [strings '()]) + (getpost-impure-port #t url #f strings)) + +;; post-impure-port : url x bytes [x list (str)] -> in-port +(define (post-impure-port url post-data [strings '()]) + (getpost-impure-port #f url post-data strings)) + +;; getpost-pure-port : bool x url x list (str) -> in-port +(define (getpost-pure-port get? url post-data strings) + (let ([scheme (url-scheme url)]) + (cond [(not scheme) + (schemeless-url url)] + [(or (string=? scheme "http") + (string=? scheme "https")) + (let ([port (http://getpost-impure-port + get? url post-data strings)]) + (purify-http-port port))] + [(string=? scheme "file") + (file://get-pure-port url)] + [else (url-error "Scheme ~a unsupported" scheme)]))) + +;; get-pure-port : url [x list (str)] -> in-port +(define (get-pure-port url [strings '()]) + (getpost-pure-port #t url #f strings)) + +;; post-pure-port : url bytes [x list (str)] -> in-port +(define (post-pure-port url post-data [strings '()]) + (getpost-pure-port #f url post-data strings)) + +;; display-pure-port : in-port -> () +(define (display-pure-port server->client) + (copy-port server->client (current-output-port)) + (close-input-port server->client)) + +;; transliteration of code in rfc 3986, section 5.2.2 +(define (combine-url/relative Base string) + (let ([R (string->url string)] + [T (make-url #f #f #f #f #f '() '() #f)]) + (if (url-scheme R) + (begin + (set-url-scheme! T (url-scheme R)) + (set-url-user! T (url-user R)) ;; authority + (set-url-host! T (url-host R)) ;; authority + (set-url-port! T (url-port R)) ;; authority + (set-url-path-absolute?! T (url-path-absolute? R)) + (set-url-path! T (remove-dot-segments (url-path R))) + (set-url-query! T (url-query R))) + (begin + (if (url-host R) ;; => authority is defined + (begin + (set-url-user! T (url-user R)) ;; authority + (set-url-host! T (url-host R)) ;; authority + (set-url-port! T (url-port R)) ;; authority + (set-url-path-absolute?! T (url-path-absolute? R)) + (set-url-path! T (remove-dot-segments (url-path R))) + (set-url-query! T (url-query R))) + (begin + (if (null? (url-path R)) ;; => R has empty path + (begin + (set-url-path-absolute?! T (url-path-absolute? Base)) + (set-url-path! T (url-path Base)) + (if (not (null? (url-query R))) + (set-url-query! T (url-query R)) + (set-url-query! T (url-query Base)))) + (begin + (cond + [(url-path-absolute? R) + (set-url-path-absolute?! T #t) + (set-url-path! T (remove-dot-segments (url-path R)))] + [(and (null? (url-path Base)) + (url-host Base)) + (set-url-path-absolute?! T #t) + (set-url-path! T (remove-dot-segments (url-path R)))] + [else + (set-url-path-absolute?! T (url-path-absolute? Base)) + (set-url-path! T (remove-dot-segments + (append (all-but-last (url-path Base)) + (url-path R))))]) + (set-url-query! T (url-query R)))) + (set-url-user! T (url-user Base)) ;; authority + (set-url-host! T (url-host Base)) ;; authority + (set-url-port! T (url-port Base)))) ;; authority + (set-url-scheme! T (url-scheme Base)))) + (set-url-fragment! T (url-fragment R)) + T)) + +(define (all-but-last lst) + (cond [(null? lst) null] + [(null? (cdr lst)) null] + [else (cons (car lst) (all-but-last (cdr lst)))])) + +;; cribbed from 5.2.4 in rfc 3986 +;; the strange [*] cases implicitly change urls +;; with paths segments "." and ".." at the end +;; into "./" and "../" respectively +(define (remove-dot-segments path) + (let loop ([path path] [result '()]) + (if (null? path) + (reverse result) + (let ([fst (path/param-path (car path))] + [rst (cdr path)]) + (loop rst + (cond + [(and (eq? fst 'same) (null? rst)) + (cons (make-path/param "" '()) result)] ; [*] + [(eq? fst 'same) + result] + [(and (eq? fst 'up) (null? rst) (not (null? result))) + (cons (make-path/param "" '()) (cdr result))] ; [*] + [(and (eq? fst 'up) (not (null? result))) + (cdr result)] + [(and (eq? fst 'up) (null? result)) + ;; when we go up too far, just drop the "up"s. + result] + [else + (cons (car path) result)])))))) + +;; call/input-url : url x (url -> in-port) x (in-port -> T) +;; [x list (str)] -> T +(define call/input-url + (let ([handle-port + (lambda (server->client handler) + (dynamic-wind (lambda () 'do-nothing) + (lambda () (handler server->client)) + (lambda () (close-input-port server->client))))]) + (case-lambda + [(url getter handler) + (handle-port (getter url) handler)] + [(url getter handler params) + (handle-port (getter url params) handler)]))) + +;; purify-port : in-port -> header-string +(define (purify-port port) + (let ([m (regexp-match-peek-positions + #rx"^HTTP/.*?(?:\r\n\r\n|\n\n|\r\r)" port)]) + (if m (read-string (cdar m) port) ""))) + +;; purify-http-port : in-port -> in-port +;; returns a new port, closes the old one when done pumping +(define (purify-http-port in-port) + (define-values (in-pipe out-pipe) (make-pipe)) + (thread + (λ () + (define status (http-read-status in-port)) + (define chunked? (http-read-headers in-port)) + (http-pipe-data chunked? in-port out-pipe) + (close-input-port in-port))) + in-pipe) + +(define (http-read-status ip) + (read-line ip 'return-linefeed)) + +(define (http-read-headers ip) + (define l (read-line ip 'return-linefeed)) + (when (eof-object? l) + (error 'purify-http-port "Connection ended before headers ended")) + (if (string=? l "") + #f + (if (string=? l "Transfer-Encoding: chunked") + (begin (http-read-headers ip) + #t) + (http-read-headers ip)))) + +(define (http-pipe-data chunked? ip op) + (if chunked? + (http-pipe-chunk ip op) + (begin + (copy-port ip op) + (flush-output op) + (close-output-port op)))) + +(define (http-pipe-chunk ip op) + (define size-str (read-line ip 'return-linefeed)) + (define chunk-size (string->number size-str 16)) + (unless chunk-size + (error 'http-pipe-chunk "Could not parse ~S as hexadecimal number" size-str)) + (if (zero? chunk-size) + (begin (flush-output op) + (close-output-port op)) + (let* ([bs (read-bytes chunk-size ip)] + [crlf (read-bytes 2 ip)]) + (write-bytes bs op) + (http-pipe-chunk ip op)))) + +(define character-set-size 256) + +;; netscape/string->url : str -> url +(define (netscape/string->url string) + (let ([url (string->url string)]) + (cond [(url-scheme url) url] + [(string=? string "") + (url-error "Can't resolve empty string as URL")] + [else (set-url-scheme! url + (if (char=? (string-ref string 0) #\/) "file" "http")) + url]))) + +;; URL parsing regexp +;; this is following the regexp in Appendix B of rfc 3986, except for using +;; `*' instead of `+' for the scheme part (it is checked later anyway, and +;; we don't want to parse it as a path element), and the user@host:port is +;; parsed here. +(define url-rx + (regexp (string-append + "^" + "(?:" ; / scheme-colon-opt + "([^:/?#]*)" ; | #1 = scheme-opt + ":)?" ; \ + "(?://" ; / slash-slash-authority-opt + "(?:" ; | / user-at-opt + "([^/?#@]*)" ; | | #2 = user-opt + "@)?" ; | \ + "([^/?#:]*)?" ; | #3 = host-opt + "(?::" ; | / colon-port-opt + "([0-9]*)" ; | | #4 = port-opt + ")?" ; | \ + ")?" ; \ + "([^?#]*)" ; #5 = path + "(?:\\?" ; / question-query-opt + "([^#]*)" ; | #6 = query-opt + ")?" ; \ + "(?:#" ; / hash-fragment-opt + "(.*)" ; | #7 = fragment-opt + ")?" ; \ + "$"))) + +;; string->url : str -> url +;; Original version by Neil Van Dyke +(define (string->url str) + (apply + (lambda (scheme user host port path query fragment) + (when (and scheme (not (regexp-match? #rx"^[a-zA-Z][a-zA-Z0-9+.-]*$" + scheme))) + (url-error "Invalid URL string; bad scheme ~e: ~e" scheme str)) + ;; Windows => "file://xxx:/...." specifies a "xxx:/..." path + (let ([win-file? (and (or (equal? "" port) (not port)) + (equal? "file" scheme) + (eq? 'windows (file-url-path-convention-type)) + (not (equal? host "")))]) + (when win-file? + (set! path (cond [(equal? "" port) (string-append host ":" path)] + [(and path host) (string-append host "/" path)] + [else (or path host)])) + (set! port #f) + (set! host "")) + (let* ([scheme (and scheme (string-downcase scheme))] + [host (and host (string-downcase host))] + [user (uri-decode/maybe user)] + [port (and port (string->number port))] + [abs? (or (equal? "file" scheme) + (regexp-match? #rx"^/" path))] + [path (if win-file? + (separate-windows-path-strings path) + (separate-path-strings path))] + [query (if query (form-urlencoded->alist query) '())] + [fragment (uri-decode/maybe fragment)]) + (make-url scheme user host port abs? path query fragment)))) + (cdr (or (regexp-match url-rx str) + (url-error "Invalid URL string: ~e" str))))) + +(define (uri-decode/maybe f) (friendly-decode/maybe f uri-decode)) + +(define (friendly-decode/maybe f uri-decode) + ;; If #f, and leave unmolested any % that is followed by hex digit + ;; if a % is not followed by a hex digit, replace it with %25 + ;; in an attempt to be "friendly" + (and f (uri-decode (regexp-replace* #rx"%([^0-9a-fA-F])" f "%25\\1")))) + +;; separate-path-strings : string[starting with /] -> (listof path/param) +(define (separate-path-strings str) + (let ([strs (regexp-split #rx"/" str)]) + (map separate-params (if (string=? "" (car strs)) (cdr strs) strs)))) + +(define (separate-windows-path-strings str) + (url-path (path->url (bytes->path (string->bytes/utf-8 str) 'windows)))) + +(define (separate-params s) + (let ([lst (map path-segment-decode (regexp-split #rx";" s))]) + (make-path/param (car lst) (cdr lst)))) + +(define (path-segment-decode p) + (cond [(string=? p "..") 'up] + [(string=? p ".") 'same] + [else (uri-path-segment-decode p)])) + +(define (path-segment-encode p) + (cond [(eq? p 'up) ".."] + [(eq? p 'same) "."] + [(equal? p "..") "%2e%2e"] + [(equal? p ".") "%2e"] + [else (uri-path-segment-encode p)])) + +(define (combine-path-strings absolute? path/params) + (cond [(null? path/params) ""] + [else (let ([p (string-join (map join-params path/params) "/")]) + (if absolute? (string-append "/" p) p))])) + +(define (join-params s) + (string-join (map path-segment-encode + (cons (path/param-path s) (path/param-param s))) + ";")) + +(define (path->url path) + (let ([url-path + (let loop ([path (simplify-path path #f)][accum null]) + (let-values ([(base name dir?) (split-path path)]) + (cond + [(not base) + (append (map + (lambda (s) + (make-path/param s null)) + (if (eq? (path-convention-type path) 'windows) + ;; For Windows, massage the root: + (let ([s (regexp-replace + #rx"[/\\\\]$" + (bytes->string/utf-8 (path->bytes name)) + "")]) + (cond + [(regexp-match? #rx"^\\\\\\\\[?]\\\\[a-zA-Z]:" s) + ;; \\?\: path: + (regexp-split #rx"[/\\]+" (substring s 4))] + [(regexp-match? #rx"^\\\\\\\\[?]\\\\UNC" s) + ;; \\?\ UNC path: + (regexp-split #rx"[/\\]+" (substring s 7))] + [(regexp-match? #rx"^[/\\]" s) + ;; UNC path: + (regexp-split #rx"[/\\]+" s)] + [else + (list s)])) + ;; On other platforms, we drop the root: + null)) + accum)] + [else + (let ([accum (cons (make-path/param + (if (symbol? name) + name + (bytes->string/utf-8 + (path-element->bytes name))) + null) + accum)]) + (if (eq? base 'relative) + accum + (loop base accum)))])))]) + (make-url "file" #f "" #f (absolute-path? path) url-path '() #f))) + +(define (url->path url [kind (system-path-convention-type)]) + (file://->path url kind)) + +;; delete-pure-port : url [x list (str)] -> in-port +(define (delete-pure-port url [strings '()]) + (method-pure-port 'delete url #f strings)) + +;; delete-impure-port : url [x list (str)] -> in-port +(define (delete-impure-port url [strings '()]) + (method-impure-port 'delete url #f strings)) + +;; head-pure-port : url [x list (str)] -> in-port +(define (head-pure-port url [strings '()]) + (method-pure-port 'head url #f strings)) + +;; head-impure-port : url [x list (str)] -> in-port +(define (head-impure-port url [strings '()]) + (method-impure-port 'head url #f strings)) + +;; put-pure-port : url bytes [x list (str)] -> in-port +(define (put-pure-port url put-data [strings '()]) + (method-pure-port 'put url put-data strings)) + +;; put-impure-port : url x bytes [x list (str)] -> in-port +(define (put-impure-port url put-data [strings '()]) + (method-impure-port 'put url put-data strings)) + +;; method-impure-port : symbol x url x list (str) -> in-port +(define (method-impure-port method url data strings) + (let ([scheme (url-scheme url)]) + (cond [(not scheme) + (schemeless-url url)] + [(or (string=? scheme "http") (string=? scheme "https")) + (http://method-impure-port method url data strings)] + [(string=? scheme "file") + (url-error "There are no impure file: ports")] + [else (url-error "Scheme ~a unsupported" scheme)]))) + +;; method-pure-port : symbol x url x list (str) -> in-port +(define (method-pure-port method url data strings) + (let ([scheme (url-scheme url)]) + (cond [(not scheme) + (schemeless-url url)] + [(or (string=? scheme "http") (string=? scheme "https")) + (let ([port (http://method-impure-port + method url data strings)]) + (purify-http-port port))] + [(string=? scheme "file") + (file://get-pure-port url)] + [else (url-error "Scheme ~a unsupported" scheme)]))) + +;; http://metod-impure-port : symbol x url x union (str, #f) x list (str) -> in-port +(define (http://method-impure-port method url data strings) + (let*-values + ([(method) (case method + [(get) "GET"] [(post) "POST"] [(head) "HEAD"] + [(put) "PUT"] [(delete) "DELETE"] + [else (url-error "unsupported method: ~a" method)])] + [(proxy) (assoc (url-scheme url) (current-proxy-servers))] + [(server->client client->server) (make-ports url proxy)] + [(access-string) (url->string + (if proxy + url + (make-url #f #f #f #f + (url-path-absolute? url) + (url-path url) + (url-query url) + (url-fragment url))))]) + (define (println . xs) + (for-each (lambda (x) (display x client->server)) xs) + (display "\r\n" client->server)) + (println method " " access-string " HTTP/1.0") + (println "Host: " (url-host url) + (let ([p (url-port url)]) (if p (format ":~a" p) ""))) + (when data (println "Content-Length: " (bytes-length data))) + (for-each println strings) + (println) + (when data (display data client->server)) + (flush-output client->server) + (tcp-abandon-port client->server) + server->client)) (provide (struct-out url) (struct-out path/param)) -(define current-https-protocol (make-parameter 'sslv2-or-v3)) -(provide current-https-protocol) - (provide/contract (string->url ((or/c bytes? string?) . -> . url?)) (path->url ((or/c path-string? path-for-some-system?) . -> . url?)) From 50d07dc67b1b9406aeeb04e6713db4490ea17d51 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 5 Sep 2011 15:13:00 -0400 Subject: [PATCH 159/235] typo --- collects/meta/web/www/people.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/meta/web/www/people.rkt b/collects/meta/web/www/people.rkt index a10ce4bda1..3259719f34 100644 --- a/collects/meta/web/www/people.rkt +++ b/collects/meta/web/www/people.rkt @@ -113,6 +113,6 @@ In particular, please check out the Racket-related work being done at @|-schematics|.} @h4{And ...} - @p{Finally, Racket is supported by an band of volunteers who contribute not + @p{Finally, Racket is supported by a band of volunteers who contribute not only code and documentation but also infectious enthusiasm—too many to name but whose help and encouragement make this fun and worthwhile.}}) From 6d944453a7ef9a444b36f97a76a143a35dd9858f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 5 Sep 2011 10:01:46 -0600 Subject: [PATCH 160/235] make memory accounting and places work together The `current-memory-use' function's result now includes the memory use of places created from the calling place, and custodian memory limits apply to memory use by places (owned by the custodian). This change is relevant to PR 12004 in that DrRacket will no longer crash on the example if a memory limit is in effect, but plain Racket starts with no such limit and will exhaust all memory. --- collects/meta/props | 1 + collects/tests/racket/runaway-place.rkt | 16 +++ src/racket/gc2/gc2.h | 36 ++++- src/racket/gc2/mem_account.c | 91 +++++++++---- src/racket/gc2/newgc.c | 125 ++++++++++++------ src/racket/gc2/newgc.h | 9 ++ src/racket/include/schthread.h | 2 + src/racket/src/env.c | 5 +- src/racket/src/place.c | 168 +++++++++++++++++++++--- src/racket/src/schpriv.h | 21 ++- src/racket/src/thread.c | 45 ++++++- 11 files changed, 423 insertions(+), 96 deletions(-) create mode 100644 collects/tests/racket/runaway-place.rkt diff --git a/collects/meta/props b/collects/meta/props index 8595c0e60e..f22fe1d92e 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1856,6 +1856,7 @@ path/s is either such a string or a list of them. "collects/tests/racket/read.rktl" drdr:command-line #f "collects/tests/racket/readtable.rktl" drdr:command-line (racket "-f" *) "collects/tests/racket/restart.rktl" drdr:command-line (racket "-f" *) +"collects/tests/racket/runaway-place.rkt" drdr:command-line (racket "-tm" *) "collects/tests/racket/runflats.rktl" drdr:command-line (racket "-f" *) "collects/tests/racket/rx.rktl" drdr:command-line #f "collects/tests/racket/sandbox.rktl" drdr:command-line (racket "-f" *) diff --git a/collects/tests/racket/runaway-place.rkt b/collects/tests/racket/runaway-place.rkt new file mode 100644 index 0000000000..f16584b69c --- /dev/null +++ b/collects/tests/racket/runaway-place.rkt @@ -0,0 +1,16 @@ +#lang racket/base +(require racket/place) + +(provide main runaway) + +(define (main) + (parameterize ([current-custodian (make-custodian)]) + (custodian-limit-memory (current-custodian) (* 1024 1024 64)) + (parameterize ([current-custodian (make-custodian)]) + (place-wait (place ch (runaway)))))) + +(define (runaway) + (printf "starting\n") + (define p (place ch (runaway))) + (place-wait p)) + diff --git a/src/racket/gc2/gc2.h b/src/racket/gc2/gc2.h index f7e61cdb8d..01c5de839a 100644 --- a/src/racket/gc2/gc2.h +++ b/src/racket/gc2/gc2.h @@ -33,7 +33,8 @@ typedef void (*GC_collect_start_callback_Proc)(void); typedef void (*GC_collect_end_callback_Proc)(void); typedef void (*GC_collect_inform_callback_Proc)(int master_gc, int major_gc, intptr_t pre_used, intptr_t post_used, - intptr_t pre_admin, intptr_t post_admin); + intptr_t pre_admin, intptr_t post_admin, + intptr_t post_child_places_used); typedef uintptr_t (*GC_get_thread_stack_base_Proc)(void); typedef void (*GC_Post_Propagate_Hook_Proc)(struct NewGC *); /* @@ -105,11 +106,13 @@ GC2_EXTERN void GC_register_root_custodian(void *); GC2_EXTERN void GC_register_new_thread(void *, void *); /* - Indicates that a just-allocated point is for a thread record - owned by a particular custodian. */ + Indicates that a just-allocated point is for a thread + or place owned by a particular custodian. */ + GC2_EXTERN void GC_register_thread(void *, void *); /* - Indicates that a a thread record is owned by a particular custodian. */ + Indicates that a a thread or place is now owned by a + particular custodian. */ GC2_EXTERN GC_collect_start_callback_Proc GC_set_collect_start_callback(GC_collect_start_callback_Proc); GC2_EXTERN GC_collect_end_callback_Proc GC_set_collect_end_callback(GC_collect_end_callback_Proc); @@ -150,6 +153,11 @@ GC2_EXTERN int GC_set_account_hook(int type, void *c1, uintptr_t b, void *c2); Set a memory-accounting property. Returns 0 for failure (i.e., not supported). */ +GC2_EXTERN uintptr_t GC_get_account_memory_limit(void *c1); +/* + Returns a moemory accounting limit for c1 (or any ancestor), + or 0 if none is set. */ + GC2_EXTERN void GC_gcollect(void); /* Performs an immediate (full) collection. */ @@ -433,19 +441,33 @@ GC2_EXTERN void GC_write_barrier(void *p); Explicit write barrier to ensure that a write-barrier signal is not triggered by a memory write. */ + GC2_EXTERN void GC_switch_out_master_gc(); /* Makes the current GC the master GC. Creates a new place specific GC and links it to the master GC. */ -GC2_EXTERN void GC_construct_child_gc(); + +GC2_EXTERN struct NewGC *GC_get_current_instance(); /* - Creates a new place specific GC and links to the master GC. + Returns a representation of the current GC. */ +GC2_EXTERN void GC_construct_child_gc(struct NewGC *parent_gc, intptr_t limit); +/* + Creates a new place-specific GC that is a child for memory-accounting + purposes of the give parent GC. If `limit' is not 0, set the maximum + amount of memory the new GC is supposed to use. +*/ + +GC2_EXTERN intptr_t GC_propagate_hierarchy_memory_use(); +/* + Notifies the parent GC (if any) of memory use by the current GC + and its children. The result is total memory use. */ + GC2_EXTERN void GC_destruct_child_gc(); /* - Destroys a place specific GC once the place has finished. + Destroys a place-specific GC once the place has finished. */ GC2_EXTERN void *GC_switch_to_master_gc(); diff --git a/src/racket/gc2/mem_account.c b/src/racket/gc2/mem_account.c index 9516c46fbc..2c5fcf1e6c 100644 --- a/src/racket/gc2/mem_account.c +++ b/src/racket/gc2/mem_account.c @@ -12,6 +12,8 @@ static const int btc_redirect_custodian = 510; static const int btc_redirect_ephemeron = 509; static const int btc_redirect_cust_box = 508; +inline static void account_memory(NewGC *gc, int set, intptr_t amount); + /*****************************************************************************/ /* thread list */ /*****************************************************************************/ @@ -23,7 +25,10 @@ inline static void BTC_register_new_thread(void *t, void *c) GC_Thread_Info *work; work = (GC_Thread_Info *)ofm_malloc(sizeof(GC_Thread_Info)); - ((Scheme_Thread *)t)->gc_info = work; + if (((Scheme_Object *)t)->type == scheme_thread_type) + ((Scheme_Thread *)t)->gc_info = work; + else + ((Scheme_Place *)t)->gc_info = work; work->owner = current_owner(gc, (Scheme_Custodian *)c); work->thread = t; @@ -35,8 +40,11 @@ inline static void BTC_register_thread(void *t, void *c) { NewGC *gc = GC_get_GC(); GC_Thread_Info *work; - - work = ((Scheme_Thread *)t)->gc_info; + + if (((Scheme_Object *)t)->type == scheme_thread_type) + work = ((Scheme_Thread *)t)->gc_info; + else + work = ((Scheme_Place *)t)->gc_info; work->owner = current_owner(gc, (Scheme_Custodian *)c); } @@ -45,15 +53,30 @@ inline static void mark_threads(NewGC *gc, int owner) GC_Thread_Info *work; Mark2_Proc thread_mark = gc->mark_table[btc_redirect_thread]; - for(work = gc->thread_infos; work; work = work->next) - if(work->owner == owner) { - if (((Scheme_Thread *)work->thread)->running) { - thread_mark(work->thread, gc); - if (work->thread == scheme_current_thread) { - GC_mark_variable_stack(GC_variable_stack, 0, get_stack_base(gc), NULL); + for(work = gc->thread_infos; work; work = work->next) { + if (work->owner == owner) { + if (((Scheme_Object *)work->thread)->type == scheme_thread_type) { + /* thread */ + if (((Scheme_Thread *)work->thread)->running) { + thread_mark(work->thread, gc); + if (work->thread == scheme_current_thread) { + GC_mark_variable_stack(GC_variable_stack, 0, get_stack_base(gc), NULL); + } + } + } else { + /* place */ + /* add in the memory used by the place's GC */ + intptr_t sz; + Scheme_Place_Object *place_obj = ((Scheme_Place *)work->thread)->place_obj; + if (place_obj) { + mzrt_mutex_lock(place_obj->lock); + sz = place_obj->memory_use; + mzrt_mutex_unlock(place_obj->lock); + account_memory(gc, owner, gcBYTES_TO_WORDS(sz)); } } } + } } inline static void clean_up_thread_list(NewGC *gc) @@ -355,10 +378,10 @@ inline static void BTC_initialize_mark_table(NewGC *gc) { } inline static int BTC_get_redirect_tag(NewGC *gc, int tag) { - if (tag == scheme_thread_type ) { tag = btc_redirect_thread; } - else if (tag == scheme_custodian_type ) { tag = btc_redirect_custodian; } - else if (tag == gc->ephemeron_tag ) { tag = btc_redirect_ephemeron; } - else if (tag == gc->cust_box_tag ) { tag = btc_redirect_cust_box; } + if (tag == scheme_thread_type) { tag = btc_redirect_thread; } + else if (tag == scheme_custodian_type) { tag = btc_redirect_custodian; } + else if (tag == gc->ephemeron_tag) { tag = btc_redirect_ephemeron; } + else if (tag == gc->cust_box_tag) { tag = btc_redirect_cust_box; } return tag; } @@ -535,7 +558,7 @@ inline static void BTC_run_account_hooks(NewGC *gc) AccountHook *work = gc->hooks; AccountHook *prev = NULL; - while(work) { + while (work) { if( ((work->type == MZACCT_REQUIRE) && ((gc->used_pages > (gc->max_pages_for_use / 2)) || ((((gc->max_pages_for_use / 2) - gc->used_pages) * APAGE_SIZE) @@ -563,7 +586,7 @@ static uintptr_t custodian_single_time_limit(NewGC *gc, int set) const int table_size = gc->owner_table_size; if (!set) - return (uintptr_t)(intptr_t)-1; + return gc->place_memory_limit; if (gc->reset_limits) { int i; @@ -575,7 +598,7 @@ static uintptr_t custodian_single_time_limit(NewGC *gc, int set) if (!owner_table[set]->limit_set) { /* Check for limits on this custodian or one of its ancestors: */ - uintptr_t limit = (uintptr_t)-1; + uintptr_t limit = gc->place_memory_limit; Scheme_Custodian *orig = (Scheme_Custodian *) owner_table[set]->originator, *c; AccountHook *work = gc->hooks; @@ -614,21 +637,39 @@ intptr_t BTC_get_memory_use(NewGC* gc, void *o) return 0; } -int BTC_single_allocation_limit(NewGC *gc, size_t sizeb) { - /* We're allowed to fail. Check for allocations that exceed a single-time - * limit. Otherwise, the limit doesn't work as intended, because - * a program can allocate a large block that nearly exhausts memory, - * and then a subsequent allocation can fail. As long as the limit - * is much smaller than the actual available memory, and as long as - * GC_out_of_memory protects any user-requested allocation whose size - * is independent of any existing object, then we can enforce the limit. */ +int BTC_single_allocation_limit(NewGC *gc, size_t sizeb) +/* Use this function to check for allocations that exceed a single-time + * limit. Otherwise, the limit doesn't work as intended, because + * a program can allocate a large block that nearly exhausts memory, + * and then a subsequent allocation can fail. As long as the limit + * is much smaller than the actual available memory, and as long as + * GC_out_of_memory protects any user-requested allocation whose size + * is independent of any existing object, then we can enforce the limit. */ +{ Scheme_Thread *p = scheme_current_thread; if (p) return (custodian_single_time_limit(gc, thread_get_owner(p)) < sizeb); else - return 0; + return (gc->place_memory_limit < sizeb); } +static uintptr_t BTC_get_account_hook(void *c1) +{ + NewGC *gc = GC_get_GC(); + uintptr_t mem; + + if (!gc->really_doing_accounting) + return 0; + + mem = custodian_single_time_limit(gc, custodian_to_owner_set(gc, c1)); + + if (mem == (uintptr_t)(intptr_t)-1) + return 0; + + return mem; +} + + static inline void BTC_clean_up(NewGC *gc) { clean_up_thread_list(gc); clean_up_owner_table(gc); diff --git a/src/racket/gc2/newgc.c b/src/racket/gc2/newgc.c index ed6a4479e4..9bd3b93d6e 100644 --- a/src/racket/gc2/newgc.c +++ b/src/racket/gc2/newgc.c @@ -5,9 +5,7 @@ Please see full copyright in the documentation Search for "FIXME" for known improvement points - IF YOU'RE NOT ADAM (AND PROBABLY IF YOU ARE) READ THIS FIRST: - - This is now a hybrid copying/mark-compact collector. The nursery + This is a hybrid copying/mark-compact collector. The nursery (generation 0) is copied into the old generation (generation 1), but the old generation compacts. This yields a nice combination of performance, scalability and memory efficiency. @@ -889,20 +887,15 @@ static void *allocate_big(const size_t request_size_bytes, int type) #ifdef NEWGC_BTC_ACCOUNT if(GC_out_of_memory) { #ifdef MZ_USE_PLACES - if (premaster_or_place_gc(gc)) { + if (premaster_or_place_gc(gc)) { #endif - if (BTC_single_allocation_limit(gc, request_size_bytes)) { - /* We're allowed to fail. Check for allocations that exceed a single-time - limit. Otherwise, the limit doesn't work as intended, because - a program can allocate a large block that nearly exhausts memory, - and then a subsequent allocation can fail. As long as the limit - is much smaller than the actual available memory, and as long as - GC_out_of_memory protects any user-requested allocation whose size - is independent of any existing object, then we can enforce the limit. */ - GC_out_of_memory(); - } + if (BTC_single_allocation_limit(gc, request_size_bytes)) { + /* We're allowed to fail. Check for allocations that exceed a single-time + limit. See BTC_single_allocation_limit() for more information. */ + GC_out_of_memory(); + } #ifdef MZ_USE_PLACES - } + } #endif } #endif @@ -1666,7 +1659,7 @@ inline static void master_set_max_size(NewGC *gc) inline static void reset_nursery(NewGC *gc) { - uintptr_t new_gen0_size; + uintptr_t new_gen0_size; new_gen0_size = NUM((GEN0_SIZE_FACTOR * (float)gc->memory_in_use) + GEN0_SIZE_ADDITION); if(new_gen0_size > GEN0_MAX_SIZE) new_gen0_size = GEN0_MAX_SIZE; @@ -2255,12 +2248,28 @@ int GC_set_account_hook(int type, void *c1, uintptr_t b, void *c2) #endif } +uintptr_t GC_get_account_memory_limit(void *c1) +{ +#ifdef NEWGC_BTC_ACCOUNT + NewGC *gc = GC_get_GC(); + uintptr_t v = BTC_get_account_hook(c1); + if (gc->place_memory_limit < (uintptr_t)(intptr_t)-1) { + if (!v || (gc->place_memory_limit < v)) + return gc->place_memory_limit; + } + return v; +#else + return 0; +#endif +} + void GC_register_thread(void *t, void *c) { #ifdef NEWGC_BTC_ACCOUNT BTC_register_thread(t, c); #endif } + void GC_register_new_thread(void *t, void *c) { #ifdef NEWGC_BTC_ACCOUNT @@ -2560,14 +2569,15 @@ void GC_set_put_external_event_fd(void *fd) { } #endif -static void NewGC_initialize(NewGC *newgc, NewGC *parentgc) { - if (parentgc) { - newgc->mark_table = parentgc->mark_table; - newgc->fixup_table = parentgc->fixup_table; - newgc->dumping_avoid_collection = parentgc->dumping_avoid_collection - 1; - } - else { - +static void NewGC_initialize(NewGC *newgc, NewGC *inheritgc, NewGC *parentgc) { + if (inheritgc) { + newgc->mark_table = inheritgc->mark_table; + newgc->fixup_table = inheritgc->fixup_table; + newgc->dumping_avoid_collection = inheritgc->dumping_avoid_collection - 1; +#ifdef MZ_USE_PLACES + newgc->parent_gc = parentgc; +#endif + } else { #ifdef MZ_USE_PLACES NewGCMasterInfo_initialize(); #endif @@ -2595,10 +2605,17 @@ static void NewGC_initialize(NewGC *newgc, NewGC *parentgc) { newgc->generations_available = 1; newgc->last_full_mem_use = (20 * 1024 * 1024); newgc->new_btc_mark = 1; + + newgc->place_memory_limit = (uintptr_t)(intptr_t)-1; + +#ifdef MZ_USE_PLACES + mzrt_mutex_create(&newgc->child_total_lock); +#endif } /* NOTE This method sets the constructed GC as the new Thread Specific GC. */ -static NewGC *init_type_tags_worker(NewGC *parentgc, int count, int pair, int mutable_pair, int weakbox, int ephemeron, int weakarray, int custbox) +static NewGC *init_type_tags_worker(NewGC *inheritgc, NewGC *parentgc, + int count, int pair, int mutable_pair, int weakbox, int ephemeron, int weakarray, int custbox) { NewGC *gc; @@ -2617,7 +2634,7 @@ static NewGC *init_type_tags_worker(NewGC *parentgc, int count, int pair, int mu gc->cust_box_tag = custbox; # endif - NewGC_initialize(gc, parentgc); + NewGC_initialize(gc, inheritgc, parentgc); /* Our best guess at what the OS will let us allocate: */ @@ -2631,7 +2648,7 @@ static NewGC *init_type_tags_worker(NewGC *parentgc, int count, int pair, int mu gc->gen0.page_alloc_size = GEN0_PAGE_SIZE; resize_gen0(gc, GEN0_INITIAL_SIZE); - if (!parentgc) { + if (!inheritgc) { GC_register_traversers2(gc->weak_box_tag, size_weak_box, mark_weak_box, fixup_weak_box, 0, 0); GC_register_traversers2(gc->ephemeron_tag, size_ephemeron, mark_ephemeron, fixup_ephemeron, 0, 0); GC_register_traversers2(gc->weak_array_tag, size_weak_array, mark_weak_array, fixup_weak_array, 0, 0); @@ -2647,22 +2664,27 @@ void GC_init_type_tags(int count, int pair, int mutable_pair, int weakbox, int e { static int initialized = 0; - if(!initialized) { + if (!initialized) { initialized = 1; - init_type_tags_worker(NULL, count, pair, mutable_pair, weakbox, ephemeron, weakarray, custbox); - } - else { + init_type_tags_worker(NULL, NULL, count, pair, mutable_pair, weakbox, ephemeron, weakarray, custbox); + } else { GCPRINT(GCOUTF, "GC_init_type_tags should only be called once!\n"); abort(); } } +struct NewGC *GC_get_current_instance() { + return GC_get_GC(); +} + #ifdef MZ_USE_PLACES -void GC_construct_child_gc() { +void GC_construct_child_gc(struct NewGC *parent_gc, intptr_t limit) { NewGC *gc = MASTERGC; - NewGC *newgc = init_type_tags_worker(gc, 0, 0, 0, gc->weak_box_tag, gc->ephemeron_tag, gc->weak_array_tag, gc->cust_box_tag); + NewGC *newgc = init_type_tags_worker(gc, parent_gc, 0, 0, 0, gc->weak_box_tag, gc->ephemeron_tag, gc->weak_array_tag, gc->cust_box_tag); newgc->primoridal_gc = MASTERGC; newgc->dont_master_gc_until_child_registers = 1; + if (limit) + newgc->place_memory_limit = limit; } void GC_destruct_child_gc() { @@ -2729,7 +2751,7 @@ void GC_switch_out_master_gc() { MASTERGC->dumping_avoid_collection++; save_globals_to_gc(MASTERGC); - GC_construct_child_gc(); + GC_construct_child_gc(NULL, 0); GC_allow_master_gc_check(); } else { @@ -2825,12 +2847,19 @@ void GC_register_traversers(short tag, Size_Proc size, Mark_Proc mark, intptr_t GC_get_memory_use(void *o) { NewGC *gc = GC_get_GC(); + intptr_t amt; #ifdef NEWGC_BTC_ACCOUNT if(o) { return BTC_get_memory_use(gc, o); } #endif - return gen0_size_in_use(gc) + gc->memory_in_use; + amt = gen0_size_in_use(gc) + gc->memory_in_use; +#ifdef MZ_USE_PLACES + mzrt_mutex_lock(gc->child_total_lock); + amt += gc->child_gc_total; + mzrt_mutex_unlock(gc->child_total_lock); +#endif + return amt; } /*****************************************************************************/ @@ -4526,7 +4555,8 @@ static void garbage_collect(NewGC *gc, int force_full, int switching_master, Log #endif gc->GC_collect_inform_callback(is_master, gc->gc_full, old_mem_use + old_gen0, gc->memory_in_use, - old_mem_allocated, mmu_memory_allocated(gc->mmu)); + old_mem_allocated, mmu_memory_allocated(gc->mmu), + gc->child_gc_total); } #ifdef MZ_USE_PLACES if (lmi) { @@ -4537,6 +4567,7 @@ static void garbage_collect(NewGC *gc, int force_full, int switching_master, Log lmi->pre_admin = old_mem_allocated; lmi->post_admin = mmu_memory_allocated(gc->mmu); } + GC_propagate_hierarchy_memory_use(); #endif TIME_STEP("ended"); @@ -4601,7 +4632,8 @@ static void garbage_collect(NewGC *gc, int force_full, int switching_master, Log if (gc->GC_collect_inform_callback) { gc->GC_collect_inform_callback(1, sub_lmi.full, sub_lmi.pre_used, sub_lmi.post_used, - sub_lmi.pre_admin, sub_lmi.post_admin); + sub_lmi.pre_admin, sub_lmi.post_admin, + 0); } } } @@ -4609,6 +4641,25 @@ static void garbage_collect(NewGC *gc, int force_full, int switching_master, Log #endif } +intptr_t GC_propagate_hierarchy_memory_use() +{ + NewGC *gc = GC_get_GC(); + +#ifdef MZ_USE_PLACES + if (gc->parent_gc) { + /* report memory use to parent */ + intptr_t total = gc->memory_in_use + gc->child_gc_total; + intptr_t delta = total - gc->previously_reported_total; + mzrt_mutex_lock(gc->parent_gc->child_total_lock); + gc->parent_gc->child_gc_total += delta; + mzrt_mutex_unlock(gc->parent_gc->child_total_lock); + gc->previously_reported_total = total; + } +#endif + + return gc->memory_in_use + gc->child_gc_total; +} + #if MZ_GC_BACKTRACE static GC_get_type_name_proc stack_get_type_name; diff --git a/src/racket/gc2/newgc.h b/src/racket/gc2/newgc.h index 98234c6693..33f8839449 100644 --- a/src/racket/gc2/newgc.h +++ b/src/racket/gc2/newgc.h @@ -245,6 +245,15 @@ typedef struct NewGC { Allocator *saved_allocator; +#ifdef MZ_USE_PLACES + struct NewGC *parent_gc; /* parent for the purpose of reporting memory use */ + intptr_t previously_reported_total; /* how much we previously reported to the parent */ + mzrt_mutex *child_total_lock; /* lock on `child_gc_total' */ +#endif + intptr_t child_gc_total; + + uintptr_t place_memory_limit; /* set to propagate a custodian limit from a parent place */ + #if defined(GC_DEBUG_PAGES) FILE *GCVERBOSEFH; #endif diff --git a/src/racket/include/schthread.h b/src/racket/include/schthread.h index e4755fbf28..a5186c5235 100644 --- a/src/racket/include/schthread.h +++ b/src/racket/include/schthread.h @@ -122,6 +122,7 @@ typedef struct Thread_Local_Variables { uintptr_t GC_gen0_alloc_page_ptr_; uintptr_t GC_gen0_alloc_page_end_; int GC_gen0_alloc_only_; + uintptr_t force_gc_for_place_accounting_; void *bignum_cache_[BIGNUM_CACHE_SIZE]; int cache_count_; struct Scheme_Hash_Table *toplevels_ht_; @@ -459,6 +460,7 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL; #define GC_gen0_alloc_page_end XOA (scheme_get_thread_local_variables()->GC_gen0_alloc_page_end_) #define GC_gen0_alloc_only XOA (scheme_get_thread_local_variables()->GC_gen0_alloc_only_) #define GC_variable_stack XOA (scheme_get_thread_local_variables()->GC_variable_stack_) +#define force_gc_for_place_accounting XOA (scheme_get_thread_local_variables()->force_gc_for_place_accounting_) #define bignum_cache XOA (scheme_get_thread_local_variables()->bignum_cache_) #define cache_count XOA (scheme_get_thread_local_variables()->cache_count_) #define toplevels_ht XOA (scheme_get_thread_local_variables()->toplevels_ht_) diff --git a/src/racket/src/env.c b/src/racket/src/env.c index ae403f6eb2..6dd71fbf8b 100644 --- a/src/racket/src/env.c +++ b/src/racket/src/env.c @@ -113,7 +113,6 @@ static Scheme_Object *rename_transformer_p(int argc, Scheme_Object *argv[]); static void skip_certain_things(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void *data); Scheme_Env *scheme_engine_instance_init(); -Scheme_Env *scheme_place_instance_init(); static Scheme_Env *place_instance_init(void *stack_base, int initial_main_os_thread); #ifdef MZ_PRECISE_GC @@ -503,11 +502,11 @@ static Scheme_Env *place_instance_init(void *stack_base, int initial_main_os_thr return env; } -Scheme_Env *scheme_place_instance_init(void *stack_base) { +Scheme_Env *scheme_place_instance_init(void *stack_base, struct NewGC *parent_gc, intptr_t memory_limit) { Scheme_Env *env; #if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES) int *signal_fd; - GC_construct_child_gc(); + GC_construct_child_gc(parent_gc, memory_limit); #endif env = place_instance_init(stack_base, 0); #if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES) diff --git a/src/racket/src/place.c b/src/racket/src/place.c index ef59c6cfc5..16bb9a2bc1 100644 --- a/src/racket/src/place.c +++ b/src/racket/src/place.c @@ -41,7 +41,8 @@ static int id_counter; static mzrt_mutex *id_counter_mutex; SHARED_OK mz_proc_thread *scheme_master_proc_thread; -THREAD_LOCAL_DECL(struct Scheme_Place_Object *place_object); +THREAD_LOCAL_DECL(static struct Scheme_Place_Object *place_object); +THREAD_LOCAL_DECL(static uintptr_t force_gc_for_place_accounting); static Scheme_Object *scheme_place(int argc, Scheme_Object *args[]); static Scheme_Object *place_wait(int argc, Scheme_Object *args[]); static Scheme_Object *place_kill(int argc, Scheme_Object *args[]); @@ -169,6 +170,8 @@ typedef struct Place_Start_Data { Scheme_Object *current_library_collection_paths; mzrt_sema *ready; /* malloc'ed item */ struct Scheme_Place_Object *place_obj; /* malloc'ed item */ + struct NewGC *parent_gc; + Scheme_Object *cust_limit; } Place_Start_Data; static void null_out_runtime_globals() { @@ -205,6 +208,14 @@ Scheme_Object *scheme_place(int argc, Scheme_Object *args[]) { Scheme_Object *collection_paths; Scheme_Place_Object *place_obj; mzrt_sema *ready; + struct NewGC *parent_gc; + Scheme_Custodian *cust; + intptr_t mem_limit; + + /* To avoid runaway place creation, check for termination before continuing. */ + scheme_thread_block(0.0); + + parent_gc = GC_get_current_instance(); /* create place object */ place = MALLOC_ONE_TAGGED(Scheme_Place); @@ -217,13 +228,24 @@ Scheme_Object *scheme_place(int argc, Scheme_Object *args[]) { place_obj->parent_signal_handle = handle; } + /* The use_factor partly determines how often a child place notifies + a parent place that it is using more memory. If the child + notified the parent evey time its memory use increased, that + would probably be too often. But notifying every time the memory + use doubles isn't good enough, because a long chain of places + wouldn't alert parents often enough to limit total memory + use. Decreasing the factor for each generation means that the + alerts become more frequent as nesting gets deeper. */ + place_obj->use_factor = (place_object ? (place_object->use_factor / 2) : 1.0); + mzrt_sema_create(&ready, 0); /* pass critical info to new place */ place_data = MALLOC_ONE(Place_Start_Data); place_data->ready = ready; place_data->place_obj = place_obj; - + place_data->parent_gc = parent_gc; + { Scheme_Object *so; @@ -257,11 +279,17 @@ Scheme_Object *scheme_place(int argc, Scheme_Object *args[]) { collection_paths = places_deep_copy_to_master(collection_paths); place_data->current_library_collection_paths = collection_paths; + cust = scheme_get_current_custodian(); + mem_limit = GC_get_account_memory_limit(cust); + place_data->cust_limit = scheme_make_integer(mem_limit); + place_obj->memory_limit = mem_limit; + place_obj->parent_need_gc = &force_gc_for_place_accounting; + /* create new place */ proc_thread = mz_proc_thread_create(place_start_proc, place_data); if (!proc_thread) { - mzrt_sema_destroy(ready); + mzrt_sema_destroy(ready); scheme_signal_error("place: place creation failed"); } @@ -277,9 +305,7 @@ Scheme_Object *scheme_place(int argc, Scheme_Object *args[]) { place_data->place_obj = NULL; { - Scheme_Custodian *cust; Scheme_Custodian_Reference *mref; - cust = scheme_get_current_custodian(); mref = scheme_add_managed(NULL, (Scheme_Object *)place, cust_kill_place, @@ -288,6 +314,10 @@ Scheme_Object *scheme_place(int argc, Scheme_Object *args[]) { place->mref = mref; } +#ifdef MZ_PRECISE_GC + GC_register_new_thread(place, cust); +#endif + return (Scheme_Object*) place; } @@ -310,13 +340,16 @@ static void do_place_kill(Scheme_Place *place) mzrt_mutex_unlock(place_obj->lock); } + scheme_resume_one_place(place); + scheme_remove_managed(place->mref, (Scheme_Object *)place); place->place_obj = NULL; } -static int do_place_break(Scheme_Place *place) { +static int do_place_break(Scheme_Place *place) +{ Scheme_Place_Object *place_obj; - place_obj = (Scheme_Place_Object*) place->place_obj; + place_obj = place->place_obj; { mzrt_mutex_lock(place_obj->lock); @@ -332,7 +365,8 @@ static int do_place_break(Scheme_Place *place) { return 0; } -static void cust_kill_place(Scheme_Object *pl, void *notused) { +static void cust_kill_place(Scheme_Object *pl, void *notused) +{ do_place_kill((Scheme_Place *)pl); } @@ -1734,28 +1768,121 @@ static void *place_start_proc(void *data_arg) { return rc; } +void scheme_pause_one_place(Scheme_Place *p) +{ + Scheme_Place_Object *place_obj = p->place_obj; + + if (place_obj) { + mzrt_mutex_lock(place_obj->lock); + if (!place_obj->pause) { + mzrt_sema *s; + mzrt_sema_create(&s, 0); + place_obj->pause = s; + } + mzrt_mutex_unlock(place_obj->lock); + } +} + +void scheme_resume_one_place(Scheme_Place *p) +{ + Scheme_Place_Object *place_obj = p->place_obj; + + if (place_obj) { + mzrt_mutex_lock(place_obj->lock); + if (place_obj->pause) { + mzrt_sema *s = place_obj->pause; + place_obj->pause = NULL; + if (!place_obj->pausing) { + mzrt_sema_destroy(s); + } else { + mzrt_sema_post(s); + } + } + mzrt_mutex_unlock(place_obj->lock); + } +} + void scheme_place_check_for_interruption() { Scheme_Place_Object *place_obj; char local_die; char local_break; + mzrt_sema *local_pause; + + place_obj = place_object; + if (!place_obj) + return; + + while (1) { + mzrt_mutex_lock(place_obj->lock); + + local_die = place_obj->die; + local_break = place_obj->pbreak; + local_pause = place_obj->pause; + place_obj->pbreak = 0; + if (local_pause) + place_obj->pausing = 1; + + mzrt_mutex_unlock(place_obj->lock); + + if (local_pause) { + scheme_pause_all_places(); + mzrt_sema_wait(local_pause); + mzrt_sema_destroy(local_pause); + scheme_resume_all_places(); + } else + break; + } + + if (local_die) + scheme_kill_thread(scheme_main_thread); + if (local_break) + scheme_break_thread(NULL); +} + +void scheme_place_set_memory_use(intptr_t mem_use) +{ + Scheme_Place_Object *place_obj; place_obj = place_object; if (!place_obj) return; mzrt_mutex_lock(place_obj->lock); - - local_die = place_obj->die; - local_break = place_obj->pbreak; - place_obj->pbreak = 0; - + place_obj->memory_use = mem_use; mzrt_mutex_unlock(place_obj->lock); - - if (local_die) - scheme_kill_thread(scheme_main_thread); - if (local_break) - scheme_break_thread(NULL); + + if (place_obj->parent_signal_handle && place_obj->memory_limit) { + if (mem_use > place_obj->memory_limit) { + /* tell the parent place to force a GC, and therefore check + custodian limits that will kill this place; pause this + place and its children to give the original place time + to kill this one */ + scheme_pause_all_places(); + mzrt_ensure_max_cas(place_obj->parent_need_gc, 1); + scheme_signal_received_at(place_obj->parent_signal_handle); + } else if (mem_use > (1 + place_obj->use_factor) * place_obj->prev_notify_memory_use) { + /* make sure the parent notices that we're using more memory: */ + scheme_signal_received_at(place_obj->parent_signal_handle); + place_obj->prev_notify_memory_use = mem_use; + } else if (mem_use < place_obj->prev_notify_memory_use) { + place_obj->prev_notify_memory_use = mem_use; + } + } +} + +void scheme_place_check_memory_use() +{ + intptr_t m; + + m = GC_propagate_hierarchy_memory_use(); + scheme_place_set_memory_use(m); + + if (force_gc_for_place_accounting) { + force_gc_for_place_accounting = 0; + scheme_collect_garbage(); + scheme_resume_all_places(); + } } static void place_set_result(Scheme_Object *result) @@ -1797,6 +1924,7 @@ static void *place_start_proc_after_stack(void *data_arg, void *stack_base) { Scheme_Place_Object *place_obj; Scheme_Object *place_main; Scheme_Object *a[2], *channel; + intptr_t mem_limit; mzrt_thread_id ptid; ptid = mz_proc_thread_self(); @@ -1812,8 +1940,10 @@ static void *place_start_proc_after_stack(void *data_arg, void *stack_base) { scheme_current_place_id = ++id_counter; mzrt_mutex_unlock(id_counter_mutex); + mem_limit = SCHEME_INT_VAL(place_data->cust_limit); + /* scheme_make_thread behaves differently if the above global vars are not null */ - scheme_place_instance_init(stack_base); + scheme_place_instance_init(stack_base, place_data->parent_gc, mem_limit); a[0] = scheme_places_deep_copy(place_data->current_library_collection_paths); scheme_current_library_collection_paths(1, a); diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index bb804c6193..26f4b4d88d 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -3669,19 +3669,29 @@ typedef struct Scheme_Place { Scheme_Object *channel; Scheme_Custodian_Reference *mref; intptr_t result; /* set when place_obj becomes NULL */ +#ifdef MZ_PRECISE_GC + struct GC_Thread_Info *gc_info; /* managed by the GC */ +#endif } Scheme_Place; typedef struct Scheme_Place_Object { Scheme_Object so; #if defined(MZ_USE_PLACES) mzrt_mutex *lock; + mzrt_sema *pause; #endif char die; char pbreak; + char pausing; void *signal_handle; void *parent_signal_handle; /* set to NULL when the place terminates */ intptr_t result; /* initialized to 1, reset when parent_signal_handle becomes NULL */ - /*Thread_Local_Variables *tlvs; */ + + intptr_t memory_use; /* set by inform hook on GC, used by GC for memory accounting */ + intptr_t prev_notify_memory_use; /* if memory_use > use_factor * prev_notify_memory_use, alert parent */ + double use_factor; + intptr_t memory_limit; /* custodian-based limit on the place's memory use */ + uintptr_t *parent_need_gc; /* ptr to a variable in parent to force a GC (triggering accounting) */ } Scheme_Place_Object; typedef struct Scheme_Serialized_File_FD{ @@ -3714,11 +3724,18 @@ void scheme_socket_to_output_port(intptr_t s, Scheme_Object *name, int takeover, #define SCHEME_PLACE_OBJECTP(o) (SCHEME_TYPE(o) == scheme_place_object_type) -Scheme_Env *scheme_place_instance_init(); +Scheme_Env *scheme_place_instance_init(void *stack_base, struct NewGC *, intptr_t memory_limit); Scheme_Object *scheme_make_place_object(); void scheme_place_instance_destroy(int force); void scheme_kill_green_thread_timer(); void scheme_place_check_for_interruption(); void scheme_check_place_port_ok(); +void scheme_place_set_memory_use(intptr_t amt); +void scheme_place_check_memory_use(); + +void scheme_pause_all_places(); +void scheme_pause_one_place(Scheme_Place *p); +void scheme_resume_all_places(); +void scheme_resume_one_place(Scheme_Place *p); #endif /* __mzscheme_private__ */ diff --git a/src/racket/src/thread.c b/src/racket/src/thread.c index fe26d20705..4b7d1627b0 100644 --- a/src/racket/src/thread.c +++ b/src/racket/src/thread.c @@ -198,7 +198,7 @@ static void get_ready_for_GC(void); static void done_with_GC(void); #ifdef MZ_PRECISE_GC static void inform_GC(int master_gc, int major_gc, intptr_t pre_used, intptr_t post_used, - intptr_t pre_admin, intptr_t post_admin); + intptr_t pre_admin, intptr_t post_admin, intptr_t post_child_places_used); #endif THREAD_LOCAL_DECL(static volatile short delayed_break_ready); @@ -988,7 +988,9 @@ static void adjust_custodian_family(void *mgr, void *skip_move) o = WEAKIFIED(((Scheme_Thread_Custodian_Hop *)o)->p); if (o) GC_register_thread(o, parent); - } + } else if (SAME_TYPE(SCHEME_TYPE(o), scheme_place_type)) { + GC_register_thread(o, parent); + } } #endif } @@ -1454,6 +1456,30 @@ static Scheme_Object *extract_thread(Scheme_Object *o) return (Scheme_Object *)WEAKIFIED(((Scheme_Thread_Custodian_Hop *)o)->p); } +static void pause_place(Scheme_Object *o) +{ +#ifdef MZ_USE_PLACES + scheme_pause_one_place((Scheme_Place *)o); +#endif +} + +void scheme_pause_all_places() +{ + for_each_managed(scheme_place_type, pause_place); +} + +static void resume_place(Scheme_Object *o) +{ +#ifdef MZ_USE_PLACES + scheme_resume_one_place((Scheme_Place *)o); +#endif +} + +void scheme_resume_all_places() +{ + for_each_managed(scheme_place_type, resume_place); +} + void scheme_init_custodian_extractors() { if (!extractors) { @@ -4196,6 +4222,13 @@ void scheme_thread_block(float sleep_time) if (!do_atomic) scheme_place_check_for_interruption(); #endif + + /* Propagate memory-use information and check for custodian-based + GC triggers due to child place memory use: */ +#if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES) + scheme_place_check_memory_use(); + check_scheduled_kills(); +#endif if (sleep_end > 0) { if (sleep_end > scheme_get_inexact_milliseconds()) { @@ -7695,7 +7728,8 @@ static char *gc_num(char *nums, int v) static void inform_GC(int master_gc, int major_gc, intptr_t pre_used, intptr_t post_used, - intptr_t pre_admin, intptr_t post_admin) + intptr_t pre_admin, intptr_t post_admin, + intptr_t post_child_places_used) { Scheme_Logger *logger = scheme_get_main_logger(); if (logger) { @@ -7731,6 +7765,11 @@ static void inform_GC(int master_gc, int major_gc, scheme_log_message(logger, SCHEME_LOG_DEBUG, buf, buflen, NULL); } +#ifdef MZ_USE_PLACES + if (!master_gc) { + scheme_place_set_memory_use(post_used + post_child_places_used); + } +#endif } #endif From a6b4b42982b4ff5b7c0ae5b855b0726f22452ec5 Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Mon, 5 Sep 2011 17:22:59 -0600 Subject: [PATCH 161/235] pr# 12143 raco make -j 2, fix split-path's 'relative to byte-string conversion --- collects/setup/parallel-build.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/setup/parallel-build.rkt b/collects/setup/parallel-build.rkt index 32927d7851..bee2989ef5 100644 --- a/collects/setup/parallel-build.rkt +++ b/collects/setup/parallel-build.rkt @@ -49,7 +49,8 @@ (define (->bytes x) (cond [(path? x) (path->bytes x)] - [(string? x) (string->bytes/locale x)])) + [(string? x) (string->bytes/locale x)] + [(equal? x 'relative) (->bytes (path->complete-path (current-directory)))])) (define collects-queue% (class* object% (work-queue<%>) From cf772ceebdba7c63bbbbebd84900696a64982a5c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 5 Sep 2011 18:10:00 -0600 Subject: [PATCH 162/235] Corrections to the guide's places entry --- collects/scribblings/guide/places.scrbl | 111 ++++++++++++------------ 1 file changed, 57 insertions(+), 54 deletions(-) diff --git a/collects/scribblings/guide/places.scrbl b/collects/scribblings/guide/places.scrbl index 5d6dbce21e..f0bafd87e5 100644 --- a/collects/scribblings/guide/places.scrbl +++ b/collects/scribblings/guide/places.scrbl @@ -6,16 +6,18 @@ The @racketmodname[racket/place] library provides support for performance improvement through parallelism with the @racket[place] -form. Two places communicate using @racket[place-channel-put] and -@racket[place-channel-get] functions. Places contains the full -expressive power of the Racket language. However, the places design -restricts both the methods of inter-place communication and the type -of values permitted inside communication messages. +form. The @racket[place] form creates a @deftech{place}, which is +effectively a new Racket instance that can run in parallel to other +places, including the initial place. The full power of the Racket +language is available at each place, but places can communicate only +through message passing---using the @racket[place-channel-put] and +@racket[place-channel-get] functions on a limited set of +values---which helps ensure the safety and independence of parallel +computations. -The @racket[place] form spawns a new pristine racket execution -context, which the OS can schedule on any available processor. As a -starting example, the racket program below uses a place to determine -whether any number in the list has a double that is also in the list: +As a starting example, the racket program below uses a @tech{place} to +determine whether any number in the list has a double that is also in +the list: @codeblock{ #lang racket @@ -28,66 +30,67 @@ whether any number in the list has a double that is also in the list: (= i2 (* 2 i))))) (define (main) - (define p (place ch - (define l (place-channel-get ch)) - (define l-double? (any-double? l)) - (place-channel-put ch l-double?))) + (define p + (place ch + (define l (place-channel-get ch)) + (define l-double? (any-double? l)) + (place-channel-put ch l-double?))) (place-channel-put p (list 1 2 4 8)) - (printf "Has double? ~a\n" (place-channel-get p)) - (place-wait p)) + (begin0 + (place-channel-get p)) + (place-wait p)) } -The first argument to the place form is an identifier, which the -@racket[place] form binds to an initial place-channel. The remaining -argument expressions form the body of the @racket[place] form. The -body expressions use the initial place-channel to communicate with the -place which spawned the new place. +The identifier @racket[ch] after @racket[place] is bound to a @deftech{place +channel}. The remaining body expressions within the @racket[place] form +are evaluated in a new place, and the body expressions use @racket[ch] +to communicate with the place that spawned the new place. -In the example above, the place form has a body of three expressions. -The first receives a list of numbers over the initial place-channel -(@racket[ch]) and binds the list to @racket[l]. The second body -expression calls any-double? on the list and binds the result to -@racket[l-double?]. The last body expression sends the -@racket[l-double?] result back to the invoking place over the -@racket[ch] place-channel. +In the body of the @racket[place] form above, the new place receives a +list of numbers over @racket[ch] and binds the list to @racket[l]. It +then calls @racket[any-double?] on the list and binds the result to +@racket[l-double?]. The final body expression sends the +@racket[l-double?] result back to the original place over @racket[ch]. -The macro that implements the @racket[place] form performs two actions with -subtle consequences. First, it lifts the place body to an anonymous -module-scope function. This has the consequence that any function -referred to by the place body must be defined at module-scope. Second, -the place form expands into a @racket[dynamic-place] call, which -@racket[dynamic-require]s the current module in a newly created place. -@margin-note{When using places inside DrRacket, the module containg -place code must be saved to a file before it will execute.} -As part of the @racket[dynamic-require] the current module body is -evaluated in the new place. The consequence of this second action is -that places forms must not be called at module-scope or indirectly by -functions which are invoked at module scope. Both of these errors are -demonstrated in the code bellow. Failing to follow this precaution -will result in an infinite spawning of places as each spawned place -evaluates the module body and spawns an additional place. +In DrRacket, after saving and running the above program, evaluate +@racket[(main)] in the interactions window to create the new +place. @margin-note*{When using @tech{places} inside DrRacket, the +module containg place code must be saved to a file before it will +execute.} Alternatively, save the program as @filepath{double.rkt} +and run from a command line with + +@commandline{racket -tm double.rkt} + +where the @Flag{t} flag tells @exec{racket} to load the +@tt{double.rkt} module, the @Flag{m} flag calls the exported +@racket[main] function, and @Flag{tm} combines the two flags. + +The @racket[place] form has two subtle features. First, it lifts the +@racket[place] body to an anonymous, module-level function. This +lifting means that any binding referenced by the @racket[place] body +must be available in the module's top level. Second, the +@racket[place] form @racket[dynamic-require]s the enclosing module in +a newly created place. As part of the @racket[dynamic-require], the +current module body is evaluated in the new place. The consequence of +this second feature is that @racket[place] should appear immediately +in a module or in a function that is called in a module's top level; +otherwise, invoking the module will invoke the same module in a new +place, and so on, triggering a cascade of place creations that will +soon exhaust memory. @codeblock{ #lang racket (provide main) -; do not do this -(define p (place ch - (place-channel-get ch))) +; Don't do this! +(define p (place ch (place-channel-get ch))) (define (indirect-place-invocation) - (define p2 (place ch - (place-channel-get ch)))) + (define p2 (place ch (place-channel-get ch)))) - -; do not do this either +; Don't do this, either! (indirect-place-invocation) } -The example above is executed by running @exec{racket -tm double.rkt} -from the command line. The @Flag{t} tells racket to load the -@tt{double.rkt} module. The @Flag{m} instructs racket to run the -@racket[main] module. - From 09e65716d529939daa8ff4c9d896f46dd4dd1a36 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 5 Sep 2011 19:14:25 -0500 Subject: [PATCH 163/235] add missing require --- collects/tests/drracket/teachpack.rkt | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/collects/tests/drracket/teachpack.rkt b/collects/tests/drracket/teachpack.rkt index d7582899b3..857a0a7462 100644 --- a/collects/tests/drracket/teachpack.rkt +++ b/collects/tests/drracket/teachpack.rkt @@ -1,9 +1,10 @@ -#lang scheme/base +#lang racket/base (require "private/drracket-test-util.rkt" - scheme/class - scheme/path - scheme/gui/base + racket/class + racket/path + racket/gui/base + framework (prefix-in fw: framework)) (provide run-test) From 57c59d2ed7e1e8a29d492d533a8b3f5673022824 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 5 Sep 2011 20:03:00 -0500 Subject: [PATCH 164/235] add yet another dialog-mixin argument to a standard dialog, this time get-text-from-user also, some minor rackety to that function/file --- collects/mred/private/moredialogs.rkt | 70 ++++++++++----------- collects/scribblings/gui/dialog-funcs.scrbl | 7 ++- 2 files changed, 36 insertions(+), 41 deletions(-) diff --git a/collects/mred/private/moredialogs.rkt b/collects/mred/private/moredialogs.rkt index 201f620a23..e732d28d69 100644 --- a/collects/mred/private/moredialogs.rkt +++ b/collects/mred/private/moredialogs.rkt @@ -1,19 +1,14 @@ -(module moredialogs mzscheme - (require mzlib/class - mzlib/etc - mzlib/list - (prefix wx: "kernel.rkt") - (prefix wx: racket/snip) +#lang racket/base + (require racket/class + (prefix-in wx: "kernel.rkt") + (prefix-in wx: racket/snip) "lock.rkt" "const.rkt" "check.rkt" "wx.rkt" "helper.rkt" - "editor.rkt" "mrtop.rkt" "mrcanvas.rkt" - "mrpopup.rkt" - "mrmenu.rkt" "mritem.rkt" "mrpanel.rkt" "mrtextfield.rkt") @@ -190,34 +185,33 @@ (define (can-get-page-setup-from-user?) (wx:can-show-print-setup?)) - (define get-text-from-user - (case-lambda - [(title message) (get-text-from-user title message #f "" null)] - [(title message parent) (get-text-from-user title message parent "" null)] - [(title message parent init-val) (get-text-from-user title message parent init-val null)] - [(title message parent init-val style) - (check-label-string 'get-text-from-user title) - (check-label-string/false 'get-text-from-user message) - (check-top-level-parent/false 'get-text-from-user parent) - (check-string 'get-text-from-user init-val) - (check-style 'get-text-from-user #f '(password) style) - (let* ([f (make-object dialog% title parent box-width)] - [ok? #f] - [done (lambda (?) (lambda (b e) (set! ok? ?) (send f show #f)))]) - (let ([t (make-object text-field% message f (lambda (t e) (when (eq? (send e get-event-type) 'text-field-enter) - ((done #t) #f #f))) - init-val (list* 'single 'vertical-label style))] - [p (make-object horizontal-pane% f)]) - (send p set-alignment 'right 'center) - (send f stretchable-height #f) - (ok-cancel - (lambda () (make-object button% "OK" p (done #t) '(border))) - (lambda () (make-object button% "Cancel" p (done #f)))) - (send (send t get-editor) select-all) - (send t focus) - (send f center) - (send f show #t) - (and ok? (send t get-value))))])) + (define (get-text-from-user title message + [parent #f] + [init-val ""] + [style null] + #:dialog-mixin [dialog-mixin values]) + (check-label-string 'get-text-from-user title) + (check-label-string/false 'get-text-from-user message) + (check-top-level-parent/false 'get-text-from-user parent) + (check-string 'get-text-from-user init-val) + (check-style 'get-text-from-user #f '(password) style) + (define f (make-object (dialog-mixin dialog%) title parent box-width)) + (define ok? #f) + (define ((done ?) b e) (set! ok? ?) (send f show #f)) + (define t (make-object text-field% message f (lambda (t e) (when (eq? (send e get-event-type) 'text-field-enter) + ((done #t) #f #f))) + init-val (list* 'single 'vertical-label style))) + (define p (make-object horizontal-pane% f)) + (send p set-alignment 'right 'center) + (send f stretchable-height #f) + (ok-cancel + (lambda () (make-object button% "OK" p (done #t) '(border))) + (lambda () (make-object button% "Cancel" p (done #f)))) + (send (send t get-editor) select-all) + (send t focus) + (send f center) + (send f show #t) + (and ok? (send t get-value))) (define get-choices-from-user (case-lambda @@ -347,4 +341,4 @@ (send f center) (send f show #t) (and ok? - (get-current-color))))]))) + (get-current-color))))])) diff --git a/collects/scribblings/gui/dialog-funcs.scrbl b/collects/scribblings/gui/dialog-funcs.scrbl index 4299af6f19..ff1629940d 100644 --- a/collects/scribblings/gui/dialog-funcs.scrbl +++ b/collects/scribblings/gui/dialog-funcs.scrbl @@ -390,7 +390,8 @@ Like @racket[message-box/custom], except that [message (or/c string? #f)] [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f) #f] [init-val string? ""] - [style (listof 'password) null]) + [style (listof 'password) null] + [#:dialog-mixin dialog-mixin (make-mixin-contract dialog%) values]) (or/c string? #f)]{ Gets a text string from the user via a modal dialog, using @@ -406,8 +407,8 @@ If @racket[style] includes @racket['password], the dialog's text field draws each character of its content using a generic symbol, instead of the actual character. - - +The @racket[dialog-mixin] argument is applied to the class that implements the dialog +before the dialog is created. } @defproc[(get-choices-from-user [title string?] From c30122d1fcf1a2830481b881423df0fda0546f38 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 5 Sep 2011 20:12:56 -0500 Subject: [PATCH 165/235] more adjustments to try to get the drracket test suites running in drdr --- collects/drracket/private/syncheck/gui.rkt | 19 ++++++++++--------- collects/meta/props | 2 +- collects/tests/drracket/hangman.rkt | 1 + .../drracket/private/drracket-test-util.rkt | 4 ++-- 4 files changed, 14 insertions(+), 12 deletions(-) diff --git a/collects/drracket/private/syncheck/gui.rkt b/collects/drracket/private/syncheck/gui.rkt index 94fcacf337..28ba64e1af 100644 --- a/collects/drracket/private/syncheck/gui.rkt +++ b/collects/drracket/private/syncheck/gui.rkt @@ -572,14 +572,14 @@ If the namespace does not, they are colored the unbound color. (define/public (syncheck:add-rename-menu id-as-sym to-be-renamed/poss name-dup?) (define (make-menu menu) (let ([name-to-offer (format "~a" id-as-sym)]) - (instantiate menu-item% () - (parent menu) - (label (fw:gui-utils:format-literal-label (string-constant cs-rename-var) name-to-offer)) - (callback - (λ (x y) - (let ([frame-parent (find-menu-parent menu)]) - (rename-callback name-to-offer - frame-parent))))))) + (new menu-item% + [parent menu] + [label (fw:gui-utils:format-literal-label (string-constant cs-rename-var) name-to-offer)] + [callback + (λ (x y) + (let ([frame-parent (find-menu-parent menu)]) + (rename-callback name-to-offer + frame-parent)))]))) ;; rename-callback : string ;; (and/c syncheck-text<%> definitions-text<%>) @@ -596,7 +596,8 @@ If the namespace does not, they are colored the unbound color. (string-constant cs-rename-id) (fw:gui-utils:format-literal-label (string-constant cs-rename-var-to) name-to-offer) parent - name-to-offer)))]) + name-to-offer + #:dialog-mixin frame:focus-table-mixin)))]) (when new-str (define new-sym (format "~s" (string->symbol new-str))) (define dup-name? (name-dup? new-sym)) diff --git a/collects/meta/props b/collects/meta/props index f22fe1d92e..d0f441deab 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1433,7 +1433,7 @@ path/s is either such a string or a list of them. "collects/tests/drracket/get-defs-test.rkt" drdr:command-line (gracket *) "collects/tests/drracket/hangman.rkt" responsible (robby matthias) drdr:command-line (gracket *) "collects/tests/drracket/io.rkt" drdr:command-line (gracket *) drdr:timeout 500 -"collects/tests/drracket/language-test.rkt" responsible (robby matthias) drdr:command-line (gracket *) drdr:timeout 600 +"collects/tests/drracket/language-test.rkt" responsible (robby matthias) drdr:command-line (gracket *) drdr:timeout 1500 "collects/tests/drracket/leaky-frame.rkt" drdr:command-line (gracket *) "collects/tests/drracket/memory-log.rkt" drdr:command-line (gracket *) "collects/tests/drracket/module-lang-test-utils.rkt" drdr:command-line (gracket-text "-t" *) diff --git a/collects/tests/drracket/hangman.rkt b/collects/tests/drracket/hangman.rkt index c29ee1facd..844c7a5bf8 100644 --- a/collects/tests/drracket/hangman.rkt +++ b/collects/tests/drracket/hangman.rkt @@ -3,6 +3,7 @@ racket/class) (fire-up-drscheme-and-run-tests + #:use-focus-table? #f (λ () (define drs (wait-for-drscheme-frame)) (define defs (send drs get-definitions-text)) diff --git a/collects/tests/drracket/private/drracket-test-util.rkt b/collects/tests/drracket/private/drracket-test-util.rkt index d0314f1ae9..a0e377d9da 100644 --- a/collects/tests/drracket/private/drracket-test-util.rkt +++ b/collects/tests/drracket/private/drracket-test-util.rkt @@ -593,7 +593,7 @@ ;; but just to print and return. (define orig-display-handler (error-display-handler)) - (define (fire-up-drscheme-and-run-tests run-test) + (define (fire-up-drscheme-and-run-tests #:use-focus-table? [use-focus-table? #t] run-test) (on-eventspace-handler-thread 'fire-up-drscheme-and-run-tests) (let () ;; change the preferences system so that it doesn't write to @@ -616,7 +616,7 @@ ;; of the startup of drscheme) (fw:preferences:restore-defaults) - (fw:test:use-focus-table #t) + (fw:test:use-focus-table use-focus-table?) (thread (λ () (let ([orig-display-handler (error-display-handler)]) From 83e7f922505bd771cd4fc22cfdafc4fc9ee4dd18 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 6 Sep 2011 05:48:17 -0600 Subject: [PATCH 166/235] fix non-places build --- src/racket/gc2/mem_account.c | 2 ++ src/racket/src/schpriv.h | 2 ++ 2 files changed, 4 insertions(+) diff --git a/src/racket/gc2/mem_account.c b/src/racket/gc2/mem_account.c index 2c5fcf1e6c..565484c77a 100644 --- a/src/racket/gc2/mem_account.c +++ b/src/racket/gc2/mem_account.c @@ -65,6 +65,7 @@ inline static void mark_threads(NewGC *gc, int owner) } } else { /* place */ +#ifdef MZ_USE_PLACES /* add in the memory used by the place's GC */ intptr_t sz; Scheme_Place_Object *place_obj = ((Scheme_Place *)work->thread)->place_obj; @@ -74,6 +75,7 @@ inline static void mark_threads(NewGC *gc, int owner) mzrt_mutex_unlock(place_obj->lock); account_memory(gc, owner, gcBYTES_TO_WORDS(sz)); } +#endif } } } diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index 26f4b4d88d..97c9382887 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -3724,7 +3724,9 @@ void scheme_socket_to_output_port(intptr_t s, Scheme_Object *name, int takeover, #define SCHEME_PLACE_OBJECTP(o) (SCHEME_TYPE(o) == scheme_place_object_type) +#ifdef MZ_USE_PLACES Scheme_Env *scheme_place_instance_init(void *stack_base, struct NewGC *, intptr_t memory_limit); +#endif Scheme_Object *scheme_make_place_object(); void scheme_place_instance_destroy(int force); void scheme_kill_green_thread_timer(); From 37a81bcfce1368bbb9c5904e24078ac6b354dff0 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Sat, 3 Sep 2011 20:36:32 -0400 Subject: [PATCH 167/235] correcting an offset error: if the string str is exactly n characters long, the use of string-ref in the last case will die. --- collects/planet/private/command.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/planet/private/command.rkt b/collects/planet/private/command.rkt index e41386552c..dad9767c20 100644 --- a/collects/planet/private/command.rkt +++ b/collects/planet/private/command.rkt @@ -112,7 +112,7 @@ ;; are eaten in the process. (define (wrap-to-count str n) (cond - [(< (string-length str) n) (list str)] + [(<= (string-length str) n) (list str)] [(regexp-match-positions #rx"\n" str 0 n) => (λ (posn) From c25f7cea2709624b08bed57a468db35abe6a5b21 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 5 Sep 2011 17:26:31 -0400 Subject: [PATCH 168/235] Micro-optimization. --- collects/typed-racket/typecheck/tc-funapp.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-racket/typecheck/tc-funapp.rkt b/collects/typed-racket/typecheck/tc-funapp.rkt index 940c5eff7a..723feabda9 100644 --- a/collects/typed-racket/typecheck/tc-funapp.rkt +++ b/collects/typed-racket/typecheck/tc-funapp.rkt @@ -59,7 +59,7 @@ (and argtys (list (tc-result1: argtys-t) ...))) (or ;; find the first function where the argument types match - (for/first ([dom doms] [rng rngs] [rest rests] [a arrs] + (for/first ([dom (in-list doms)] [rng (in-list rngs)] [rest (in-list rests)] [a (in-list arrs)] #:when (subtypes/varargs argtys-t dom rest)) ;; then typecheck here ;; we call the separate function so that we get the appropriate From 41bfb878c3dfc111be9107276712b35a995d4dcc Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 5 Sep 2011 17:27:11 -0400 Subject: [PATCH 169/235] Add logging to typechecker main loop. --- .../typed-racket/typecheck/tc-toplevel.rkt | 135 +++++++++--------- 1 file changed, 71 insertions(+), 64 deletions(-) diff --git a/collects/typed-racket/typecheck/tc-toplevel.rkt b/collects/typed-racket/typecheck/tc-toplevel.rkt index aa8da40b69..4d991585e2 100644 --- a/collects/typed-racket/typecheck/tc-toplevel.rkt +++ b/collects/typed-racket/typecheck/tc-toplevel.rkt @@ -252,65 +252,70 @@ [_ (int-err "not define-type-alias")])) (define (type-check forms0) - (begin-with-definitions - (define forms (syntax->list forms0)) - (define-values (type-aliases struct-defs stx-defs0 val-defs0 provs reqs) - (filter-multiple - forms - (internal-syntax-pred define-type-alias-internal) - (lambda (e) (or ((internal-syntax-pred define-typed-struct-internal) e) - ((internal-syntax-pred define-typed-struct/exec-internal) e))) - parse-syntax-def - parse-def - provide? - define/fixup-contract?)) - (for-each (compose register-type-alias parse-type-alias) type-aliases) - ;; add the struct names to the type table - (for-each (compose add-type-name! names-of-struct) struct-defs) - ;; resolve all the type aliases, and error if there are cycles - (resolve-type-aliases parse-type) - ;; do pass 1, and collect the defintions - (define defs (apply append (filter list? (map tc-toplevel/pass1 forms)))) - ;; separate the definitions into structures we'll handle for provides - (define def-tbl - (for/fold ([h (make-immutable-free-id-table)]) - ([def (in-list defs)]) - (dict-set h (binding-name def) def))) - ;; typecheck the expressions and the rhss of defintions - (for-each tc-toplevel/pass2 forms) - ;; check that declarations correspond to definitions - (check-all-registered-types) - ;; report delayed errors - (report-all-errors) - (define syntax-provide? #f) - (define provide-tbl - (for/fold ([h (make-immutable-free-id-table)]) ([p (in-list provs)]) - (define-syntax-class unknown-provide-form - (pattern - (~and name - (~or (~datum protect) (~datum for-syntax) (~datum for-label) (~datum for-meta) - (~datum struct) (~datum all-from) (~datum all-from-except) - (~datum all-defined) (~datum all-defined-except) - (~datum prefix-all-defined) (~datum prefix-all-defined-except) - (~datum expand))))) - (syntax-parse p #:literals (#%provide) - [(#%provide form ...) - (for/fold ([h h]) ([f (syntax->list #'(form ...))]) - (parameterize ([current-orig-stx f]) - (syntax-parse f - [i:id - (when (def-stx-binding? (dict-ref def-tbl #'i #f)) - (set! syntax-provide? #t)) - (dict-set h #'i #'i)] - [((~datum rename) in out) - (when (def-stx-binding? (dict-ref def-tbl #'in #f)) - (set! syntax-provide? #t)) - (dict-set h #'in #'out)] - [(name:unknown-provide-form . _) - (tc-error "provide: ~a not supported by Typed Racket" (syntax-e #'name.name))] - [_ (int-err "unknown provide form")])))] - [_ (int-err "non-provide form! ~a" (syntax->datum p))]))) - ;; compute the new provides + (define forms (syntax->list forms0)) + (define-values (type-aliases struct-defs stx-defs0 val-defs0 provs reqs) + (filter-multiple + forms + (internal-syntax-pred define-type-alias-internal) + (lambda (e) (or ((internal-syntax-pred define-typed-struct-internal) e) + ((internal-syntax-pred define-typed-struct/exec-internal) e))) + parse-syntax-def + parse-def + provide? + define/fixup-contract?)) + (do-time "Form splitting done") + (for-each (compose register-type-alias parse-type-alias) type-aliases) + ;; add the struct names to the type table + (for-each (compose add-type-name! names-of-struct) struct-defs) + ;; resolve all the type aliases, and error if there are cycles + (resolve-type-aliases parse-type) + (do-time "Starting pass1") + ;; do pass 1, and collect the defintions + (define defs (apply append (filter list? (map tc-toplevel/pass1 forms)))) + (do-time "Finished pass1") + ;; separate the definitions into structures we'll handle for provides + (define def-tbl + (for/fold ([h (make-immutable-free-id-table)]) + ([def (in-list defs)]) + (dict-set h (binding-name def) def))) + ;; typecheck the expressions and the rhss of defintions + (do-time "Starting pass2") + (for-each tc-toplevel/pass2 forms) + (do-time "Finished pass2") + ;; check that declarations correspond to definitions + (check-all-registered-types) + ;; report delayed errors + (report-all-errors) + (define syntax-provide? #f) + (define provide-tbl + (for/fold ([h (make-immutable-free-id-table)]) ([p (in-list provs)]) + (define-syntax-class unknown-provide-form + (pattern + (~and name + (~or (~datum protect) (~datum for-syntax) (~datum for-label) (~datum for-meta) + (~datum struct) (~datum all-from) (~datum all-from-except) + (~datum all-defined) (~datum all-defined-except) + (~datum prefix-all-defined) (~datum prefix-all-defined-except) + (~datum expand))))) + (syntax-parse p #:literals (#%provide) + [(#%provide form ...) + (for/fold ([h h]) ([f (syntax->list #'(form ...))]) + (parameterize ([current-orig-stx f]) + (syntax-parse f + [i:id + (when (def-stx-binding? (dict-ref def-tbl #'i #f)) + (set! syntax-provide? #t)) + (dict-set h #'i #'i)] + [((~datum rename) in out) + (when (def-stx-binding? (dict-ref def-tbl #'in #f)) + (set! syntax-provide? #t)) + (dict-set h #'in #'out)] + [(name:unknown-provide-form . _) + (tc-error "provide: ~a not supported by Typed Racket" (syntax-e #'name.name))] + [_ (int-err "unknown provide form")])))] + [_ (int-err "non-provide form! ~a" (syntax->datum p))]))) + ;; compute the new provides + (define new-stx (with-syntax* ([the-variable-reference (generate-temporary #'blame)] [(new-provs ...) @@ -319,11 +324,13 @@ #,(if (null? (syntax-e #'(new-provs ...))) #'(begin) #'(define the-variable-reference (quote-module-name))) - #,(env-init-code syntax-provide? provide-tbl def-tbl) - #,(tname-env-init-code) - #,(talias-env-init-code) - (begin-for-syntax #,(make-struct-table-code)) - (begin new-provs ...))))) + #,(env-init-code syntax-provide? provide-tbl def-tbl) + #,(tname-env-init-code) + #,(talias-env-init-code) + (begin-for-syntax #,(make-struct-table-code)) + (begin new-provs ...)))) + (do-time "finished provide generation") + new-stx) ;; typecheck a whole module ;; syntax -> syntax From 076c0fe6d821bc99c80eda95d627091e6fe0d7c3 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 5 Sep 2011 18:00:09 -0400 Subject: [PATCH 170/235] Switch to id-table, Rackety. --- collects/typed-racket/rep/interning.rkt | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/collects/typed-racket/rep/interning.rkt b/collects/typed-racket/rep/interning.rkt index 79b6fd80c9..79fafd25d6 100644 --- a/collects/typed-racket/rep/interning.rkt +++ b/collects/typed-racket/rep/interning.rkt @@ -1,6 +1,6 @@ -#lang scheme/base +#lang racket/base -(require syntax/boundmap (for-syntax scheme/base syntax/parse)) +(require syntax/id-table racket/dict (for-syntax racket/base syntax/parse)) (provide defintern hash-id) @@ -34,12 +34,12 @@ (define count! (make-count!)) (define id-count! (make-count!)) -(define identifier-table (make-module-identifier-mapping)) +(define identifier-table (make-free-id-table)) (define (hash-id id) - (module-identifier-mapping-get + (dict-ref identifier-table id (lambda () (let ([c (id-count!)]) - (module-identifier-mapping-put! identifier-table id c) + (dict-set! identifier-table id c) c)))) From 43c0177895bafaec1732d160b57ebc92d2e16ffb Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 6 Sep 2011 08:01:13 -0400 Subject: [PATCH 171/235] Fix minor formatting error. --- collects/mzlib/scribblings/pconvert.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mzlib/scribblings/pconvert.scrbl b/collects/mzlib/scribblings/pconvert.scrbl index 74e9db4bfb..a6b32b4a04 100644 --- a/collects/mzlib/scribblings/pconvert.scrbl +++ b/collects/mzlib/scribblings/pconvert.scrbl @@ -230,7 +230,7 @@ conversion when the value of @racket[constructor-style-printing] is @racket[#f]. If @racket[quasi-read-style-printing] is set to @racket[#f], then boxes and vectors are unquoted and represented using constructors. For example, the list of a box containing the number 1 -and a vector containing the number 1 is represented as @racket[`(,(box +and a vector containing the number 1 is represented as @racketresult[`(,(box 1) ,(vector 1))]. If the parameter's value is @racket[#t], then @racket[#&....] and @racket[#(....)] are used, e.g., @racket[`(#&1 #(1))]. The initial value of the parameter is @racket[#t].} From 64a1aee65df1f7babc1e832a39a0fe891f2e39f4 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 6 Sep 2011 08:02:12 -0400 Subject: [PATCH 172/235] Whitespace fixes, small optimizations of union cases. --- collects/typed-racket/types/subtype.rkt | 172 +++++++++++++----------- 1 file changed, 94 insertions(+), 78 deletions(-) diff --git a/collects/typed-racket/types/subtype.rkt b/collects/typed-racket/types/subtype.rkt index 224e9c2f9c..32e762d73a 100644 --- a/collects/typed-racket/types/subtype.rkt +++ b/collects/typed-racket/types/subtype.rkt @@ -2,14 +2,14 @@ (require "../utils/utils.rkt" (rep type-rep filter-rep object-rep rep-utils) (utils tc-utils) - (types utils comparison resolve abbrev numeric-tower substitute) + (types utils comparison resolve abbrev numeric-tower substitute) (env type-name-env) (only-in (infer infer-dummy) unify) racket/match unstable/match racket/function (rename-in racket/contract [-> c->] [->* c->*]) - (for-syntax racket/base syntax/parse)) + (for-syntax racket/base syntax/parse)) ;; exn representing failure of subtyping ;; s,t both types @@ -91,13 +91,13 @@ [(_ init (s1:sub* . args1) (s:sub* . args) ...) (with-syntax ([(A* ... A-last) (generate-temporaries #'(s1 s ...))]) (with-syntax ([(clauses ...) - (for/list ([s (syntax->list #'(s1 s ...))] - [args (syntax->list #'(args1 args ...))] - [A (syntax->list #'(init A* ...))] - [A-next (syntax->list #'(A* ... A-last))]) - #`[#,A-next (#,s #,A . #,args)])]) - #'(let* (clauses ...) - A-last)))])) + (for/list ([s (syntax->list #'(s1 s ...))] + [args (syntax->list #'(args1 args ...))] + [A (syntax->list #'(init A* ...))] + [A-next (syntax->list #'(A* ... A-last))]) + #`[#,A-next (#,s #,A . #,args)])]) + #'(let* (clauses ...) + A-last)))])) (define (kw-subtypes* A0 t-kws s-kws) (let loop ([A A0] [t t-kws] [s s-kws]) @@ -245,25 +245,25 @@ [(and (symbol? ks) (symbol? kt) (not (eq? ks kt))) (fail! s t)] [(and (symbol? ks) (pair? kt) (not (memq ks kt))) (fail! s t)] [(and (pair? ks) (pair? kt) - (for/and ([i (in-list ks)]) (not (memq i kt)))) - (fail! s t)] + (for/and ([i (in-list ks)]) (not (memq i kt)))) + (fail! s t)] [else - (let* ([A0 (remember s t A)]) - (parameterize ([current-seen A0]) + (let* ([A0 (remember s t A)]) + (parameterize ([current-seen A0]) (match* (s t) - [(_ (Univ:)) A0] - ;; error is top and bot - [(_ (Error:)) A0] - [((Error:) _) A0] - ;; (Un) is bot - [(_ (Union: (list))) (fail! s t)] - [((Union: (list)) _) A0] - ;; value types - [((Value: v1) (Value: v2)) (=> unmatch) (if (equal? v1 v2) A0 (unmatch))] + [(_ (Univ:)) A0] + ;; error is top and bot + [(_ (Error:)) A0] + [((Error:) _) A0] + ;; (Un) is bot + [(_ (Union: (list))) (fail! s t)] + [((Union: (list)) _) A0] + ;; value types + [((Value: v1) (Value: v2)) (=> unmatch) (if (equal? v1 v2) A0 (unmatch))] ;; values are subtypes of their "type" - [((Value: v) (Base: _ _ pred _)) (if (pred v) A0 (fail! s t))] - ;; tvars are equal if they are the same variable - [((F: t) (F: t*)) (if (eq? t t*) A0 (fail! s t))] + [((Value: v) (Base: _ _ pred _)) (if (pred v) A0 (fail! s t))] + ;; tvars are equal if they are the same variable + [((F: t) (F: t*)) (if (eq? t t*) A0 (fail! s t))] ;; Avoid needing to resolve things that refer to different structs. ;; Saves us from non-termination ;; Must happen *before* the sequence cases, which sometimes call `resolve' in match expanders @@ -311,57 +311,73 @@ (or (arr-subtype*/no-fail A0 (combine-arrs arr1) arr2) (supertype-of-one/arr A0 arr2 arr1) (fail! s t))] - ;; case-lambda - [((Function: arr1) (Function: arr2)) - (when (null? arr1) (fail! s t)) - (let loop-arities ([A* A0] - [arr2 arr2]) - (cond - [(null? arr2) A*] - [(supertype-of-one/arr A* (car arr2) arr1) => (lambda (A) (loop-arities A (cdr arr2)))] - [else (fail! s t)]))] - ;; recur structurally on pairs - [((Pair: a d) (Pair: a* d*)) - (let ([A1 (subtype* A0 a a*)]) - (and A1 (subtype* A1 d d*)))] + ;; case-lambda + [((Function: arr1) (Function: arr2)) + (when (null? arr1) (fail! s t)) + (let loop-arities ([A* A0] + [arr2 arr2]) + (cond + [(null? arr2) A*] + [(supertype-of-one/arr A* (car arr2) arr1) => (lambda (A) (loop-arities A (cdr arr2)))] + [else (fail! s t)]))] + ;; recur structurally on pairs + [((Pair: a d) (Pair: a* d*)) + (let ([A1 (subtype* A0 a a*)]) + (and A1 (subtype* A1 d d*)))] ;; recur structurally on dotted lists, assuming same bounds [((ListDots: s-dty dbound) (ListDots: t-dty dbound)) (subtype* A0 s-dty t-dty)] [((ListDots: s-dty dbound) (Listof: t-elem)) (subtype* A0 (substitute Univ dbound s-dty) t-elem)] - ;; quantification over two types preserves subtyping - [((Poly: ns b1) (Poly: ms b2)) - (=> unmatch) - (unless (= (length ns) (length ms)) - (unmatch)) - (subtype* A0 b1 (subst-all (make-simple-substitution ms (map make-F ns)) b2))] - [((Refinement: par _ _) t) + ;; quantification over two types preserves subtyping + [((Poly: ns b1) (Poly: ms b2)) + (=> unmatch) + (unless (= (length ns) (length ms)) + (unmatch)) + (subtype* A0 b1 (subst-all (make-simple-substitution ms (map make-F ns)) b2))] + [((Refinement: par _ _) t) (subtype* A0 par t)] - ;; use unification to see if we can use the polytype here - [((Poly: vs b) s) - (=> unmatch) - (if (unify vs (list b) (list s)) A0 (unmatch))] - [(s (Poly: vs b)) - (=> unmatch) - (if (null? (fv b)) (subtype* A0 s b) (unmatch))] - ;; rec types, applications and names (that aren't the same) - [((? needs-resolving? s) other) + ;; use unification to see if we can use the polytype here + [((Poly: vs b) s) + (=> unmatch) + (if (unify vs (list b) (list s)) A0 (unmatch))] + [(s (Poly: vs b)) + (=> unmatch) + (if (null? (fv b)) (subtype* A0 s b) (unmatch))] + ;; rec types, applications and names (that aren't the same) + [((? needs-resolving? s) other) (let ([s* (resolve-once s)]) (if (Type? s*) ;; needed in case this was a name that hasn't been resolved yet (subtype* A0 s* other) (fail! s t)))] - [(other (? needs-resolving? t)) + [(other (? needs-resolving? t)) (let ([t* (resolve-once t)]) (if (Type? t*) ;; needed in case this was a name that hasn't been resolved yet (subtype* A0 other t*) (fail! s t)))] - ;; for unions, we check the cross-product - [((Union: es) t) (or (and (andmap (lambda (elem) (subtype* A0 elem t)) es) A0) - (fail! s t))] - [(s (Union: es)) (or (and (ormap (lambda (elem) (subtype*/no-fail A0 s elem)) es) A0) - (fail! s t))] - ;; subtyping on immutable structs is covariant - [((Struct: nm _ flds proc _ _ _ _) (Struct: nm* _ flds* proc* _ _ _ _)) (=> nevermind) + ;; for unions, we check the cross-product + ;; some special cases for better performance + [((Union: (list e1 e2)) t) + (if (and (subtype* A0 e1 t) (subtype* A0 e2 t)) + A0 + (fail! s t))] + [((Union: (list e1 e2 e3)) t) + (if (and (subtype* A0 e1 t) (subtype* A0 e2 t) (subtype* A0 e3 t)) + A0 + (fail! s t))] + [((Union: es) t) + (if (for/and ([elem (in-list es)]) + (subtype* A0 elem t)) + A0 + (fail! s t))] + [(s (Union: es)) + (if (for/or ([elem (in-list es)]) + (with-handlers ([exn:subtype? (lambda _ #f)]) + (subtype* A0 s elem))) + A0 + (fail! s t))] + ;; subtyping on immutable structs is covariant + [((Struct: nm _ flds proc _ _ _ _) (Struct: nm* _ flds* proc* _ _ _ _)) (=> nevermind) (unless (free-identifier=? nm nm*) (nevermind)) (let ([A (cond [(and proc proc*) (subtype* proc proc*)] [proc* (fail! proc proc*)] @@ -384,37 +400,37 @@ (if (andmap (lambda (e0) (type-equal? e0 e*)) e) A0 (fail! s t))] [((MPair: _ _) (MPairTop:)) A0] [((Hashtable: _ _) (HashtableTop:)) A0] - ;; subtyping on structs follows the declared hierarchy - [((Struct: nm (? Type? parent) flds proc _ _ _ _) other) + ;; subtyping on structs follows the declared hierarchy + [((Struct: nm (? Type? parent) flds proc _ _ _ _) other) ;(dprintf "subtype - hierarchy : ~a ~a ~a\n" nm parent other) - (subtype* A0 parent other)] - ;; Promises are covariant - [((Struct: (? (lambda (n) (free-identifier=? n promise-id))) _ (list t) _ _ _ _ _) - (Struct: (? (lambda (n) (free-identifier=? n promise-id))) _ (list t*) _ _ _ _ _)) - (subtype* A0 t t*)] - ;; subtyping on values is pointwise - [((Values: vals1) (Values: vals2)) (subtypes* A0 vals1 vals2)] + (subtype* A0 parent other)] + ;; Promises are covariant + [((Struct: (? (lambda (n) (free-identifier=? n promise-id))) _ (list t) _ _ _ _ _) + (Struct: (? (lambda (n) (free-identifier=? n promise-id))) _ (list t*) _ _ _ _ _)) + (subtype* A0 t t*)] + ;; subtyping on values is pointwise + [((Values: vals1) (Values: vals2)) (subtypes* A0 vals1 vals2)] ;; trivial case for Result [((Result: t f o) (Result: t* f o)) (subtype* A0 t t*)] ;; we can ignore interesting results [((Result: t f o) (Result: t* (FilterSet: (Top:) (Top:)) (Empty:))) (subtype* A0 t t*)] - ;; subtyping on other stuff - [((Syntax: t) (Syntax: t*)) - (subtype* A0 t t*)] + ;; subtyping on other stuff + [((Syntax: t) (Syntax: t*)) + (subtype* A0 t t*)] [((Future: t) (Future: t*)) (subtype* A0 t t*)] - [((Instance: t) (Instance: t*)) - (subtype* A0 t t*)] + [((Instance: t) (Instance: t*)) + (subtype* A0 t t*)] [((Class: '() '() (list (and s (list names meths )) ...)) (Class: '() '() (list (and s* (list names* meths*)) ...))) (for/fold ([A A0]) ([n names*] [m meths*]) (cond [(assq n s) => (lambda (spec) (subtype* A (cadr spec) m))] [else (fail! s t)]))] - ;; otherwise, not a subtype - [(_ _) (fail! s t) #;(dprintf "failed")])))])))) + ;; otherwise, not a subtype + [(_ _) (fail! s t) #;(dprintf "failed")])))])))) (define (type-compare? a b) (and (subtype a b) (subtype b a))) From 7bb389cda257d4b65d7795ec8a1b7bde0a195c92 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 2 Sep 2011 22:32:32 -0600 Subject: [PATCH 173/235] Removing garbled text --- collects/web-server/scribblings/web-server-unit.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/web-server/scribblings/web-server-unit.scrbl b/collects/web-server/scribblings/web-server-unit.scrbl index c2e8b4df2f..d40e501ed9 100644 --- a/collects/web-server/scribblings/web-server-unit.scrbl +++ b/collects/web-server/scribblings/web-server-unit.scrbl @@ -47,7 +47,7 @@ operations: @item{Allows the @racket["/conf/refresh-passwords"] URL to refresh the password file.} @item{Allows the @racket["/conf/collect-garbage"] URL to call the garbage collector.} @item{Allows the @racket["/conf/refresh-servlets"] URL to refresh the servlets cache.} - @item{Execute servlets in the mapping URLs to the given servlet root directory under htdocs.} + @item{Executes servlets mapping URLs to the given servlet root directory under htdocs.} @item{Serves files under the @racket["/"] URL in the given htdocs directory.} ] From b2570bee3c33781912e46ac024e421415a5399f6 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 6 Sep 2011 09:48:05 -0600 Subject: [PATCH 174/235] Fixing allowance of multiple headers --- .../web-server/private/response-test.rkt | 8 ++- collects/web-server/http/response.rkt | 53 ++++++++++--------- 2 files changed, 36 insertions(+), 25 deletions(-) diff --git a/collects/tests/web-server/private/response-test.rkt b/collects/tests/web-server/private/response-test.rkt index 9517a57b61..4f70967256 100644 --- a/collects/tests/web-server/private/response-test.rkt +++ b/collects/tests/web-server/private/response-test.rkt @@ -55,7 +55,13 @@ (output output-response (response 404 #"404" (current-seconds) #"text/html" (list (make-header #"Header" #"Value")) void)) - #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nConnection: close\r\nHeader: Value\r\n\r\n")) + #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nConnection: close\r\nHeader: Value\r\n\r\n") + (test-equi? "response (both)" + (output output-response + (response 404 #"404" (current-seconds) #"text/html" + (list (make-header #"Header" #"Value1") + (make-header #"Header" #"Value2")) void)) + #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nConnection: close\r\nHeader: Value1\r\nHeader: Value2\r\n\r\n")) (test-suite "response/full" diff --git a/collects/web-server/http/response.rkt b/collects/web-server/http/response.rkt index 6e4ee7e1b3..f6b041cc88 100644 --- a/collects/web-server/http/response.rkt +++ b/collects/web-server/http/response.rkt @@ -32,37 +32,42 @@ ;; Write the headers portion of a response to an output port. ;; NOTE: According to RFC 2145 the server should write HTTP/1.1 ;; header for *all* clients. -(define-syntax-rule (maybe-hash-set! h k v) - (unless (hash-has-key? h k) - (hash-set! h k (header k v)))) -(define-syntax-rule (maybe-hash-set!* h [k v] ...) - (begin (maybe-hash-set! h k v) - ...)) +(define-syntax-rule (maybe-header h k v) + (if (hash-has-key? h k) + empty + (list (header k v)))) +(define-syntax-rule (maybe-headers h [k v] ...) + (append (maybe-header h k v) + ...)) (define (output-response-head conn bresp) (fprintf (connection-o-port conn) "HTTP/1.1 ~a ~a\r\n" (response-code bresp) (response-message bresp)) - (define hs (make-hash)) - (for ([h (in-list (response-headers bresp))]) - (hash-set! hs (header-field h) h)) - (maybe-hash-set!* - hs - [#"Date" - (string->bytes/utf-8 (seconds->gmt-string (current-seconds)))] - [#"Last-Modified" - (string->bytes/utf-8 (seconds->gmt-string (response-seconds bresp)))] - [#"Server" - #"Racket"] - [#"Content-Type" - (response-mime bresp)]) - (when (connection-close? conn) - (hash-set! hs #"Connection" - (make-header #"Connection" #"close"))) + (define hs (response-headers bresp)) + (define seen? (make-hash)) + (for ([h (in-list hs)]) + (hash-set! seen? (header-field h) #t)) (output-headers - conn - (hash-values hs))) + conn + (append + (maybe-headers + seen? + [#"Date" + (string->bytes/utf-8 (seconds->gmt-string (current-seconds)))] + [#"Last-Modified" + (string->bytes/utf-8 (seconds->gmt-string (response-seconds bresp)))] + [#"Server" + #"Racket"] + [#"Content-Type" + (response-mime bresp)]) + (if (connection-close? conn) + (maybe-headers + seen? + [#"Connection" #"close"]) + empty) + hs))) ;; output-headers : connection (list-of header) -> void (define (output-headers conn headers) From 5e943709efac8b8306f80b2d71b62390497ebe6a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 6 Sep 2011 11:11:51 -0500 Subject: [PATCH 175/235] catch up on the release notes --- doc/release-notes/drracket/HISTORY.txt | 35 ++++++++++++++++++++++++++ doc/release-notes/racket/HISTORY.txt | 11 ++++++++ 2 files changed, 46 insertions(+) diff --git a/doc/release-notes/drracket/HISTORY.txt b/doc/release-notes/drracket/HISTORY.txt index 4c5d55e8a3..73c95d1c6d 100644 --- a/doc/release-notes/drracket/HISTORY.txt +++ b/doc/release-notes/drracket/HISTORY.txt @@ -7,6 +7,41 @@ "Run" is now -r "Replace" is now -shift-f + . added online expansion and check syntax + + . 2htdp/image: + - shrunk the size of saved files that contain 2htdp/image bitmaps + (you can get these by copying and pasting from the REPL; using + "insert image" isn't affected) + + - use the pre-multiplied alphas when doing image comparsion + + - sped up rotation and flipping of bitmaps + + . improved the way the scribble-language buttons (render html and + render pdf) work; they now basically do what 'Run' does, plus the + extra work of rendering the document; before they had their own error + handling and sandboxing code, which was less integrated with DrRacket + + . improved the preference handling for the frame's location + (specifically for the multiple-monitors case) + + . check syntax no longer turns the module in the #lang line red + + . improved the handling of the 'Open Recent' menu item; specifically it + discards duplicates in a smarter way. + + . adjust DrRacket to be more accomodating to hostile filesystems; specifically + it no longer fails if it cannot read the preference system and it no longer + writes anywhere to the filesystem during startup except the prefs (and if that + fails, it survives in a less annoying manner) + + . DrRacket no longer locks the definitions text while evaluating the program + (it makes a copy of the definitions text and uses that copy now) + + . cleaned up the Close/Close Window/Close Tab menu items to match + the platform-specific conventions + ------------------------------ Version 5.1.2 ------------------------------ diff --git a/doc/release-notes/racket/HISTORY.txt b/doc/release-notes/racket/HISTORY.txt index 5828286a26..1724ad7830 100644 --- a/doc/release-notes/racket/HISTORY.txt +++ b/doc/release-notes/racket/HISTORY.txt @@ -4,11 +4,22 @@ Add support for the collection links file, including Version 5.1.3.3 unsafe/ffi: added support for C arrays and unions +Fixed the planet module-name-resolver to be thread safe +mrlib/include-bitmap: Adjust include-bitmap so it does not + write to the filesystem +framework: the finder get-file & put-file dialogs no + longer normalize their results +framework: added to the testing library so that tests can be + run when ignoring focus information from the underlying OS Version 5.1.2.3 Added set-port-next-location! and changed the default prompt read handler to use it when input and output ar terminals racket/gui: removed unsupported MDI styles and method +compiler/cm: added support for using more powerful + security-guards when writing to the filesystem +Fixed an old bug so that planet now uses the already-downloaded + .plt files (when present) Version 5.1.2.2 Changed the location-creation semantics of internal definitions From e781072bf325b1bd03bef4265c778d1fdcb5cb58 Mon Sep 17 00:00:00 2001 From: John Clements Date: Fri, 26 Aug 2011 11:07:10 -0700 Subject: [PATCH 176/235] eliminate quasiquote-the-cons-application tag --- collects/lang/private/teach.rkt | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/collects/lang/private/teach.rkt b/collects/lang/private/teach.rkt index 80e565c045..79e6e2da38 100644 --- a/collects/lang/private/teach.rkt +++ b/collects/lang/private/teach.rkt @@ -2145,9 +2145,7 @@ (with-syntax ([x (loop (syntax x) (sub1 depth))] [rest (loop (syntax rest) depth)] [uq-splicing (stx-car (stx-car stx))]) - (stepper-syntax-property (syntax/loc stx (the-cons/matchable (list (quote uq-splicing) x) rest)) - 'stepper-hint - 'quasiquote-the-cons-application)))] + (syntax/loc stx (the-cons/matchable (list (quote uq-splicing) x) rest))))] [intermediate-unquote-splicing (teach-syntax-error 'quasiquote @@ -2161,9 +2159,7 @@ [(a . b) (with-syntax ([a (loop (syntax a) depth)] [b (loop (syntax b) depth)]) - (stepper-syntax-property (syntax/loc stx (the-cons/matchable a b)) - 'stepper-hint - 'quasiquote-the-cons-application))] + (syntax/loc stx (the-cons/matchable a b)))] [any (syntax/loc stx (quote any))]))) From 9b91d37032f618f2794c13a7896499189d95cc93 Mon Sep 17 00:00:00 2001 From: John Clements Date: Wed, 31 Aug 2011 11:47:07 -0700 Subject: [PATCH 177/235] added entry for cstruct->list converter --- collects/scribblings/foreign/types.scrbl | 3 +++ 1 file changed, 3 insertions(+) diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index 6e25c0b553..1a343e893f 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -878,6 +878,9 @@ The resulting bindings are as follows: currently, this information is correct only when no @racket[super-id] is specified.} +@item{@racketvarfont{id}->list : a function that converts a struct into + a list of values.} + ] Objects of the new type are actually C pointers, with a type tag that From f44337e28ed413b0c034750e8e7e314fd3f9294e Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Tue, 6 Sep 2011 11:13:07 -0600 Subject: [PATCH 178/235] Change stderr output to logging, to please drdr --- collects/tests/racket/place-channel-fd2.rkt | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/collects/tests/racket/place-channel-fd2.rkt b/collects/tests/racket/place-channel-fd2.rkt index eed8fcbdf3..aadd042ee1 100644 --- a/collects/tests/racket/place-channel-fd2.rkt +++ b/collects/tests/racket/place-channel-fd2.rkt @@ -24,17 +24,19 @@ (flush-output p)) (sleep 3) -(with-handlers ([exn? (lambda (e) (eprintf "Child Read Exception Caught ~e\n" e))]) - (fprintf (current-error-port) "ChildRead1 ~a\n" (read))) -(with-handlers ([exn? (lambda (e) (eprintf "Child Read Exception Caught ~e\n" e))]) - (fprintf (current-error-port) "ChildRead2 ~a\n" (read))) +(with-handlers ([exn? (lambda (e) (eprintf "Child Read1 Exception Caught ~e\n" e))]) + (define r (read)) + (log-debug (format "Child Read1 ~a\n" r))) +(with-handlers ([exn? (lambda (e) (eprintf "Child Read2 Exception Caught ~e\n" e))]) + (define r (read)) + (log-debug (format "Child Read2 ~a\n" r))) ;(close-input-port) (sleep 3) (with-handlers ([exn? (lambda (e) (eprintf "Child Write StdOut Exception Caught ~e\n" e))]) (write-flush "ByeO")) -(with-handlers ([exn? (lambda (e) (fprintf "Child Write StdErr Exception Caught ~e\n" e))]) - (write-flush "ByeE" (current-error-port))) +(with-handlers ([exn? (lambda (e) (eprintf "Child Write StdErr Exception Caught ~e\n" e))]) + (log-debug "ByeE")) END ))) From 69a56ef683e557b255de2b8a962077245b4f5955 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 31 Aug 2011 17:34:45 -0600 Subject: [PATCH 179/235] db: clean up test suite, (test conditional) => (conditional test), timing --- collects/tests/db/all-tests.rkt | 2 +- collects/tests/db/config.rkt | 9 +++++++++ collects/tests/db/db/concurrent.rkt | 12 ++++++------ collects/tests/db/db/query.rkt | 16 ++++++++-------- collects/tests/db/db/sql-types.rkt | 18 +++++------------- 5 files changed, 29 insertions(+), 28 deletions(-) diff --git a/collects/tests/db/all-tests.rkt b/collects/tests/db/all-tests.rkt index 42b1d03fe6..99cdd3055a 100644 --- a/collects/tests/db/all-tests.rkt +++ b/collects/tests/db/all-tests.rkt @@ -250,5 +250,5 @@ Testing profiles are flattened, not hierarchical. [else (for ([test tests]) (printf "Running ~s tests\n" (car test)) - (run-tests (cdr test)) + (time (run-tests (cdr test))) (newline))]))) diff --git a/collects/tests/db/config.rkt b/collects/tests/db/config.rkt index 434698cf6b..da69cbc88d 100644 --- a/collects/tests/db/config.rkt +++ b/collects/tests/db/config.rkt @@ -27,6 +27,7 @@ set-equal? sql select-val + dbsystem NOISY? TESTFLAGS ANYFLAGS)) @@ -88,6 +89,14 @@ (sql (string-append "values (" str ")"))] [else (sql (string-append "select " str))])) + (define dbsystem + (with-handlers ([(lambda (e) #t) + (lambda (e) #f)]) + (let* ([c (connect)] + [dbsystem (send c get-dbsystem)]) + (disconnect c) + dbsystem))) + ;; Flags = dbflags U dbsys ;; Returns #t if all are set. diff --git a/collects/tests/db/db/concurrent.rkt b/collects/tests/db/db/concurrent.rkt index 0f25a08de7..a051a580c1 100644 --- a/collects/tests/db/db/concurrent.rkt +++ b/collects/tests/db/db/concurrent.rkt @@ -7,8 +7,8 @@ (export test^) (define (test-concurrency workers) - (test-case (format "lots of threads (~s)" workers) - (unless (ANYFLAGS 'isora 'isdb2) + (unless (ANYFLAGS 'isora 'isdb2) + (test-case (format "lots of threads (~s)" workers) (call-with-connection (lambda (c) (query-exec c "create temporary table play_numbers (n integer)") @@ -40,8 +40,8 @@ (query-value c "select max(n) from play_numbers")))) (define (kill-safe-test proxy?) - (test-case (format "kill-safe test~a" (if proxy? " (proxy)" "")) - (unless (ANYFLAGS 'isora 'isdb2) + (unless (ANYFLAGS 'isora 'isdb2) + (test-case (format "kill-safe test~a" (if proxy? " (proxy)" "")) (call-with-connection (lambda (c0) (let ([c (if proxy? @@ -63,8 +63,8 @@ (sync t)))))))) (define (async-test) - (test-case "asynchronous execution" - (unless (ANYFLAGS 'ismy 'isora 'isdb2) + (unless (ANYFLAGS 'ismy 'isora 'isdb2) + (test-case "asynchronous execution" (call-with-connection (lambda (c) (query-exec c "create temporary table nums (n integer)") diff --git a/collects/tests/db/db/query.rkt b/collects/tests/db/db/query.rkt index e404c40cb6..c396daf566 100644 --- a/collects/tests/db/db/query.rkt +++ b/collects/tests/db/db/query.rkt @@ -33,8 +33,8 @@ (test-suite (format "simple (~a)" prep-mode) - (test-case "query-exec" - (unless (ANYFLAGS 'isora 'isdb2) ;; table isn't temp, so don't tamper with it + (unless (ANYFLAGS 'isora 'isdb2) ;; table isn't temp, so don't tamper with it + (test-case "query-exec" (with-connection c (check-pred void? (Q c query-exec "insert into the_numbers values(-1, 'mysterious')")) (check-equal? (Q c query-value "select descr from the_numbers where N = -1") @@ -143,8 +143,8 @@ (check set-equal? (map vector (map car test-data)) (rows-result-rows q))))) - (test-case "query - update" - (unless (ANYFLAGS 'isora 'isdb2) + (unless (ANYFLAGS 'isora 'isdb2) + (test-case "query - update" (with-connection c (let [(q (query c "update the_numbers set N = -1 where N = 1"))] (check-pred simple-result? q))))) @@ -226,8 +226,8 @@ ;; Added 18 May 2003: Corrected a bug which incorrectly interleaved ;; nulls with returned fields. - (test-case "nulls arrive in correct order" - (unless (TESTFLAGS 'odbc 'issl) + (unless (TESTFLAGS 'odbc 'issl) + (test-case "nulls arrive in correct order" (with-connection c ;; raw NULL has PostgreSQL type "unknown", not allowed (define (clean . strs) @@ -257,8 +257,8 @@ (test-case "query - not a statement" (with-connection c (check-exn exn:fail? (lambda () (query c 5))))) - (test-case "query - multiple statements in string" - (unless (or (TESTFLAGS 'odbc 'ispg) (ANYFLAGS 'isdb2)) + (unless (or (TESTFLAGS 'odbc 'ispg) (ANYFLAGS 'isdb2)) + (test-case "query - multiple statements in string" (with-connection c (check-exn exn:fail? (lambda () diff --git a/collects/tests/db/db/sql-types.rkt b/collects/tests/db/db/sql-types.rkt index 402de55fb4..ed42b49fbc 100644 --- a/collects/tests/db/db/sql-types.rkt +++ b/collects/tests/db/db/sql-types.rkt @@ -12,8 +12,6 @@ (import config^ database^) (export test^) -(define dbsystem #f) ;; hack, set within test suite - (define current-type (make-parameter #f)) (define-syntax-rule (type-test-case types . body) @@ -23,10 +21,9 @@ (let* ([known-types (send dbsystem get-known-types)] [type (for/or ([type types]) (and (member type known-types) type))]) - (if type - (test-case (format "~s" type) - (parameterize ((current-type type)) (proc))) - (test-case (format "unsupported: ~s" types) (void))))) + (when type + (test-case (format "~s" type) + (parameterize ((current-type type)) (proc)))))) (define (check-timestamptz-equal? a b) (check srfi:time=? @@ -143,11 +140,6 @@ (define test (test-suite "SQL types (roundtrip, etc)" - #:before (lambda () - (call-with-connection - (lambda (c) (set! dbsystem (connection-dbsystem c))))) - #:after (lambda () (set! dbsystem #f)) - (type-test-case '(bool boolean) (call-with-connection (lambda (c) @@ -205,8 +197,8 @@ (check-roundtrip c -inf.0) (check-roundtrip c +nan.0))))) - (type-test-case '(numeric decimal) - (unless (ANYFLAGS 'isdb2) ;; "Driver not capable" + (unless (ANYFLAGS 'isdb2) ;; "Driver not capable" + (type-test-case '(numeric decimal) (call-with-connection (lambda (c) (check-roundtrip c 0) From f4d712ac71151ccf7b76dd546f3f0da561cb41eb Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 31 Aug 2011 23:07:02 -0600 Subject: [PATCH 180/235] db: made sql data serializable --- collects/db/private/generic/place-client.rkt | 76 ++++++-------------- collects/db/private/generic/place-server.rkt | 59 ++++++++------- collects/db/private/generic/sql-data.rkt | 27 +++++-- 3 files changed, 71 insertions(+), 91 deletions(-) diff --git a/collects/db/private/generic/place-client.rkt b/collects/db/private/generic/place-client.rkt index d22dd81472..3f51cca579 100644 --- a/collects/db/private/generic/place-client.rkt +++ b/collects/db/private/generic/place-client.rkt @@ -4,15 +4,18 @@ racket/place racket/promise racket/vector + racket/serialize ffi/unsafe/atomic "interfaces.rkt" "prepared.rkt" "sql-data.rkt") (provide place-connect - place-proxy-connection% + place-proxy-connection%) - sql-datum->sexpr - sexpr->sql-datum) +(define (pchan-put chan datum) + (place-channel-put chan (serialize datum))) +(define (pchan-get chan) + (deserialize (place-channel-get chan))) (define connection-server-channel (delay/sync @@ -22,7 +25,7 @@ (let-values ([(channel other-channel) (place-channel)]) (place-channel-put (force connection-server-channel) (list 'connect other-channel connection-spec)) - (match (place-channel-get channel) + (match (pchan-get channel) [(list 'ok) (new proxy% (channel channel))] [(list 'error message) @@ -41,10 +44,10 @@ (call-with-lock* method-name (lambda () (call* method-name args #f)) #f #f)) (define/private (call* method-name args need-connected?) (cond [channel - (place-channel-put channel (cons method-name args)) - (match (place-channel-get channel) + (pchan-put channel (cons method-name args)) + (match (pchan-get channel) [(cons 'values vals) - (apply values (for/list ([val (in-list vals)]) (translate-result val)))] + (apply values (for/list ([val (in-list vals)]) (sexpr->result val)))] [(list 'error message) (raise (make-exn:fail message (current-continuation-marks)))])] [need-connected? @@ -67,13 +70,18 @@ (call 'query fsym (match stmt [(? string?) (list 'string stmt)] - [(statement-binding pst _meta params) - (list 'statement-binding - (send pst get-handle) - (map sql-datum->sexpr params))]))) - + [(statement-binding pst meta params) + (list 'statement-binding (send pst get-handle) meta params)]))) (define/public (prepare fsym stmt close-on-exec?) (call 'prepare fsym stmt close-on-exec?)) + (define/public (transaction-status fsym) + (call 'transaction-status fsym)) + (define/public (start-transaction fsym iso) + (call 'start-transaction fsym iso)) + (define/public (end-transaction fsym mode) + (call 'end-transaction fsym mode)) + (define/public (list-tables fsym schema) + (call 'list-tables fsym schema)) (define/public (free-statement pst) (start-atomic) @@ -83,27 +91,12 @@ (when channel (call/d 'free-statement handle)))) - (define/public (transaction-status fsym) - (call 'transaction-status fsym)) - - (define/public (start-transaction fsym iso) - (call 'start-transaction fsym iso)) - - (define/public (end-transaction fsym mode) - (call 'end-transaction fsym mode)) - - (define/public (list-tables fsym schema) - (call 'list-tables fsym schema)) - - (define/private (translate-result x) + (define/private (sexpr->result x) (match x [(list 'simple-result y) (simple-result y)] [(list 'rows-result h rows) - (let ([rows - (for/list ([row (in-list rows)]) - (vector-map sexpr->sql-datum row))]) - (rows-result h rows))] + (rows-result h rows)] [(list 'prepared-statement handle close-on-exec? param-typeids result-dvecs) (new prepared-statement% (handle handle) @@ -111,27 +104,4 @@ (param-typeids param-typeids) (result-dvecs result-dvecs) (owner this))] - [_ x])) - )) - -(define (sql-datum->sexpr x) - (match x - [(? sql-null?) - 'sql-null] - [(sql-date Y M D) - (list 'sql-date Y M D)] - [(sql-time h m s ns tz) - (list 'sql-time h m s ns tz)] - [(sql-timestamp Y M D h m s ns tz) - (list 'sql-timestamp Y M D h m s ns tz)] - ;; FIXME: add sql-interval when implemented for odbc - [_ x])) - -(define (sexpr->sql-datum x) - (match x - ['sql-null sql-null] - [(list 'sql-date Y M D) (sql-date Y M D)] - [(list 'sql-time h m s ns tz) (sql-time h m s ns tz)] - [(list 'sql-timestamp Y M D h m s ns tz) - (sql-timestamp Y M D h m s ns tz)] - [else x])) + [_ x])))) diff --git a/collects/db/private/generic/place-server.rkt b/collects/db/private/generic/place-server.rkt index dba93176d4..2e6e24c1c2 100644 --- a/collects/db/private/generic/place-server.rkt +++ b/collects/db/private/generic/place-server.rkt @@ -3,6 +3,7 @@ racket/class racket/match racket/place + racket/serialize "lazy-require.rkt" "interfaces.rkt" "prepared.rkt" @@ -10,6 +11,11 @@ "place-client.rkt") (provide connection-server) +(define (pchan-put chan datum) + (place-channel-put chan (serialize datum))) +(define (pchan-get chan) + (deserialize (place-channel-get chan))) + #| Connection creation protocol @@ -37,8 +43,7 @@ where ::= (list 'sqlite3 path/sym mode-sym delay-num limit-num) [(list 'connect conn-chan connect-spec) (with-handlers ([exn:fail? (lambda (e) - (place-channel-put conn-chan - (list 'error (exn-message e))))]) + (pchan-put conn-chan (list 'error (exn-message e))))]) (let* ([c (match connect-spec [(list 'sqlite3 db mode busy-retry-delay busy-retry-limit) @@ -60,7 +65,7 @@ where ::= (list 'sqlite3 path/sym mode-sym delay-num limit-num) #:character-mode char-mode #:use-place #f)])] [p (new proxy-server% (connection c) (channel conn-chan))]) - (place-channel-put conn-chan (list 'ok)) + (pchan-put conn-chan (list 'ok)) (thread (lambda () (send p serve)))))])) #| @@ -87,53 +92,45 @@ server -> client: (or (list 'values result ...) (define/private (serve1) (with-handlers ([exn? (lambda (e) - (place-channel-put channel (list 'error (exn-message e))))]) + (pchan-put channel (list 'error (exn-message e))))]) (call-with-values (lambda () - (match (place-channel-get channel) + (match (pchan-get channel) [(list 'disconnect) (send connection disconnect) (set! connection #f)] [(list 'free-statement pstmt-index) (send connection free-statement (hash-ref pstmt-table pstmt-index)) (hash-remove! pstmt-table pstmt-index)] + [(list 'query fsym stmt) + (send connection query fsym (sexpr->statement stmt))] [msg - (define-syntax-rule (forward-methods (method (arg translate) ...) ...) + (define-syntax-rule (forward-methods (method arg ...) ...) (match msg - [(list 'method arg ...) - (send connection method (translate arg) ...)] - ...)) - (define-syntax-rule (id x) x) + [(list 'method arg ...) + (send connection method arg ...)] + ...)) (forward-methods (connected?) - (query (w id) (s translate-in-stmt)) - (prepare (w id) (s id) (m id)) - (list-tables (w id) (s id)) - (start-transaction (w id) (m id)) - (end-transaction (w id) (m id)) - (transaction-status (w id)))])) + (prepare w s m) + (list-tables w s) + (start-transaction w m) + (end-transaction w m) + (transaction-status w))])) (lambda results - (let ([results (for/list ([result (in-list results)]) (translate-result result))]) - (place-channel-put channel (cons 'values results))))))) + (let ([results (for/list ([result (in-list results)]) (result->sexpr result))]) + (pchan-put channel (cons 'values results))))))) - (define/private (translate-in-stmt x) + (define/private (sexpr->statement x) (match x - [(list 'string s) - s] - [(list 'statement-binding pstmt-index args) - (statement-binding (hash-ref pstmt-table pstmt-index) - null - (map sexpr->sql-datum args))])) + [(list 'string s) s] + [(list 'statement-binding pstmt-index meta args) + (statement-binding (hash-ref pstmt-table pstmt-index) meta args)])) - (define/private (translate-result x) + (define/private (result->sexpr x) (match x [(simple-result y) (list 'simple-result y)] [(rows-result h rows) - (for ([row (in-list rows)]) - (for ([i (in-range (vector-length row))]) - (let* ([x (vector-ref row i)] - [nx (sql-datum->sexpr x)]) - (unless (eq? x nx) (vector-set! row i nx))))) (list 'rows-result h rows)] ;; FIXME: Assumes prepared-statement is concrete class, not interface. [(? (lambda (x) (is-a? x prepared-statement%))) diff --git a/collects/db/private/generic/sql-data.rkt b/collects/db/private/generic/sql-data.rkt index 6336173377..732972fd64 100644 --- a/collects/db/private/generic/sql-data.rkt +++ b/collects/db/private/generic/sql-data.rkt @@ -1,4 +1,5 @@ #lang racket/base +(require racket/serialize) (provide (all-defined-out)) ;; SQL Data @@ -10,8 +11,15 @@ (define sql-null (let () - (define-struct sql-null ()) - (make-sql-null))) + (struct sql-null () + ;; must deserialize to singleton, so can't just use serializable-struct + #:property prop:serializable + (make-serialize-info (lambda _ '#()) + #'deserialize-info:sql-null-v0 + #f + (or (current-load-relative-directory) + (current-directory)))) + (sql-null))) (define (sql-null? x) (eq? x sql-null)) @@ -26,6 +34,11 @@ sql-null x)) +(define deserialize-info:sql-null-v0 + (make-deserialize-info + (lambda _ sql-null) + (lambda () (error 'deserialize-sql-null "cannot have cycles")))) + ;; ---------------------------------------- ;; Dates and times @@ -44,15 +57,15 @@ - timezone offset too limited |# -(define-struct sql-date (year month day) #:transparent) -(define-struct sql-time (hour minute second nanosecond tz) #:transparent) -(define-struct sql-timestamp +(define-serializable-struct sql-date (year month day) #:transparent) +(define-serializable-struct sql-time (hour minute second nanosecond tz) #:transparent) +(define-serializable-struct sql-timestamp (year month day hour minute second nanosecond tz) #:transparent) ;; Intervals must be "pre-multiplied" rather than carry extra sign field. ;; Rationale: postgresql, at least, allows mixture of signs, eg "1 month - 30 days" -(define-struct sql-interval +(define-serializable-struct sql-interval (years months days hours minutes seconds nanoseconds) #:transparent #:guard (lambda (years months days hours minutes seconds nanoseconds _name) @@ -131,7 +144,7 @@ byte. (Because that's PostgreSQL's binary format.) For example: (bytes 128 3) represents 1000000 0000011 |# -(struct sql-bits (length bv offset)) +(serializable-struct sql-bits (length bv offset)) (define (make-sql-bits len) (sql-bits len (make-bytes (/ceiling len 8) 0) 0)) From 5db417fcf2f6e3c1178b9106760df7bcebf10131 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Thu, 1 Sep 2011 19:38:08 -0600 Subject: [PATCH 181/235] db: add support for odbc on macosx (needs testing) --- collects/db/private/odbc/ffi.rkt | 21 +++++++++++++++------ 1 file changed, 15 insertions(+), 6 deletions(-) diff --git a/collects/db/private/odbc/ffi.rkt b/collects/db/private/odbc/ffi.rkt index 370190b06d..5669dafd8c 100644 --- a/collects/db/private/odbc/ffi.rkt +++ b/collects/db/private/odbc/ffi.rkt @@ -20,11 +20,6 @@ (define _sqluinteger _uint) (define _sqlreturn _sqlsmallint) -;; Windows ODBC defines wchar_t, thus WCHAR, as 16-bit -;; unixodbc defines WCHAR as 16-bit for compat w/ Windows -;; (even though Linux wchar_t is 32-bit) -(define WCHAR-SIZE 2) - (define-ffi-definer define-mz #f) (define-mz scheme_utf16_to_ucs4 @@ -118,7 +113,21 @@ Docs at http://msdn.microsoft.com/en-us/library/ms712628%28v=VS.85%29.aspx (define odbc-lib (case (system-type) ((windows) (ffi-lib "odbc32.dll")) - (else (ffi-lib "libodbc" '("1" #f))))) + ((macosx) (ffi-lib "libiodbc" '("2" #f))) + ((unix) (ffi-lib "libodbc" '("1" #f))))) + +(define WCHAR-SIZE + (case (system-type) + ((windows) + ;; Windows ODBC defines wchar_t, thus WCHAR, thus SQLWCHAR, as 16-bit + 2) + ((macosx) + ;; MacOSX uses iodbc, which defines SQLWCHAR as wchar_t, as 32-bit + 4) + ((unix) + ;; unixodbc defines WCHAR as 16-bit for compat w/ Windows + ;; (even though Linux wchar_t is 32-bit) + 2))) (define-ffi-definer define-odbc odbc-lib) From 766e6c2f00a788d6195208449c380bd7f547448a Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Thu, 1 Sep 2011 19:37:24 -0600 Subject: [PATCH 182/235] rackunit/tool: avoid attaching module to user namespace --- collects/rackunit/tool.rkt | 23 ++++++----------------- 1 file changed, 6 insertions(+), 17 deletions(-) diff --git a/collects/rackunit/tool.rkt b/collects/rackunit/tool.rkt index ba75e1a362..230df69fd4 100644 --- a/collects/rackunit/tool.rkt +++ b/collects/rackunit/tool.rkt @@ -3,8 +3,7 @@ racket/gui/base framework drscheme/tool - racket/unit - (prefix-in drlink: "private/gui/drracket-link.rkt")) + racket/unit) (provide tool@) @@ -13,8 +12,6 @@ (define BACKTRACE-NO-MESSAGE "No message.") (define LINK-MODULE-SPEC 'rackunit/private/gui/drracket-link) -(define-namespace-anchor drracket-ns-anchor) - ;; ---- ;; close/eventspace : (a* -> b) -> (a* -> b) @@ -63,25 +60,17 @@ (drscheme:debug:open-and-highlight-in-file (list (make-srcloc src #f #f pos span)))))) - ;; Send them off to the drscheme-ui module. - ;; We'll still have to attach our instantiation of drscheme-link - ;; to the user namespace. - (set-box! drlink:link - (vector get-errortrace-backtrace - show-backtrace - show-source)) - - (define drracket-ns (namespace-anchor->namespace drracket-ns-anchor)) - (define interactions-text-mixin (mixin ((class->interface drscheme:rep:text%)) () (inherit get-user-namespace) (super-new) (define/private (setup-helper-module) - (namespace-attach-module drracket-ns - LINK-MODULE-SPEC - (get-user-namespace))) + (let ([link (parameterize ((current-namespace (get-user-namespace))) + (dynamic-require LINK-MODULE-SPEC 'link))]) + (set-box! link (vector get-errortrace-backtrace + show-backtrace + show-source)))) (define/override (reset-console) (super reset-console) From e6433084f318b2b5bf8c2c35d13e6e86253a19bd Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Thu, 1 Sep 2011 22:21:31 -0600 Subject: [PATCH 183/235] added unstable/lazy-require Also fixed lazy-require to capture and use correct namespace. --- collects/db/main.rkt | 48 ++++++++----------- collects/db/private/generic/dsn.rkt | 17 +++---- collects/db/private/generic/lazy-require.rkt | 38 --------------- collects/db/private/generic/place-server.rkt | 12 ++--- collects/unstable/lazy-require.rkt | 37 ++++++++++++++ .../unstable/scribblings/lazy-require.scrbl | 24 ++++++++++ collects/unstable/scribblings/unstable.scrbl | 1 + 7 files changed, 93 insertions(+), 84 deletions(-) delete mode 100644 collects/db/private/generic/lazy-require.rkt create mode 100644 collects/unstable/lazy-require.rkt create mode 100644 collects/unstable/scribblings/lazy-require.scrbl diff --git a/collects/db/main.rkt b/collects/db/main.rkt index 673c48b3e5..3a852f1e54 100644 --- a/collects/db/main.rkt +++ b/collects/db/main.rkt @@ -1,38 +1,28 @@ #lang racket/base (require (for-syntax racket/base) - "private/generic/lazy-require.rkt" - racket/runtime-path + unstable/lazy-require racket/contract "base.rkt") (provide (all-from-out "base.rkt")) -(define-lazy-require-definer define-postgresql "private/postgresql/main.rkt") -(define-lazy-require-definer define-mysql "private/mysql/main.rkt") -(define-lazy-require-definer define-sqlite3 "private/sqlite3/main.rkt") -(define-lazy-require-definer define-odbc "private/odbc/main.rkt") -(define-lazy-require-definer define-openssl 'openssl) - -(define-postgresql - postgresql-connect - postgresql-guess-socket-path - postgresql-password-hash) - -(define-mysql - mysql-connect - mysql-guess-socket-path - mysql-password-hash) - -(define-sqlite3 - sqlite3-connect) - -(define-odbc - odbc-connect - odbc-driver-connect - odbc-data-sources - odbc-drivers) - -(define-openssl - ssl-client-context?) +(lazy-require + ["private/postgresql/main.rkt" + (postgresql-connect + postgresql-guess-socket-path + postgresql-password-hash)] + ["private/mysql/main.rkt" + (mysql-connect + mysql-guess-socket-path + mysql-password-hash)] + ["private/sqlite3/main.rkt" + (sqlite3-connect)] + ["private/odbc/main.rkt" + (odbc-connect + odbc-driver-connect + odbc-data-sources + odbc-drivers)] + ['openssl + (ssl-client-context?)]) (provide/contract ;; Duplicates contracts at postgresql.rkt diff --git a/collects/db/private/generic/dsn.rkt b/collects/db/private/generic/dsn.rkt index 177b659cc1..3100dc1490 100644 --- a/collects/db/private/generic/dsn.rkt +++ b/collects/db/private/generic/dsn.rkt @@ -1,9 +1,8 @@ #lang racket/base -(require "lazy-require.rkt" +(require unstable/lazy-require racket/match racket/file - racket/list - racket/runtime-path) + racket/list) (provide dsn-connect (struct-out data-source) connector? @@ -17,13 +16,11 @@ sqlite3-data-source odbc-data-source) -(define-lazy-require-definer define-main "../../main.rkt") - -(define-main - postgresql-connect - mysql-connect - sqlite3-connect - odbc-connect) +(lazy-require + ["../../main.rkt" (postgresql-connect + mysql-connect + sqlite3-connect + odbc-connect)]) #| DSN v0.1 format diff --git a/collects/db/private/generic/lazy-require.rkt b/collects/db/private/generic/lazy-require.rkt deleted file mode 100644 index 2b217a6ad2..0000000000 --- a/collects/db/private/generic/lazy-require.rkt +++ /dev/null @@ -1,38 +0,0 @@ -#lang racket/base -(require (for-syntax racket/base) - racket/runtime-path - racket/promise) -(provide define-lazy-require-definer) - -(define-syntax (define-lazy-require-definer stx) - (syntax-case stx () - [(_ name modpath) - (begin - (unless (identifier? #'name) - (raise-syntax-error #f "expected identifier" stx #'name)) - #'(begin (define-runtime-module-path-index mpi-var modpath) - (define-syntax name (make-lazy-require-definer #'mpi-var))))])) - -(define-for-syntax (make-lazy-require-definer mpi-var) - (lambda (stx) - (syntax-case stx () - [(_ fun ...) - (begin - (for ([fun (in-list (syntax->list #'(fun ...)))]) - (unless (identifier? fun) - (raise-syntax-error #f "expected identifier for function name" stx fun))) - (with-syntax ([(fun-p ...) (generate-temporaries #'(fun ...))] - [mpi-var mpi-var]) - ;; Use 'delay/sync' because 'delay' promise is not reentrant. - ;; FIXME: OTOH, 'delay/sync' promise is not kill-safe. - #'(begin (define fun-p (delay/sync (dynamic-require mpi-var 'fun))) - ... - (define fun (make-delayed-function 'fun fun-p)) - ...)))]))) - -(define (make-delayed-function name fun-p) - (procedure-rename - (make-keyword-procedure - (lambda (kws kwargs . args) - (keyword-apply (force fun-p) kws kwargs args))) - name)) diff --git a/collects/db/private/generic/place-server.rkt b/collects/db/private/generic/place-server.rkt index 2e6e24c1c2..155007cd95 100644 --- a/collects/db/private/generic/place-server.rkt +++ b/collects/db/private/generic/place-server.rkt @@ -4,7 +4,7 @@ racket/match racket/place racket/serialize - "lazy-require.rkt" + unstable/lazy-require "interfaces.rkt" "prepared.rkt" "sql-data.rkt" @@ -31,12 +31,10 @@ where ::= (list 'sqlite3 path/sym mode-sym delay-num limit-num) (serve client-chan) (loop))) -(define-lazy-require-definer define-main "../../main.rkt") - -(define-main - sqlite3-connect - odbc-connect - odbc-driver-connect) +(lazy-require + ["../../main.rkt" (sqlite3-connect + odbc-connect + odbc-driver-connect)]) (define (serve client-chan) (match (place-channel-get client-chan) diff --git a/collects/unstable/lazy-require.rkt b/collects/unstable/lazy-require.rkt new file mode 100644 index 0000000000..e33b7cbd96 --- /dev/null +++ b/collects/unstable/lazy-require.rkt @@ -0,0 +1,37 @@ +#lang racket/base +(require (for-syntax racket/base) + racket/runtime-path + racket/promise) +(provide lazy-require + (for-syntax #%datum)) + +(define-syntax (lazy-require stx) + (syntax-case stx () + [(lazy-require [modpath (thing ...)] ...) + #`(begin (define-namespace-anchor anchor) + (lazy-require1 modpath (thing ...) anchor #,stx) + ...)])) + +(define-syntax (lazy-require1 stx) + (syntax-case stx () + [(lazy-require1 modpath (name ...) anchor orig-stx) + (with-syntax ([(defn ...) + (for/list ([name (in-list (syntax->list #'(name ...)))]) + (unless (identifier? name) + (raise-syntax-error #f "expected identifier" #'orig-stx name)) + #`(define #,name (make-lazy-function '#,name get-sym)))]) + #'(begin (define-runtime-module-path-index mpi-var modpath) + (define (get-sym sym) + (parameterize ((current-namespace (namespace-anchor->namespace anchor))) + (dynamic-require mpi-var sym))) + defn ...))])) + +(define (make-lazy-function name get-sym) + ;; Use 'delay/sync' because 'delay' promise is not reentrant. + ;; FIXME: OTOH, 'delay/sync' promise is not kill-safe. + (let ([fun-p (delay/sync (get-sym name))]) + (procedure-rename + (make-keyword-procedure + (lambda (kws kwargs . args) + (keyword-apply (force fun-p) kws kwargs args))) + name))) diff --git a/collects/unstable/scribblings/lazy-require.scrbl b/collects/unstable/scribblings/lazy-require.scrbl new file mode 100644 index 0000000000..a7453c8dc6 --- /dev/null +++ b/collects/unstable/scribblings/lazy-require.scrbl @@ -0,0 +1,24 @@ +#lang scribble/manual +@(require scribble/eval + "utils.rkt" + (for-label racket/base + racket/runtime-path + unstable/lazy-require)) + +@title[#:tag "lazy-require"]{Lazy Require} + +@defmodule[unstable/lazy-require] + +@unstable[@author+email["Ryan Culpepper" "ryanc@racket-lang.org"]] + +@defform[(lazy-require [mod-expr (imported-fun-id ...)] ...) + #:contracts ([mod-expr module-path?])]{ + +Defines each @racket[imported-fun-id] as a function that, when called, +dynamically requires the export named @racket['imported-fun-id] from +the module specified by @racket[mod-expr] and calls it with the same +arguments. + +As with @racket[define-runtime-module-path-index], @racket[mod-expr] +is evaluated both in phase 0 and phase 1. +} diff --git a/collects/unstable/scribblings/unstable.scrbl b/collects/unstable/scribblings/unstable.scrbl index 3c72f03fbf..61ca638b48 100644 --- a/collects/unstable/scribblings/unstable.scrbl +++ b/collects/unstable/scribblings/unstable.scrbl @@ -88,6 +88,7 @@ Keep documentation and tests up to date. @include-section["generics.scrbl"] @include-section["hash.scrbl"] @include-section["class-iop.scrbl"] ;; Interface-oriented Programming +@include-section["lazy-require.scrbl"] @include-section["list.scrbl"] @include-section["logging.scrbl"] @include-section["markparam.scrbl"] From 15e3640191676a59e1e220b4f97101ca0c827367 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sat, 3 Sep 2011 14:52:06 -0600 Subject: [PATCH 184/235] db: fix #:group contract, fix sqlite headers --- collects/db/TODO | 7 + collects/db/base.rkt | 4 +- collects/db/private/generic/functions.rkt | 2 +- collects/db/private/sqlite3/connection.rkt | 35 +++-- collects/db/private/sqlite3/ffi.rkt | 8 ++ collects/db/scribblings/db.scrbl | 16 +-- collects/db/scribblings/notes.scrbl | 141 ++++++++++++--------- 7 files changed, 129 insertions(+), 84 deletions(-) diff --git a/collects/db/TODO b/collects/db/TODO index 3a69ba3572..1c31fcc149 100644 --- a/collects/db/TODO +++ b/collects/db/TODO @@ -71,3 +71,10 @@ Misc - connection-pool-lease-evt - when is it useful in practice? - would make it easier to handle timeouts... + +- on insert, return last inserted id + - postgresql: parse CommandComplete msg tag + - mysql: in ok-packet (what conditions, though?) + - sqlite3: sqlite3_last_insert_rowid(), use sqlite3_changes() to see if insert succeeded, + but still need to tell if stmt was even insert (parse sql?) + - odbc: ??? diff --git a/collects/db/base.rkt b/collects/db/base.rkt index 7fc39c6d71..fe626b3aa6 100644 --- a/collects/db/base.rkt +++ b/collects/db/base.rkt @@ -104,7 +104,9 @@ [query-exec (->* (connection? statement?) () #:rest list? any)] [query-rows - (->* (connection? statement?) () #:rest list? (listof vector?))] + (->* (connection? statement?) + (#:group (or/c (vectorof string?) (listof (vectorof string?)))) + #:rest list? (listof vector?))] [query-list (->* (connection? statement?) () #:rest list? list?)] [query-row diff --git a/collects/db/private/generic/functions.rkt b/collects/db/private/generic/functions.rkt index 554fb73fb9..54527bbe0e 100644 --- a/collects/db/private/generic/functions.rkt +++ b/collects/db/private/generic/functions.rkt @@ -142,7 +142,7 @@ (let* ([sql (compose-statement 'query-rows c sql args 'rows)] [result (query/rows c 'query-rows sql #f)] [result - (cond [(pair? group-fields-list) + (cond [(not (null? group-fields-list)) (group-rows-result* 'query-rows result group-fields-list (not (memq 'preserve-null-rows group-mode)) (memq 'list group-mode))] diff --git a/collects/db/private/sqlite3/connection.rkt b/collects/db/private/sqlite3/connection.rkt index 523d4336a5..3d9a4b5657 100644 --- a/collects/db/private/sqlite3/connection.rkt +++ b/collects/db/private/sqlite3/connection.rkt @@ -37,14 +37,13 @@ (define/override (connected?) (and -db #t)) (define/public (query fsym stmt) - (let-values ([(stmt* info rows) + (let-values ([(stmt* result) (call-with-lock fsym (lambda () (check-valid-tx-status fsym) (query1 fsym stmt)))]) (statement:after-exec stmt) - (cond [(pair? info) (rows-result info rows)] - [else (simple-result '())]))) + result)) (define/private (query1 fsym stmt) (let* ([stmt (cond [(string? stmt) @@ -64,12 +63,23 @@ (load-param fsym db stmt i param)) (let* ([info (for/list ([i (in-range (sqlite3_column_count stmt))]) - `((name ,(sqlite3_column_name stmt i)) - (decltype ,(sqlite3_column_decltype stmt i))))] + `((name . ,(sqlite3_column_name stmt i)) + (decltype . ,(sqlite3_column_decltype stmt i))))] [rows (step* fsym db stmt)]) (HANDLE fsym (sqlite3_reset stmt)) (HANDLE fsym (sqlite3_clear_bindings stmt)) - (values stmt info rows))))) + (values stmt + (cond [(pair? info) + (rows-result info rows)] + [else + (let ([changes (sqlite3_changes db)]) + (cond [(and (positive? changes) + #f ;; Note: currently disabled + #| FIXME: statement was INSERT stmt |#) + (simple-result + (list (cons 'last-insert-rowid + (sqlite3_last_insert_rowid db))))] + [else (simple-result '())]))])))))) (define/private (load-param fsym db stmt i param) (HANDLE fsym @@ -203,7 +213,7 @@ (let ([db (get-db fsym)]) (when (get-tx-status db) (error/already-in-tx fsym)) - (let-values ([(stmt* _info _rows) + (let-values ([(stmt* _result) (query1 fsym "BEGIN TRANSACTION")]) stmt*))))]) (statement:after-exec stmt) @@ -217,7 +227,7 @@ (unless (eq? mode 'rollback) (check-valid-tx-status fsym)) (when (get-tx-status db) - (let-values ([(stmt* _info _rows) + (let-values ([(stmt* _result) (case mode ((commit) (query1 fsym "COMMIT TRANSACTION")) @@ -235,14 +245,11 @@ ;; schema ignored, because sqlite doesn't support (string-append "SELECT tbl_name from sqlite_master " "WHERE type = 'table' or type = 'view'")]) - (let-values ([(stmt rows) + (let-values ([(stmt result) (call-with-lock fsym - (lambda () - (let-values ([(stmt _info rows) - (query1 fsym stmt)]) - (values stmt rows))))]) + (lambda () (query1 fsym stmt)))]) (statement:after-exec stmt) - (for/list ([row (in-list rows)]) + (for/list ([row (in-list (rows-result-rows result))]) (vector-ref row 0))))) ;; ---- diff --git a/collects/db/private/sqlite3/ffi.rkt b/collects/db/private/sqlite3/ffi.rkt index 94db428b6d..8fd7e8ce78 100644 --- a/collects/db/private/sqlite3/ffi.rkt +++ b/collects/db/private/sqlite3/ffi.rkt @@ -140,6 +140,14 @@ (_fun _sqlite3_statement -> _string)) +(define-sqlite sqlite3_changes + (_fun _sqlite3_database + -> _int)) + +(define-sqlite sqlite3_last_insert_rowid + (_fun _sqlite3_database + -> _int)) + ;; ---------------------------------------- #| diff --git a/collects/db/scribblings/db.scrbl b/collects/db/scribblings/db.scrbl index 99369d1199..8b8e76d8fa 100644 --- a/collects/db/scribblings/db.scrbl +++ b/collects/db/scribblings/db.scrbl @@ -26,17 +26,15 @@ native client library is required.} @item{@bold{@as-index{@hyperlink["http://www.sqlite.org"]{SQLite}} version 3.} The SQLite native client library is required; see -@secref["sqlite3-native-libs"].} +@secref["sqlite3-requirements"].} @item{@bold{@as-index{ODBC}.} An ODBC Driver Manager and appropriate -ODBC drivers are required; see @secref["odbc-native-libs"]. The -following additional database systems are known to work with this -library's ODBC support (see @secref["odbc-status"] for details): -@itemlist[ -@item{@bold{@as-index{@hyperlink["http://www.oracle.com"]{Oracle}}}} -@item{@bold{@as-index{@hyperlink["http://www.ibm.com/software/data/db2/"]{DB2}}}} -@item{@bold{@as-index{@hyperlink["http://www.microsoft.com/sqlserver/"]{SQL Server}}}} -]} +ODBC drivers are required; see @secref["odbc-requirements"]. The +following database systems are known to work with this library via +ODBC (see @secref["odbc-status"] for details): +@bold{@as-index{@hyperlink["http://www.ibm.com/software/data/db2/"]{DB2}}}, +@bold{@as-index{@hyperlink["http://www.oracle.com"]{Oracle}}}, and +@bold{@as-index{@hyperlink["http://www.microsoft.com/sqlserver/"]{SQL Server}}}.} ] The query operations are functional in spirit: queries return results diff --git a/collects/db/scribblings/notes.scrbl b/collects/db/scribblings/notes.scrbl index 55d51512bd..2a5860c060 100644 --- a/collects/db/scribblings/notes.scrbl +++ b/collects/db/scribblings/notes.scrbl @@ -4,25 +4,27 @@ scribble/struct racket/sandbox "config.rkt" - (for-label db)) + (for-label db + setup/dirs)) @title[#:tag "notes"]{Notes} -This section describes miscellaneous issues. +This section discusses issues related to specific database systems. + @section[#:tag "connecting-to-server"]{Local Sockets for PostgreSQL and MySQL Servers} PostgreSQL and MySQL servers are sometimes configured by default to listen only on local sockets (also called ``unix domain sockets''). This library provides support for communication over local -sockets, but only on Linux (x86 and x86-64) and Mac OS X. If local -socket communication is not available, the server must be reconfigured -to listen on a TCP port. +sockets on Linux (x86 and x86-64) and Mac OS X. If local socket +communication is not available, the server must be reconfigured to +listen on a TCP port. The socket file for a PostgreSQL server is located in the directory specified by the @tt{unix_socket_directory} variable in the @tt{postgresql.conf} server configuration file. For example, on -Ubuntu 10.10 running PostgreSQL 8.4, the socket directory is +Ubuntu 11.04 running PostgreSQL 8.4, the socket directory is @tt{/var/run/postgresql} and the socket file is @tt{/var/run/postgresql/.s.PGSQL.5432}. Common socket paths may be searched automatically using the @racket[postgresql-guess-socket-path] @@ -30,20 +32,19 @@ function. The socket file for a MySQL server is located at the path specified by the @tt{socket} variable in the @tt{my.cnf} configuration file. For -example, on Ubuntu 10.10 running MySQL 5.1, the socket is located at +example, on Ubuntu 11.04 running MySQL 5.1, the socket is located at @tt{/var/run/mysqld/mysqld.sock}. Common socket paths for MySQL can be searched using the @racket[mysql-guess-socket-path] function. -@section{Database Character Encodings} +@section{PostgreSQL Database Character Encoding} -In most cases, a PostgreSQL or MySQL database's character encoding is -irrelevant, since the connect function always requests translation to -Unicode (UTF-8) when creating a connection. If a PostgreSQL database's -character encoding is @tt{SQL_ASCII}, however, PostgreSQL will not -honor the connection encoding; it will instead send untranslated -octets, which will cause corrupt data or internal errors in the client -connection. +In most cases, a database's character encoding is irrelevant, since +the connect function always requests translation to Unicode (UTF-8) +when creating a connection. If a PostgreSQL database's character +encoding is @tt{SQL_ASCII}, however, PostgreSQL will not honor the +connection encoding; it will instead send untranslated octets, which +will cause corrupt data or internal errors in the client connection. To convert a PostgreSQL database from @tt{SQL_ASCII} to something sensible, @tt{pg_dump} the database, recode the dump file (using a @@ -51,31 +52,17 @@ utility such as @tt{iconv}), create a new database with the desired encoding, and @tt{pg_restore} from the recoded dump file. -@section{Prepared Query Parameter Types} - -Different database systems vary in their handling of query parameter -types. For example, consider the following parameterized SQL -statement: - -@tt{SELECT 1 + ?;} - -PostgreSQL reports an expected type of @tt{integer} for the parameter and -will not accept other types. MySQL and SQLite, in contrast, report no -useful parameter type information, and ODBC connections vary in -behavior based on the driver, the data source configuration, and the -connection parameters (see @secref["odbc-status"] for specific notes). - - @section{PostgreSQL Authentication} -PostgreSQL supports a large variety of authentication mechanisms, -controlled by the @tt{pg_hba.conf} server configuration file. This -library currently supports only cleartext and md5-hashed passwords, -and it does not send cleartext passwords unless explicitly ordered to -(see @racket[postgresql-connect]). These correspond to the @tt{md5} -and @tt{password} authentication methods in the parlance of +PostgreSQL supports a large variety of +@hyperlink["http://www.postgresql.org/docs/8.4/static/auth-pg-hba-conf.html"]{authentication +mechanisms}, controlled by the @tt{pg_hba.conf} server configuration +file. This library currently supports only cleartext and md5-hashed +passwords, and it does not send cleartext passwords unless explicitly +ordered to (see @racket[postgresql-connect]). These correspond to the +@tt{md5} and @tt{password} authentication methods in the parlance of @tt{pg_hba.conf}, respectively. On Linux, @tt{ident} authentication is -automatically supported for unix domain sockets (but not TCP). The +automatically supported for local sockets, but not TCP sockets. The @tt{gss}, @tt{sspi}, @tt{krb5}, @tt{pam}, and @tt{ldap} methods are not supported. @@ -89,36 +76,69 @@ plugins}. The only plugin currently supported by this library is password authentication mechanism used since version 4.1. -@section[#:tag "sqlite3-native-libs"]{SQLite Native Library} +@section[#:tag "sqlite3-requirements"]{SQLite Requirements} -SQLite support requires the appropriate native library, specifically -@tt{libsqlite3.so.0} on Unix or @tt{sqlite3.dll} on Windows. +SQLite support requires the appropriate native library. + +@itemlist[ + +@item{On Windows, the library is @tt{sqlite3.dll}. It can be obtained +from @hyperlink["http://www.sqlite.org/download.html"]{the SQLite +download page}; the DLL file should be extracted and placed into one +of the directories produced by +@racketblock[(begin (require setup/dirs) (get-lib-search-dirs))]} + +@item{On Mac OS X, the library is @tt{libsqlite3.0.dylib}, which is +included (in @tt{/usr/lib}) in Mac OS X version 10.4 onwards.} + +@item{On Linux, the library is @tt{libsqlite3.so.0}. It is included in +the @tt{libsqlite3-0} package in Debian/Ubuntu and in the @tt{sqlite} +package in Red Hat.} +] -@section[#:tag "odbc-native-libs"]{ODBC Native Libraries} +@section[#:tag "odbc-requirements"]{ODBC Requirements} -ODBC support requires the appropriate native library, specifically -@tt{libodbc.so.1} (from unixODBC; iODBC is not supported) on Unix or -@tt{odbc32.dll} on Windows. In addition, the appropriate ODBC Drivers -must be installed and any Data Sources configured. +ODBC requires the appropriate driver manager native library as well as +driver native libraries for each database system you want use ODBC to +connect to. + +@itemlist[ + +@item{On Windows, the driver manager is @tt{odbc32.dll}, which is +included automatically with Windows.} + +@item{On Mac OS X, the driver manager is @tt{libiodbc.2.dylib} +(@hyperlink["http://www.iodbc.org"]{iODBC}), which is included (in +@tt{/usr/lib}) in Mac OS X version 10.2 onwards.} + +@item{On Linux, the driver manager is @tt{libodbc.so.1} +(@hyperlink["http://www.unixodbc.org"]{unixODBC}---iODBC is not +supported). It is available from the @tt{unixodbc} package in +Debian/Ubuntu and in the @tt{unixODBC} package in Red Hat.} +] + +In addition, you must install the appropriate ODBC Drivers and +configure Data Sources. Refer to the ODBC documentation for the +specific database system for more information. -@section[#:tag "odbc-status"]{ODBC Support Status} +@section[#:tag "odbc-status"]{ODBC Status} -ODBC support is experimental. This library is compatible only with -ODBC 3.x Driver Managers. The behavior of ODBC connections can vary -widely depending on the driver in use and even the configuration of a -particular data source. +ODBC support is experimental. The behavior of ODBC connections can +vary widely depending on the driver in use and even the configuration +of a particular data source. The following sections describe the configurations that this library -has been tested with. The platform @bold{win32} means Windows Vista on -a 32-bit processor and @bold{linux} means Ubuntu 11.04 and unixODBC on -both x86 (32-bit) and x86-64 processors, unless otherwise -specified. The iODBC Driver Manager is not supported. +has been tested with. Reports of success or failure on other platforms or with other drivers would be appreciated. +@;{ +** There's no reason to actually use the following drivers. They're just +** useful for testing ODBC support. + @subsection{PostgreSQL ODBC Driver} The PostgreSQL ODBC driver version 09.00.0300 has been tested on @@ -149,15 +169,18 @@ Furthermore, this driver interprets the declared types of columns strictly, replacing nonconforming values in query results with @tt{NULL}. All computed columns, even those with explicit @tt{CAST}s, seem to be returned as @tt{text}. +} @subsection{DB2 ODBC Driver} -The driver from IBM DB2 Express-C v9.7 has been tested on @bold{linux} +The driver from IBM DB2 Express-C v9.7 has been tested on Ubuntu 11.04 (32-bit only). For a typical installation where the instance resides at @tt{/home/db2inst1}, set the following option in the Driver -configuration: @tt{Driver = /home/db2inst1/sqllib/lib32/libdb2.so}. +configuration: @tt{Driver = +/home/db2inst1/sqllib/lib32/libdb2.so}. (The path would presumably be +different for a 64-bit installation.) The DB2 driver does not seem to accept a separate argument for the database to connect to; it must be the same as the Data Source name. @@ -165,7 +188,7 @@ database to connect to; it must be the same as the Data Source name. @subsection{Oracle ODBC Driver} The driver from Oracle Database 10g Release 2 Express Edition has been -tested on @bold{linux} (32-bit only). +tested on Ubuntu 11.04 (32-bit only). It seems the @tt{ORACLE_HOME} and @tt{LD_LIBRARY_PATH} environment variables must be set according to the @tt{oracle_env.{csh,sh}} script @@ -185,5 +208,5 @@ Maybe Oracle bug? See: @subsection{SQL Server ODBC Driver} -Basic SQL Server support has been verified on @bold{win32}, but the -automated test suite has not yet been adapted and run. +Basic SQL Server support has been verified on Windows (32-bit only), +but the automated test suite has not yet been adapted and run. From 68e76a9876a736f97c48469c546d10fdc20d4374 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Tue, 6 Sep 2011 02:07:01 -0600 Subject: [PATCH 185/235] =?UTF-8?q?syntax/parse:=20speed=20up=20free-ident?= =?UTF-8?q?ifier=3D=3F/phases=20when=20phases=20are=20same?= --- collects/syntax/parse/private/runtime.rkt | 38 +++++++++++++---------- 1 file changed, 21 insertions(+), 17 deletions(-) diff --git a/collects/syntax/parse/private/runtime.rkt b/collects/syntax/parse/private/runtime.rkt index d8beb8e6f0..07f8f02a9e 100644 --- a/collects/syntax/parse/private/runtime.rkt +++ b/collects/syntax/parse/private/runtime.rkt @@ -273,23 +273,27 @@ ;; that y has at phase-level y. ;; At least one of the identifiers MUST have a binding (module or lexical) (define (free-identifier=?/phases x phase-x y phase-y) - (let ([bx (identifier-binding x phase-x)] - [by (identifier-binding y phase-y)]) - (cond [(and (list? bx) (list? by)) - (let ([modx (module-path-index-resolve (first bx))] - [namex (second bx)] - [phasex (fifth bx)] - [mody (module-path-index-resolve (first by))] - [namey (second by)] - [phasey (fifth by)]) - (and (eq? modx mody) ;; resolved-module-paths are interned - (eq? namex namey) - (equal? phasex phasey)))] - [else - ;; Module is only way to get phase-shift; if not module-bound names, - ;; then only identifiers at same phase can refer to same binding. - (and (equal? phase-x phase-y) - (free-identifier=? x y phase-x))]))) + (cond [(eqv? phase-x phase-y) + (free-identifier=? x y phase-x)] + [else + (let ([bx (identifier-binding x phase-x)] + [by (identifier-binding y phase-y)]) + (cond [(and (pair? bx) (pair? by)) + (let ([mpix (first bx)] + [namex (second bx)] + [defphasex (fifth bx)] + [mpiy (first by)] + [namey (second by)] + [defphasey (fifth by)]) + (and (eq? namex namey) + ;; resolved-module-paths are interned + (eq? (module-path-index-resolve mpix) + (module-path-index-resolve mpiy)) + (eqv? defphasex defphasey)))] + [else + ;; Module is only way to get phase-shift; phases differ, so + ;; if not module-bound names, no way can refer to same binding. + #f]))])) ;; ---- From 3aa16f2c26dc05c278f268417c7beee6eea6eaa9 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Tue, 6 Sep 2011 04:28:11 -0600 Subject: [PATCH 186/235] syntax/parse: speed up "is literal bound?" check Can't do check completely statically, because phase of comparison is expression (and even default is slightly unpredictable). So instead compute whether check would succeed for likely phase offsets, and use list of ok offsets as run-time fast path (memv instead of identifier-binding). --- collects/syntax/parse/private/rep.rkt | 8 ++---- collects/syntax/parse/private/runtime.rkt | 31 ++++++++++++++++++----- 2 files changed, 27 insertions(+), 12 deletions(-) diff --git a/collects/syntax/parse/private/rep.rkt b/collects/syntax/parse/private/rep.rkt index 69f3417c50..c0af86edb1 100644 --- a/collects/syntax/parse/private/rep.rkt +++ b/collects/syntax/parse/private/rep.rkt @@ -2,8 +2,7 @@ (require (for-template racket/base racket/stxparam "keywords.rkt" - "runtime.rkt" - (only-in unstable/syntax phase-of-enclosing-module)) + "runtime.rkt") racket/contract/base "minimatch.rkt" syntax/id-table @@ -1301,10 +1300,7 @@ A syntax class is integrable if ;; check-literal-entry : stx stx -> (list id id ct-phase ct-phase) (define (check-literal-entry stx ctx) (define (go internal external phase) - (txlift #`(check-literal (quote-syntax #,external) - #,phase - (phase-of-enclosing-module) - (quote-syntax #,ctx))) + (txlift #`(check-literal #,external #,phase #,ctx)) (list internal external phase phase)) (syntax-case stx () [(internal external #:phase phase) diff --git a/collects/syntax/parse/private/runtime.rkt b/collects/syntax/parse/private/runtime.rkt index 07f8f02a9e..a71919d0e0 100644 --- a/collects/syntax/parse/private/runtime.rkt +++ b/collects/syntax/parse/private/runtime.rkt @@ -1,6 +1,7 @@ #lang racket/base (require racket/list racket/stxparam + unstable/syntax "runtime-progress.rkt" "runtime-failure.rkt" (for-syntax racket/base @@ -257,15 +258,33 @@ (provide check-literal free-identifier=?/phases) -;; check-literal : id phase-level phase-level stx -> void -;; FIXME: change to normal 'error', if src gets stripped away -(define (check-literal id abs-phase mod-phase ctx) - (unless (identifier-binding id abs-phase) +;; (check-literal id phase-level-expr ctx) -> void +(define-syntax (check-literal stx) + (syntax-case stx () + [(check-literal id used-phase-expr ctx) + (let* ([ok-phases/ct-rel + ;; id is bound at each of ok-phases/ct-rel + ;; (phase relative to the compilation of the module in which the + ;; 'syntax-parse' (or related) form occurs) + (filter (lambda (p) (identifier-binding #'id p)) '(0 1 -1 #f))]) + ;; so we can avoid run-time call to identifier-binding if + ;; (+ (phase-of-enclosing-module) ok-phase/ct-rel) = used-phase + (with-syntax ([ok-phases/ct-rel ok-phases/ct-rel]) + #'(check-literal* (quote-syntax id) + used-phase-expr + (phase-of-enclosing-module) + 'ok-phases/ct-rel + (quote-syntax ctx))))])) + +(define (check-literal* id used-phase mod-phase ok-phases/ct-rel ctx) + (unless (or (memv (and used-phase (- used-phase mod-phase)) + ok-phases/ct-rel) + (identifier-binding id used-phase)) (raise-syntax-error #f (format "literal is unbound in phase ~a (phase ~a relative to the enclosing module)" - abs-phase - (and abs-phase (- abs-phase mod-phase))) + used-phase + (and used-phase (- used-phase mod-phase))) ctx id))) ;; free-identifier=?/phases : id phase-level id phase-level -> boolean From a74ce9d7b283a37257d24413d51010e380696527 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Tue, 6 Sep 2011 14:08:44 -0400 Subject: [PATCH 187/235] fixed docs for check-member-of and check-range --- collects/test-engine/test-engine.scrbl | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/collects/test-engine/test-engine.scrbl b/collects/test-engine/test-engine.scrbl index fb4f9eca5b..4295ec3f1f 100644 --- a/collects/test-engine/test-engine.scrbl +++ b/collects/test-engine/test-engine.scrbl @@ -49,15 +49,16 @@ the error message matches the string, if it is present.} @defform[(check-member-of (test any/c) (expected any/c) ...)]{ -Accepts at least two value-producing expressions. Structurally compares the first -value to each value subsequent value specified. +Checks whether the value of the @racket[test] expression is structurally +equal to any of the values produced by the @racket[expected] expressions. -It is an error to produce a function value.} +It is an error for @racket[test] or any of the @racket[expected] expression +to produce a function value.} @defform[(check-range (test number/c) (min number/c) (max number/c))]{ -Accepts three number-producing expressions. Performs the following comparison: -min <= test <= max.} +Checks whether value of @racket[test] is between the values of the +@racket[min] and @racket[max] expressions [inclusive].} @defproc[(test) void?]{ From ac8b5a7d038666f525be2056cf9e6697f3aef967 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 6 Sep 2011 14:38:29 -0500 Subject: [PATCH 188/235] fix up the teachpack code to be friendly to the drracket test suites --- collects/lang/htdp-langs.rkt | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/collects/lang/htdp-langs.rkt b/collects/lang/htdp-langs.rkt index bf1973e3fe..5b01566eb2 100644 --- a/collects/lang/htdp-langs.rkt +++ b/collects/lang/htdp-langs.rkt @@ -591,7 +591,8 @@ (begin (message-box (string-constant drscheme) (format (string-constant already-added-teachpack) - (cadr teachpack))) + (cadr teachpack)) + #:dialog-mixin frame:focus-table-mixin) settings) (let ([new-tps (append old-tps (list teachpack))]) @@ -686,7 +687,7 @@ tp-dirs)) (define sort-order (λ (x y) (string<=? (path->string x) (path->string y)))) (define pre-installed-tpss (map (λ (tps) (sort tps sort-order)) tpss)) - (define dlg (new dialog% [parent parent] [label (string-constant drscheme)])) + (define dlg (new (frame:focus-table-mixin dialog%) [parent parent] [label (string-constant drscheme)])) (define hp (new horizontal-panel% [parent dlg])) (define answer #f) (define compiling? #f) From 5295e143a31168ac08cd65503f7be5dcf8332f08 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 6 Sep 2011 14:27:42 -0400 Subject: [PATCH 189/235] `scheme' -> `racket'. --- collects/profile/analyzer.rkt | 4 ++-- collects/profile/main.rkt | 4 ++-- collects/profile/render-graphviz.rkt | 2 +- collects/profile/render-text.rkt | 4 ++-- collects/profile/sampler.rkt | 2 +- collects/profile/structs.rkt | 2 +- collects/profile/utils.rkt | 4 ++-- 7 files changed, 11 insertions(+), 11 deletions(-) diff --git a/collects/profile/analyzer.rkt b/collects/profile/analyzer.rkt index e114c4e369..63880af623 100644 --- a/collects/profile/analyzer.rkt +++ b/collects/profile/analyzer.rkt @@ -1,10 +1,10 @@ -#lang scheme/base +#lang racket/base ;; Analyzer for the sampler results (provide analyze-samples) -(require "structs.rkt" "utils.rkt" scheme/list) +(require "structs.rkt" "utils.rkt" racket/list) (define-syntax-rule (with-hash ) (hash-ref! (lambda () ))) diff --git a/collects/profile/main.rkt b/collects/profile/main.rkt index af103813fb..be53d1b71e 100644 --- a/collects/profile/main.rkt +++ b/collects/profile/main.rkt @@ -1,10 +1,10 @@ -#lang scheme/base +#lang racket/base (provide profile-thunk profile) (require "sampler.rkt" "analyzer.rkt" (prefix-in text: "render-text.rkt") - (for-syntax scheme/base)) + (for-syntax racket/base)) (define (profile-thunk thunk #:delay [delay 0.05] diff --git a/collects/profile/render-graphviz.rkt b/collects/profile/render-graphviz.rkt index 1aba7cea6c..8e063dfa32 100644 --- a/collects/profile/render-graphviz.rkt +++ b/collects/profile/render-graphviz.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base (provide render) diff --git a/collects/profile/render-text.rkt b/collects/profile/render-text.rkt index a0952fcf0d..a6c6abe76d 100644 --- a/collects/profile/render-text.rkt +++ b/collects/profile/render-text.rkt @@ -1,8 +1,8 @@ -#lang at-exp scheme/base +#lang at-exp racket/base (provide render) -(require "structs.rkt" "analyzer.rkt" "utils.rkt" scheme/list) +(require "structs.rkt" "analyzer.rkt" "utils.rkt" racket/list) (define (f:msec msec) (number->string (round (inexact->exact msec)))) diff --git a/collects/profile/sampler.rkt b/collects/profile/sampler.rkt index 7529135373..9dadc6bfe2 100644 --- a/collects/profile/sampler.rkt +++ b/collects/profile/sampler.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base ;; The core profiler sample collector ;; (This module is a private tool for collecting profiling data, and should not diff --git a/collects/profile/structs.rkt b/collects/profile/structs.rkt index 9732e7c726..7ecbeffbfa 100644 --- a/collects/profile/structs.rkt +++ b/collects/profile/structs.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base ;; Struct definitions for the profiler diff --git a/collects/profile/utils.rkt b/collects/profile/utils.rkt index 7486ce3b30..8b9430eb15 100644 --- a/collects/profile/utils.rkt +++ b/collects/profile/utils.rkt @@ -1,6 +1,6 @@ -#lang scheme/base +#lang racket/base -(require "structs.rkt" scheme/list scheme/nest) +(require "structs.rkt" racket/list) ;; Format a percent number, possibly doing the division too. If we do the ;; division, then be careful: if we're dividing by zero, then make the result From eec994a899c5c2ba50f81812836a47f0e28607b4 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 6 Sep 2011 15:13:20 -0400 Subject: [PATCH 190/235] Reprovide the structs from "analyzer.rkt". (Also switch to `struct'.) --- collects/profile/analyzer.rkt | 4 ++-- collects/profile/main.rkt | 2 +- collects/profile/render-graphviz.rkt | 2 +- collects/profile/render-text.rkt | 2 +- collects/profile/structs.rkt | 11 +++++++---- 5 files changed, 12 insertions(+), 9 deletions(-) diff --git a/collects/profile/analyzer.rkt b/collects/profile/analyzer.rkt index 63880af623..22981574c8 100644 --- a/collects/profile/analyzer.rkt +++ b/collects/profile/analyzer.rkt @@ -2,10 +2,10 @@ ;; Analyzer for the sampler results -(provide analyze-samples) - (require "structs.rkt" "utils.rkt" racket/list) +(provide analyze-samples (all-from-out "structs.rkt")) + (define-syntax-rule (with-hash ) (hash-ref! (lambda () ))) diff --git a/collects/profile/main.rkt b/collects/profile/main.rkt index be53d1b71e..9827f42670 100644 --- a/collects/profile/main.rkt +++ b/collects/profile/main.rkt @@ -2,7 +2,7 @@ (provide profile-thunk profile) -(require "sampler.rkt" "analyzer.rkt" +(require "sampler.rkt" (except-in "analyzer.rkt" profile) (prefix-in text: "render-text.rkt") (for-syntax racket/base)) diff --git a/collects/profile/render-graphviz.rkt b/collects/profile/render-graphviz.rkt index 8e063dfa32..0c23a534a2 100644 --- a/collects/profile/render-graphviz.rkt +++ b/collects/profile/render-graphviz.rkt @@ -2,7 +2,7 @@ (provide render) -(require "structs.rkt" "analyzer.rkt" "utils.rkt") +(require "analyzer.rkt" "utils.rkt") (define (render profile #:hide-self [hide-self% 1/100] diff --git a/collects/profile/render-text.rkt b/collects/profile/render-text.rkt index a6c6abe76d..61f21f31d4 100644 --- a/collects/profile/render-text.rkt +++ b/collects/profile/render-text.rkt @@ -2,7 +2,7 @@ (provide render) -(require "structs.rkt" "analyzer.rkt" "utils.rkt" racket/list) +(require "analyzer.rkt" "utils.rkt" racket/list) (define (f:msec msec) (number->string (round (inexact->exact msec)))) diff --git a/collects/profile/structs.rkt b/collects/profile/structs.rkt index 7ecbeffbfa..49cea4dc46 100644 --- a/collects/profile/structs.rkt +++ b/collects/profile/structs.rkt @@ -14,8 +14,9 @@ ;; identifiable by having both id and src fields being #f. Can be used to ;; start a graph traversal from the top or the bottom. (provide (struct-out profile)) -(define-struct profile - (total-time cpu-time sample-number thread-times nodes *-node)) +(struct profile + (total-time cpu-time sample-number thread-times nodes *-node) + #:constructor-name make-profile) ;; An entry for a single profiled function: ;; - id, src: the corresponding values from `continuation-mark-set->context'. @@ -36,7 +37,8 @@ #:property prop:custom-write (lambda (node o w?) (fprintf o "#" - (or (node-id node) (if (node-src node) '??? 'ROOT))))) + (or (node-id node) (if (node-src node) '??? 'ROOT)))) + #:constructor-name make-node) ;; An edge representing function calls between two nodes: ;; - total: the total time spent while the call was anywhere on the stack. @@ -52,4 +54,5 @@ (lambda (edge o w?) (fprintf o "#" (or (node-id (edge-caller edge)) '???) - (or (node-id (edge-callee edge)) '???)))) + (or (node-id (edge-callee edge)) '???))) + #:constructor-name make-edge) From bfc9a2ba766c199f5cb5b285702af8122f3bcc64 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 6 Sep 2011 16:32:06 -0400 Subject: [PATCH 191/235] Switch to `make-'-less constructors. --- collects/profile/analyzer.rkt | 19 +++++++++---------- collects/profile/structs.rkt | 9 +++------ 2 files changed, 12 insertions(+), 16 deletions(-) diff --git a/collects/profile/analyzer.rkt b/collects/profile/analyzer.rkt index 22981574c8..82ad451cdd 100644 --- a/collects/profile/analyzer.rkt +++ b/collects/profile/analyzer.rkt @@ -25,14 +25,14 @@ (define id+src->node-hash (make-hasheq)) (define (id+src->node id+src) (with-hash id+src->node-hash id+src - (make-node (car id+src) (cdr id+src) '() 0 0 '() '()))) + (node (car id+src) (cdr id+src) '() 0 0 '() '()))) ;; special node that is the caller of toplevels and callee of leaves (define *-node (id+src->node '(#f . #f))) (define call->edge (let ([t (make-hasheq)]) (lambda (ler lee) (with-hash (with-hash t ler (make-hasheq)) lee - (let ([e (make-edge 0 ler 0 lee 0)]) + (let ([e (edge 0 ler 0 lee 0)]) (set-node-callers! lee (cons e (node-callers lee))) (set-node-callees! ler (cons e (node-callees ler))) e))))) @@ -84,14 +84,13 @@ (for ([n (in-list nodes)]) (set-node-callees! n (sort (node-callees n) > #:key edge-callee-time)) (set-node-callers! n (sort (node-callers n) > #:key edge-caller-time))) - (make-profile - total-time - cpu-time - (length samples) - (for/list ([time (in-vector thread-times)] [n (in-naturals 0)]) - (cons n time)) - nodes - *-node))) + (profile total-time + cpu-time + (length samples) + (for/list ([time (in-vector thread-times)] [n (in-naturals 0)]) + (cons n time)) + nodes + *-node))) ;; Groups raw samples by their thread-id, returns a vector with a field for ;; each thread id holding the sample data for that thread. The samples in diff --git a/collects/profile/structs.rkt b/collects/profile/structs.rkt index 49cea4dc46..1f6a513bd6 100644 --- a/collects/profile/structs.rkt +++ b/collects/profile/structs.rkt @@ -15,8 +15,7 @@ ;; start a graph traversal from the top or the bottom. (provide (struct-out profile)) (struct profile - (total-time cpu-time sample-number thread-times nodes *-node) - #:constructor-name make-profile) + (total-time cpu-time sample-number thread-times nodes *-node)) ;; An entry for a single profiled function: ;; - id, src: the corresponding values from `continuation-mark-set->context'. @@ -37,8 +36,7 @@ #:property prop:custom-write (lambda (node o w?) (fprintf o "#" - (or (node-id node) (if (node-src node) '??? 'ROOT)))) - #:constructor-name make-node) + (or (node-id node) (if (node-src node) '??? 'ROOT))))) ;; An edge representing function calls between two nodes: ;; - total: the total time spent while the call was anywhere on the stack. @@ -54,5 +52,4 @@ (lambda (edge o w?) (fprintf o "#" (or (node-id (edge-caller edge)) '???) - (or (node-id (edge-callee edge)) '???))) - #:constructor-name make-edge) + (or (node-id (edge-callee edge)) '???)))) From 3cc51f20ac787c87b3d337d96e2afa0eecd5452d Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 6 Sep 2011 16:32:20 -0400 Subject: [PATCH 192/235] Update and revise docs. --- collects/profile/scribblings/analyzer.scrbl | 115 ++++++++++--------- collects/profile/scribblings/profile.scrbl | 12 +- collects/profile/scribblings/renderers.scrbl | 31 +++-- collects/profile/scribblings/sampler.scrbl | 32 +++--- collects/profile/scribblings/toplevel.scrbl | 86 +++++++------- 5 files changed, 139 insertions(+), 137 deletions(-) diff --git a/collects/profile/scribblings/analyzer.scrbl b/collects/profile/scribblings/analyzer.scrbl index 418458a250..1a22a7d54a 100644 --- a/collects/profile/scribblings/analyzer.scrbl +++ b/collects/profile/scribblings/analyzer.scrbl @@ -1,45 +1,45 @@ #lang scribble/doc @(require scribble/manual - (for-label scheme profile/analyzer)) + (for-label racket/base profile/analyzer)) @title[#:tag "analyzer"]{Analyzing Profile Data} @defmodule[profile/analyzer] -Once a profile run is done, and the results are collected, the next -step is to analyze the data. In this step the sample time are -computed and summed, a call-graph representing the observed function -calls is built, and per-node and per-edge information is created. -This is the job of the main function provided by -@racket[profile/analyzer]. +Once a profile run is done and the results are collected, the next +step is to analyze the data. In this step sample times are computed +and summed, a call-graph representing observed function calls is +built, and per-node and per-edge information is created. This is the +job of the main function provided by @racket[profile/analyzer]. @defproc[(analyze-samples [raw-sample-data any/c]) profile?]{ This function consumes the raw result of the -@seclink["sampler"]{sampler} (which is given in an undocumented form), -analyzes it, and returns a @racket[profile] value holding the analyzed -results. Without this function, the results of the sampler are +@seclink["sampler"]{sampler} (given in an undocumented form), analyzes +it, and returns a @racket[profile] value holding the analyzed results. +Without this function, the results of the sampler should be considered meaningless.} -@defstruct[profile ([total-time exact-nonnegative-integer?] - [cpu-time exact-nonnegative-integer?] - [sample-number exact-nonnegative-integer?] - [thread-times (listof (cons exact-nonnegative-integer? - exact-nonnegative-integer?))] - [nodes (listof node?)] - [*-node node?])]{ +@defstruct*[profile ([total-time exact-nonnegative-integer?] + [cpu-time exact-nonnegative-integer?] + [sample-number exact-nonnegative-integer?] + [thread-times (listof (cons exact-nonnegative-integer? + exact-nonnegative-integer?))] + [nodes (listof node?)] + [*-node node?])]{ -Represents the analyzed profile result. +Represents an analyzed profile result. @itemize[ @item{@racket[total-time] is the total observed time (in milliseconds) - included in the profile. This is different than the actual time the - profiling took, due to unaccounted-for time spent in untracked - threads. (E.g., the sampler thread itself.)} + included in the profile run. This can be different from the actual + time the profiling took, due to unaccounted-for time spent in + untracked threads. (E.g., time spent in the sampler thread + itself.)} @item{@racket[cpu-time] is the actual cpu time consumed by the process during the profiler's work.} @@ -61,69 +61,70 @@ Represents the analyzed profile result. amount of time (time spent either in the function or in its callees) as a secondary key.} -@item{@racket[*-node] holds a ``special'' node value that is - constructed for every graph. This node is used as the caller for - all top-level function nodes and as the callee for all leaf nodes. - It can therefore be used to start a scan of the call graph. In - addition, the times associated with its "callers and callees" - actually represent the time these functions spent being the root of - the computation or its leaf. (This can be different from a node's - ``self'' time, since it is divided by the number of instances a - function had on the stack for every sample --- so for recursive - functions this value is different from.)} +@item{@racket[*-node] holds a ``special'' root node value that is + constructed for every call graph. This node is used as the caller + for all top-level function nodes and as the callee for all leaf + nodes. It can therefore be used to start a recursive scan of the + call graph. In addition, the times associated with its ``callers'' + and ``callees'' actually represent the time these functions spent + being the root of the computation or its leaf. (This can be + different from a node's ``self'' time, since it is divided by the + number of instances a function had on the stack in each sample---so + for recursive functions this value is always different from the + ``self'' time.)} ]} -@defstruct[node ([id (or/c #f symbol?)] - [src (or/c #f srcloc?)] - [thread-ids (listof exact-nonnegative-integer?)] - [total exact-nonnegative-integer?] - [self exact-nonnegative-integer?] - [callers (listof edge?)] - [callees (listof edge?)])]{ +@defstruct*[node ([id (or/c #f symbol?)] + [src (or/c #f srcloc?)] + [thread-ids (listof exact-nonnegative-integer?)] + [total exact-nonnegative-integer?] + [self exact-nonnegative-integer?] + [callers (listof edge?)] + [callees (listof edge?)])]{ Represents a function call node in the call graph of an analyzed profile result. @itemize[ -@item{The @racket[id] and @racket[src] field hold a symbol naming the +@item{The @racket[id] and @racket[src] fields hold a symbol naming the function and/or its source location as a @racket[srcloc] value. This is the same as the results of - @racket[continuation-mark-set->context], so at most of of these can + @racket[continuation-mark-set->context], so at most one of these can be @racket[#f], except for the special @racket[*-node] (see the - @racket[profile] struct) that can be identified by both of these - being @racket[#f].} + @racket[profile] struct) that can be identified by both being + @racket[#f].} @item{@racket[thread-ids] holds a list of thread identifiers that were observed executing this function.} -@item{@racket[total] holds the total time (in milliseconds) where this +@item{@racket[total] holds the total time (in milliseconds) that this function was anywhere on the stack. It is common to see a few toplevel functions that have close to a 100% total time, but - otherwise small @racket[self] times --- these functions are the ones - that derive the work that was done, but they don't do any hard work + otherwise small @racket[self] times---these functions are the ones + that initiate the actual work, but they don't do any hard work directly.} -@item{@racket[self] holds the total time (in milliseconds) where this +@item{@racket[self] holds the total time (in milliseconds) that this function was observed as the leaf of the stack. It represents the - actual work done by this function, rather than @racket[total] that - represents the work done by both the function and its callees.} + actual work done by this function, rather than the @racket[total] + time spent by both the function and its callees.} -@item{@racket[callers] and @racket[callees] hold the list of caller - and callee nodes. The nodes are not actually held in these lists, - instead, @racket[edge] values are used --- and provide information - specific to an edge in the call-graph.} +@item{@racket[callers] and @racket[callees] hold the list of callers + and callees. The nodes are not actually held in these lists, + instead, @racket[edge] values are used---and provide information + specific to each edge in the call-graph.} ]} -@defstruct[edge ([total exact-nonnegative-integer?] - [caller node?] - [caller-time exact-nonnegative-integer?] - [callee node?] - [callee-time exact-nonnegative-integer?])]{ +@defstruct*[edge ([total exact-nonnegative-integer?] + [caller node?] + [caller-time exact-nonnegative-integer?] + [callee node?] + [callee-time exact-nonnegative-integer?])]{ Represents an edge between two function call nodes in the call graph of an analyzed profile result. diff --git a/collects/profile/scribblings/profile.scrbl b/collects/profile/scribblings/profile.scrbl index ba8a4949be..e07a7b449a 100644 --- a/collects/profile/scribblings/profile.scrbl +++ b/collects/profile/scribblings/profile.scrbl @@ -1,15 +1,15 @@ #lang scribble/doc @(require scribble/manual - (for-label scheme)) + (for-label racket/base)) @title{Profile: Statistical Profiler} -The @racket[profile] collection implements a statistical profiler. -The profiling is done by running a background thread that collects -stack snapshots via @racket[continuation-mark-set->context], meaning -that the result is an estimate of the execution costs and it is -limited to the kind of information that +The @racketmodname[profile] collection implements a statistical +profiler. The profiling is done by running a background thread that +collects stack snapshots via @racket[continuation-mark-set->context], +meaning that the result is an estimate of the execution costs and it +is limited to the kind of information that @racket[continuation-mark-set->context] produces (most notably being limited to functions calls, and subject to compiler optimizations); but the result is often useful. In practice, since this method does diff --git a/collects/profile/scribblings/renderers.scrbl b/collects/profile/scribblings/renderers.scrbl index 8486b58a6f..641b64bb9f 100644 --- a/collects/profile/scribblings/renderers.scrbl +++ b/collects/profile/scribblings/renderers.scrbl @@ -1,7 +1,7 @@ #lang scribble/doc @(require scribble/manual - (for-label scheme + (for-label racket/base profile/analyzer (prefix-in text: profile/render-text) (prefix-in graphviz: profile/render-graphviz))) @@ -9,11 +9,11 @@ @title[#:tag "renderers"]{Profile Renderers} After collecting the profile samples and analyzing the data, the last -aspect of profiling is to render the results. The profile collection -provides several renderers, each providing a rendering function that -consumes a @racket[profile] instance. See the +step of the profiling process is to render the results. The profile +collection provides several renderers, each providing a rendering +function that consumes a @racket[profile] instance. See the @seclink["analyzer"]{analyzer} section for a description of the -@racket[profile] struct if you want to implement your own renderer. +@racket[profile] struct if you want to implement a new renderer. @;-------------------------------------------------------------------- @section{Textual Rendering} @@ -29,7 +29,7 @@ consumes a @racket[profile] instance. See the Prints the given @racket[profile] results as a textual table. -The printout begins with some general facts about the profile, and +The printout begins with some general details about the profile, and then a table that represents the call-graph is printed. Each row in this table looks like: @@ -38,17 +38,17 @@ this table looks like: [N1] N2(N3%) N4(N5%) A ...path/to/source.rkt:12:34 C [M3] M4%} -Where actual numbers appear in the printout. The meaning of the +where actual numbers appear in the printout. The meaning of the numbers and labels is as follows: @itemize[ @item{@tt{A} --- the name of the function that this node represents, followed by the source location for the function if it is known. - The name can be ``???'' for functions with no identifier, but in - this case the source location will identify them.} + The name can be ``???'' for anonymous functions, but in this case + the source location will identify them.} @item{@tt{N1} --- an index number associated with this node. This is - important in references to this function, since the symbolic names - are not unique (and some can be missing). The number itself has no - significance, it simply goes from 1 up.} + useful in references to this function, since the symbolic names are + not unique (and some can be missing). The number itself has no + significance.} @item{@tt{N2} --- the time (in milliseconds) that this function has been anywhere in a stack snapshot. This is the total time that the execution was somewhere in this function or in its callees. @@ -59,13 +59,12 @@ numbers and labels is as follows: whole execution.} @item{@tt{N4} --- the time (in milliseconds) that this function has been at the top of the stack snapshot. This is the time that this - function consumed doing work itself rather than calling other - functions. (Corresponds to the @racket[node-self] field.)} + function was itself doing work rather than calling other functions. + (Corresponds to the @racket[node-self] field.)} @item{@tt{N5} --- this is the percentage of @tt{N4} out of the total observed time of the profile. Functions with high values here can be good candidates for optimization, But, of course, they can - represent doing real work due to one of its callers that need to be - optimized.} + represent doing real work for a caller that needs to be optimized.} @item{@tt{B} and @tt{C} --- these are labels for the callers and callees of the function. Any number of callers and callees can appear here (including 0). The function itself can also appear in diff --git a/collects/profile/scribblings/sampler.scrbl b/collects/profile/scribblings/sampler.scrbl index f6d15307c2..908521ce7c 100644 --- a/collects/profile/scribblings/sampler.scrbl +++ b/collects/profile/scribblings/sampler.scrbl @@ -1,7 +1,7 @@ #lang scribble/doc @(require scribble/manual - (for-label scheme profile/sampler profile/analyzer)) + (for-label racket/base profile/sampler profile/analyzer)) @title[#:tag "sampler"]{Collecting Profile Information} @@ -13,7 +13,7 @@ [super-cust custodian? (current-custodian)]) ((symbol?) (any/c) . ->* . any/c)]{ -Creates a sample collector thread, which tracks the given +Creates a stack-snapshot collector thread, which tracks the given @racket[to-track] value every @racket[delay] seconds. The @racket[to-track] value can be either a thread (track just that thread), a custodian (track all threads managed by the custodian), or @@ -26,33 +26,33 @@ consisting of a symbol and an optional argument, and can affect the sampler. The following messages are currently supported: @itemize[ -@item{@racket['pause] and @racket['resume] will stop or resume data -collection. These messages can be nested. Note that the thread will -continue running it will just stop collecting snapshots.} +@item{@racket['pause] and @racket['resume] will stop or resume + snapshot collection. These messages can be nested. Note that the + thread will continue running---it will just stop collecting + snapshots.} -@item{@racket['stop] kills the controlled thread. It should be called +@item{@racket['stop] kills the sampler thread. It should be called when no additional data should be collected. (This is currently irreversible: there is no message to start a new sampler thread.)} @item{@racket['set-tracked!] with a value will change the tracked - objects (initially specified as the @racket[to-track] argument) to - the given value.} + object(s) which were initially specified as the @racket[to-track] + argument.} -@item{@racket['set-tracked!] with a value will change the delay that - the sampler us taking between snapshots. Note that although - changing this means that the snapshots are not uniformly - distributed, the results will still be sensible --- this is because - the cpu time between samples is taken into account when the - resulting data is analyzed.} +@item{@racket['set-tracked!] with a numeric value will change the + delay that the sampler is taking between snapshots. Note that + although changing this means that the snapshots are not uniformly + distributed, the results will still be correct: the cpu time between + samples is taken into account when the collected data is analyzed.} @item{Finally, a @racket['get-snapshots] message will make the controller return the currently collected data. Note that this can - be called multiple times, each call will return the data thatis + be called multiple times, each call will return the data that is collected up to that point in time. In addition, it can be (and usually is) called after the sampler was stopped. The value that is returned should be considered as an undocumented - internal detail of the profiler, to be sent to + internal detail of the profiler, intended to be sent to @racket[analyze-samples] for analysis. The reason this is not done automatically, is that a future extension might allow you to combine several sampler results, making it possible to combine a profile diff --git a/collects/profile/scribblings/toplevel.scrbl b/collects/profile/scribblings/toplevel.scrbl index de0ebe5d7f..be663a796b 100644 --- a/collects/profile/scribblings/toplevel.scrbl +++ b/collects/profile/scribblings/toplevel.scrbl @@ -1,8 +1,8 @@ #lang scribble/doc @(require scribble/manual - (for-label scheme profile profile/sampler - (only-in profile/analyzer analyze-samples) + (for-label racket/base profile profile/sampler + (only-in profile/analyzer analyze-samples profile?) (prefix-in text: profile/render-text))) @title{Toplevel Interface} @@ -10,7 +10,7 @@ @defmodule[profile] This module provides one procedure and one macro that are convenient -high-level entry points for timing expressions. This hides the +high-level entry points for profiling expressions. It abstracts over details that are available through other parts of the library, and is intended as a convenient tool for profiling code. @@ -25,53 +25,55 @@ intended as a convenient tool for profiling code. #f]) void?]{ -Executes the given thunk while collecting profiling data, and render -this data when done. Keyword arguments can customize the profiling: +Executes the given @racket[thunk] and collect profiling data during +execution, eventually analyzing and rendering this. Keyword arguments +can customize the profiling: @itemize[ -@item{The profiler works by @racket[create-sampler] starting a - ``sampler'' thread whose job is to collect stack samples - periodically (using @racket[continuation-mark-set->context]). - @racket[delay] determines the amount of time the sampler - @racket[sleep]s for between samples. Note that this is will be - close, but not identical to, the frequency in which data is actually - sampled.} +@item{The profiler works by starting a ``sampler'' thread to + periodically collect stack snapshots (using + @racket[continuation-mark-set->context]). To determine the + frequency of these collections, the sampler thread sleeps + @racket[delay] seconds between collections. Note that this is will + be close, but not identical to, the frequency in which data is + actually sampled. (The @racket[delay] value is passed on to + @racket[create-sampler], which creates the sampler thread.)} -@item{When the profiled computation takes a short amount of time, the - collected data will not be accurate. In this case, you can specify - an @racket[iterations] argument to repeat the evaluation a number of - times which will improve the accuracy of the resulting report.} +@item{Due to the statistical nature of the profiler, longer executions + result in more accurate analysis. You can specify a number of + @racket[iterations] to repeat the @racket[thunk] to collect more + data.} -@item{Normally, the sampler collects snapshots of the - @racket[current-thread]'s stack. If there is some computation that - happens on a different thread, that work will not be reflected in - the results: the only effect will be suspiciously small value for - the observed time, because the collected data is taking into account - the cpu time that the thread actually performed (it uses - @racket[current-process-milliseconds] with the running thread as an - argument). Specifying a non-@racket[#f] value for the - @racket[threads?] argument will arrange for all threads that are - started during the evaluation to be tracked. Note that this means - that the computation will actually run in a new sub-custodian, as - this is the only way to be able to track such threads.} +@item{Normally, the sampler collects only snapshots of the + @racket[current-thread]'s stack. Profiling a computation that + creates threads will therefore lead to bad analysis: the timing + results will be correct, but because the profiler is unaware of + other threads the observed time will be suspiciously small, and work + done in other threads will not be included in the results. To track + all threads, specify a non-@racket[#f] value for the + @racket[threads?] argument---this will execute the computation in a + fresh custodian, and keep track of all threads under this + custodian.} -@item{Once the computation has finished, the sampler is stopped, and - the accumulated data is collected. It is then analyzed by - @racket[analyze-samples], and the analyzed profile data is fed into - a renderer. Use an identity function (@racket[values]) to get the - analyzed result, and render it yourself, or use one of the existing - renderers (see @secref["renderers"]).} +@item{Once the computation is done and the sampler is stopped, the + accumulated data is analyzed (by @racket[analyze-samples]) and the + resulting profile value is sent to the @racket[renderer] function. + See @secref["renderers"] for available renderers. You can also use + @racket[values] as a ``renderer''---in this case the + @racket[profile-thunk] returns the analyzed information which can + now be rendered multiple times, or saved for future rendering.} -@item{The @racket[periodic-renderer] argument can be set to a list - holding a delay time and a renderer. In this case, the given - renderer will be called periodically. This is useful for cases - where you want a dynamically updated display of the results. This - delay should be larger than the sampler delay.} +@item{To provide feedback information during execution, specify a + @racket[periodic-renderer]. This should be a list holding a delay + time (in seconds) and a renderer function. The delay determines the + frequency in which the renderer is called, and it should be larger + than the sampler delay (usually much larger since it can involve + more noticeable overhead, and it is intended for a human observer).} ]} @defform[(profile expr keyword-arguments ...)]{ -A macro version of @racket[profile-thunk]. The keyword arguments can -be specified in the same was as for a function call: they can appear -before and/or after the expression to be profiled.} +A macro version of @racket[profile-thunk]. Keyword arguments can be +specified as in a function call: they can appear before and/or after +the expression to be profiled.} From c893502857d2484540e8ba7bde72e101d23fb22c Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 2 Sep 2011 16:12:44 -0400 Subject: [PATCH 193/235] Forge identifiers instead of dumpster-diving. --- .../base-env/base-special-env.rkt | 142 ++++++------------ 1 file changed, 43 insertions(+), 99 deletions(-) diff --git a/collects/typed-racket/base-env/base-special-env.rkt b/collects/typed-racket/base-env/base-special-env.rkt index cc2e1e30c8..9b3e034fea 100644 --- a/collects/typed-racket/base-env/base-special-env.rkt +++ b/collects/typed-racket/base-env/base-special-env.rkt @@ -7,7 +7,7 @@ string-constants/string-constant racket/private/kw racket/file racket/port syntax/parse racket/path (for-template (only-in racket/private/kw kw-expander-proc kw-expander-impl) - racket/base racket/promise racket/file racket/port racket/path string-constants/string-constant) + racket/base racket/file racket/port racket/path) (utils tc-utils) (env init-envs) (except-in (rep filter-rep object-rep type-rep) make-arr) @@ -20,36 +20,39 @@ [(_ initialize-env [id-expr ty] ... #:middle [id-expr* ty*] ...) #`(begin (define initial-env (make-env [id-expr (λ () ty)] ... )) - (do-time "finished local-expand types") + (do-time "finished special types") (define initial-env* (make-env [id-expr* (λ () ty*)] ...)) (define (initialize-env) (initialize-type-env initial-env) (initialize-type-env initial-env*)) (provide initialize-env))])) +(define (make-template-identifier what where) + (let ([name (module-path-index-resolve (module-path-index-join where #f))]) + (parameterize ([current-namespace (make-empty-namespace)]) + (namespace-attach-module (current-namespace) ''#%kernel) + (parameterize ([current-module-declare-name name]) + (eval `(,#'module any '#%kernel + (#%provide ,what) + (define-values (,what) #f)))) + (namespace-require `(for-template ,name)) + (namespace-syntax-introduce (datum->syntax #f what))))) + + (define-initial-env initialize-special ;; make-promise - [(syntax-parse (local-expand #'(delay 3) 'expression null) - #:context #'make-promise - [(_ mp . _) #'mp]) + [(make-template-identifier 'delay 'racket/private/promise) (-poly (a) (-> (-> a) (-Promise a)))] ;; language - [(syntax-parse (local-expand #'(this-language) 'expression null) - #:context #'language - [lang #'lang]) + [(make-template-identifier 'language 'string-constants/string-constant) -Symbol] ;; qq-append - [(syntax-parse (local-expand #'`(,@'() 1) 'expression null) - #:context #'qq-append - [(_ qqa . _) #'qqa]) - (-poly (a b) - (cl->* - (-> (-lst a) (-val '()) (-lst a)) - (-> (-lst a) (-lst b) (-lst (*Un a b)))))] + [(make-template-identifier 'qq-append 'racket/private/qq-and-or) + (-poly (a b) + (cl->* + (-> (-lst a) (-val '()) (-lst a)) + (-> (-lst a) (-lst b) (-lst (*Un a b)))))] ;; make-sequence - [(syntax-parse (local-expand #'(for ([x '()]) x) 'expression #f) - #:context #'make-sequence - #:literals (let-values quote) - [(let-values ([_ (m-s '(_) '())]) . _) #'m-s]) + [(make-template-identifier 'make-sequence 'racket/private/for) (-poly (a b) (let ([seq-vals (lambda (a) @@ -64,9 +67,7 @@ (-> Univ (-seq a) (seq-vals (list a))) (-> Univ (-seq a b) (seq-vals (list a b))))))] ;; in-range - [(syntax-parse (local-expand #'(in-range 1) 'expression #f) - [(i-n _ ...) - #'i-n]) + [(make-template-identifier 'in-range 'racket/private/for) (cl->* (-PosFixnum -Fixnum [-Nat] . ->opt . (-seq -PosFixnum)) (-NonNegFixnum [-Fixnum -Nat] . ->opt . (-seq -NonNegFixnum)) (-Fixnum [-Fixnum -Int] . ->opt . (-seq -Fixnum)) @@ -74,118 +75,61 @@ (-Nat [-Int -Nat] . ->opt . (-seq -Nat)) (-Int [-Int -Int] . ->opt . (-seq -Int)))] ;; in-naturals - [(syntax-parse (local-expand #'(in-naturals) 'expression #f) - [(i-n _ ...) - #'i-n]) + [(make-template-identifier 'in-naturals 'racket/private/for) (cl->* (-> -PosInt (-seq -PosInt)) (-> -Int (-seq -Nat)))] ;; in-list - [(syntax-parse (local-expand #'(in-list '(1 2 3)) 'expression #f) - [(i-n _ ...) - #'i-n]) + [(make-template-identifier 'in-list 'racket/private/for) (-poly (a) (-> (-lst a) (-seq a)))] ;; in-vector - [(syntax-parse (local-expand #'(in-vector (vector 1 2 3)) 'expression #f) - [(i-n _ ...) - #'i-n]) + [(make-template-identifier 'in-vector 'racket/private/for) (-poly (a) (->opt (-vec a) [-Int (-opt -Int) -Int] (-seq a)))] ;; in-string - [(syntax-parse (local-expand #'(in-string "abc") 'expression #f) - [(i-n _ ...) - #'i-n]) + [(make-template-identifier 'in-string 'racket/private/for) (->opt -String [-Int (-opt -Int) -Int] (-seq -Char))] ;; in-bytes - [(syntax-parse (local-expand #'(in-bytes #"abc") 'expression #f) - [(i-n _ ...) - #'i-n]) + [(make-template-identifier 'in-bytes 'racket/private/for) (->opt -Bytes [-Int (-opt -Int) -Int] (-seq -Byte))] ;; in-hash and friends - [(syntax-parse (local-expand #'(in-hash #hash((1 . 2))) 'expression #f) - [(i-n _ ...) - #'i-n]) + [(make-template-identifier 'in-hash 'racket/private/for) (-poly (a b) (-> (-HT a b) (-seq a b)))] - [(syntax-parse (local-expand #'(in-hash-keys #hash((1 . 2))) 'expression #f) - [(i-n _ ...) - #'i-n]) + [(make-template-identifier 'in-hash-keys 'racket/private/for) (-poly (a b) (-> (-HT a b) (-seq a)))] - [(syntax-parse (local-expand #'(in-hash-values #hash((1 . 2))) 'expression #f) - [(i-n _ ...) - #'i-n]) + [(make-template-identifier 'in-hash-values 'racket/private/for) (-poly (a b) (-> (-HT a b) (-seq b)))] ;; in-port - [(syntax-parse (local-expand #'(in-port) 'expression #f) - [(i-n _ ...) - #'i-n]) + [(make-template-identifier 'in-port 'racket/private/for) (->opt [(-> -Input-Port Univ) -Input-Port] (-seq Univ))] ;; in-input-port-bytes - [(syntax-parse (local-expand #'(in-input-port-bytes (open-input-bytes #"abc")) 'expression #f) - [(i-n _ ...) - #'i-n]) + [(make-template-identifier 'in-input-port-bytes 'racket/private/for) (-> -Input-Port (-seq -Byte))] ;; in-input-port-chars - [(syntax-parse (local-expand #'(in-input-port-chars (open-input-string "abc")) 'expression #f) - [(i-n _ ...) - #'i-n]) + [(make-template-identifier 'in-input-port-chars 'racket/private/for) (-> -Input-Port (-seq -Char))] ;; in-lines - [(syntax-parse (local-expand #'(in-lines) 'expression #f) - [(i-n _ ...) - #'i-n]) + [(make-template-identifier 'in-lines 'racket/private/for) (->opt [-Input-Port -Symbol] (-seq -String))] ;; in-bytes-lines - [(syntax-parse (local-expand #'(in-bytes-lines) 'expression #f) - [(i-n _ ...) - #'i-n]) + [(make-template-identifier 'in-bytes-lines 'racket/private/for) (->opt [-Input-Port -Symbol] (-seq -Bytes))] ;; check-in-bytes-lines - [(syntax-parse (local-expand #'(for ([i (in-bytes-lines 0)]) i) - 'expression #f) - #:literals (let-values let) - [(let-values ((_ (let _ (c . _) . _)) - . _) - . _) - #'c]) + [(make-template-identifier 'check-in-bytes-lines 'racket/private/for) (-> Univ Univ Univ)] ;; check-in-lines - [(syntax-parse (local-expand #'(for ([i (in-lines 0)]) i) - 'expression #f) - #:literals (let-values #%app let) - [(let-values ((_ (let _ (c . _) . _)) - . _) - . _) - #'c]) + [(make-template-identifier 'check-in-lines 'racket/private/for) (-> Univ Univ Univ)] ;; check-in-port - [(syntax-parse (local-expand #'(for ([i (in-port 0)]) i) - 'expression #f) - #:literals (let-values #%app let) - [(let-values ((_ (let _ (c . _) . _)) - . _) - . _) - #'c]) + [(make-template-identifier 'check-in-port 'racket/private/for) (-> Univ Univ Univ)] ;; from the expansion of `with-syntax' - [(syntax-parse (local-expand #'(with-syntax ([x 1]) #'(x)) 'expression null) - #:literals (let-values #%plain-app #%plain-lambda if letrec-syntaxes+values) - [(let-values _ - (let-values _ - (let-values _ - (if _ - (let-values _ (letrec-syntaxes+values _ _ (#%plain-app (#%plain-lambda _ (#%plain-app apply-pattern-substitute _ _ _)) _))) - _)))) - #'apply-pattern-substitute]) + [(make-template-identifier 'apply-pattern-substitute 'racket/private/stxcase) (->* (list (-Syntax Univ) Univ) Univ Any-Syntax)] - - [(syntax-parse (local-expand #'(with-syntax ([x 1]) #'(x)) 'expression null) - #:literals (let-values #%plain-app #%plain-lambda if letrec-syntaxes+values) - [(let-values _ (let-values _ - (let-values _ (if _ _ (let-values _ - (if _ (let-values _ (letrec-syntaxes+values _ _ (#%plain-app with-syntax-fail _))) _)))))) - #'with-syntax-fail]) + ;; same + [(make-template-identifier 'with-syntax-fail 'racket/private/with-stx) (-> (-Syntax Univ) (Un))] - [(local-expand #'make-temporary-file 'expression #f) + [(make-template-identifier 'make-temporary-file/proc 'racket/file) (->opt [-String (Un -Pathlike (-val 'directory) (-val #f)) (-opt -Pathlike)] -Path)] ;; below here: keyword-argument functions from the base environment From 371fcba252ca2ea2a4389e1a9273436253e62be4 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 6 Sep 2011 13:38:57 -0400 Subject: [PATCH 194/235] here-figures shouldn't be on a page of their own. --- collects/scriblib/figure.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scriblib/figure.tex b/collects/scriblib/figure.tex index 54a393c56a..4606cd5601 100644 --- a/collects/scriblib/figure.tex +++ b/collects/scriblib/figure.tex @@ -19,6 +19,6 @@ \newenvironment{CenterfigureMulti}{\begin{figure*}[t!p]\centering}{\end{figure*}} \newenvironment{CenterfigureMultiWide}{\begin{CenterfigureMulti}}{\end{CenterfigureMulti}} -\newenvironment{Herefigure}{\begin{figure}[ht!p]\centering}{\end{figure}} +\newenvironment{Herefigure}{\begin{figure}[ht!]\centering}{\end{figure}} \newenvironment{FigureInside}{\begin{list}{}{\leftmargin=0pt\topsep=0pt\parsep=\FigOrigskip\partopsep=0pt}\item}{\end{list}} From ef84301f83d2be2bf8fa05040fc0703c0f82cb0f Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 6 Sep 2011 10:23:31 -0600 Subject: [PATCH 195/235] JSON timing data --- collects/meta/drdr/render.rkt | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/collects/meta/drdr/render.rkt b/collects/meta/drdr/render.rkt index e274bd4daf..9b4f1e7f50 100644 --- a/collects/meta/drdr/render.rkt +++ b/collects/meta/drdr/render.rkt @@ -282,6 +282,21 @@ [(struct stderr (bs)) `(pre ([class "stderr"]) ,(bytes->string/utf-8 bs))]))) +(define (json-timing req path-to-file) + (let* ([timing-pth (path-timing-log (apply build-path path-to-file))] + [s (file->string timing-pth)] + [s (regexp-replace* (regexp-quote "(") s "[")] + [s (regexp-replace* (regexp-quote ")") s "]")] + [s (format "[~a]" s)]) + (response + 200 #"Okay" + (file-or-directory-modify-seconds timing-pth) + #"application/json" + (list (make-header #"Access-Control-Allow-Origin" + #"*")) + (lambda (out) + (write-string s out))))) + (define (render-log log-pth) (match (log-rendering log-pth) [#f @@ -940,6 +955,7 @@ [("help") show-help] [("") show-revisions] [("diff" (integer-arg) (integer-arg) (string-arg) ...) show-diff] + [("json" "timing" (string-arg) ...) json-timing] [("current" "") show-revision/current] [("current" (string-arg) ...) show-file/current] [((integer-arg) "") show-revision] From e9a9d7949030faab94d0223a6ebebe3ad9e8b602 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 6 Sep 2011 15:41:25 -0600 Subject: [PATCH 196/235] Better solution to pr12145 --- .../dispatchers/dispatch-files-test.rkt | 20 ++++----- .../web-server/private/mime-types-test.rkt | 2 +- .../web-server/private/response-test.rkt | 15 ++++--- .../web-server/dispatchers/dispatch-files.rkt | 4 +- collects/web-server/http/response-structs.rkt | 4 +- collects/web-server/http/response.rkt | 45 ++++++++++--------- collects/web-server/http/xexpr.rkt | 2 +- collects/web-server/private/mime-types.rkt | 6 +-- .../web-server/scribblings/dispatchers.scrbl | 2 +- collects/web-server/scribblings/http.scrbl | 6 +-- .../web-server/scribblings/mime-types.scrbl | 2 +- 11 files changed, 59 insertions(+), 49 deletions(-) diff --git a/collects/tests/web-server/dispatchers/dispatch-files-test.rkt b/collects/tests/web-server/dispatchers/dispatch-files-test.rkt index a42f645af2..58e3110408 100644 --- a/collects/tests/web-server/dispatchers/dispatch-files-test.rkt +++ b/collects/tests/web-server/dispatchers/dispatch-files-test.rkt @@ -80,22 +80,22 @@ (test-equal?* "file, exists, whole, no Range, get" (collect (dispatch #t tmp-file) (req #f #"GET" empty)) - #"HTTP/1.1 200 OK\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html; charset=utf-8\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\n\r\nA titleHere's some content!") + #"HTTP/1.1 200 OK\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\n\r\nA titleHere's some content!") (test-equal?* "file, exists, whole, no Range, head" (collect (dispatch #t tmp-file) (req #f #"HEAD" empty)) - #"HTTP/1.1 200 OK\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html; charset=utf-8\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\n\r\n") + #"HTTP/1.1 200 OK\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\n\r\n") (test-equal?* "file, exists, whole, Range, get" (collect (dispatch #t tmp-file) (req #f #"GET" (list (make-header #"Range" #"bytes=0-80")))) - #"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html; charset=utf-8\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\nContent-Range: bytes 0-80/81\r\n\r\nA titleHere's some content!") + #"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\nContent-Range: bytes 0-80/81\r\n\r\nA titleHere's some content!") (test-equal?* "file, exists, whole, Range, head" (collect (dispatch #t tmp-file) (req #f #"HEAD" (list (make-header #"Range" #"bytes=0-80")))) - #"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html; charset=utf-8\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\nContent-Range: bytes 0-80/81\r\n\r\n") + #"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\nContent-Range: bytes 0-80/81\r\n\r\n") (test-equal?* "file, exists, part, get" (collect (dispatch #t tmp-file) (req #f #"GET" (list (make-header #"Range" #"bytes=5-9")))) - #"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html; charset=utf-8\r\nAccept-Ranges: bytes\r\nContent-Length: 5\r\nContent-Range: bytes 5-9/81\r\n\r\n>A titleHere's some content!") + #"HTTP/1.1 200 OK\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\n\r\nA titleHere's some content!") (test-equal?* "dir, exists, no Range, head" (collect (dispatch #t a-dir) (req #t #"HEAD" empty)) - #"HTTP/1.1 200 OK\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html; charset=utf-8\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\n\r\n") + #"HTTP/1.1 200 OK\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\n\r\n") (test-equal?* "dir, exists, Range, get" (collect (dispatch #t a-dir) (req #t #"GET" (list (make-header #"Range" #"bytes=0-80")))) - #"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html; charset=utf-8\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\nContent-Range: bytes 0-80/81\r\n\r\nA titleHere's some content!") + #"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\nContent-Range: bytes 0-80/81\r\n\r\nA titleHere's some content!") (test-equal?* "dir, exists, Range, head" (collect (dispatch #t a-dir) (req #t #"HEAD" (list (make-header #"Range" #"bytes=0-80")))) - #"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html; charset=utf-8\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\nContent-Range: bytes 0-80/81\r\n\r\n") + #"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nAccept-Ranges: bytes\r\nContent-Length: 81\r\nContent-Range: bytes 0-80/81\r\n\r\n") (test-equal?* "dir, not dir-url, get" (collect (dispatch #t a-dir) (req #f #"GET" empty)) #"HTTP/1.1 302 Moved Temporarily\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nConnection: close\r\nLocation: /foo/\r\n\r\n") diff --git a/collects/tests/web-server/private/mime-types-test.rkt b/collects/tests/web-server/private/mime-types-test.rkt index 91566d0152..708c883ec4 100644 --- a/collects/tests/web-server/private/mime-types-test.rkt +++ b/collects/tests/web-server/private/mime-types-test.rkt @@ -28,7 +28,7 @@ END (check-not-false (read-mime-types test-file))) (test-case "Default mime-type given" - (check-equal? ((make-path->mime-type test-file) (build-path "test.html")) TEXT/HTML-MIME-TYPE)) + (check-equal? ((make-path->mime-type test-file) (build-path "test.html")) #f)) (test-case "MIME type resolves (single in file)" (check-equal? ((make-path->mime-type test-file) (build-path "test.mp4")) #"video/mp4")) diff --git a/collects/tests/web-server/private/response-test.rkt b/collects/tests/web-server/private/response-test.rkt index 4f70967256..130043568d 100644 --- a/collects/tests/web-server/private/response-test.rkt +++ b/collects/tests/web-server/private/response-test.rkt @@ -36,6 +36,11 @@ (response 404 #"404" (current-seconds) #"text/html" (list) void)) #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: text/html\r\nConnection: close\r\n\r\n") + (test-equi? "response" + (output output-response + (response 404 #"404" (current-seconds) #f + (list) void)) + #"HTTP/1.1 404 404\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nConnection: close\r\n\r\n") (test-equi? "response (header)" (output output-response (response 404 #"404" (current-seconds) #"text/html" @@ -231,12 +236,12 @@ (test-equi? "(get) multiple ranges" (output output-file/boundary tmp-file #"GET" #"text/html" '((10 . 19) (30 . 39) (50 . 59)) #"BOUNDARY") - #"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: multipart/byteranges; boundary=BOUNDARY\r\nAccept-Ranges: bytes\r\nContent-Length: 260\r\n\r\n--BOUNDARY\r\nContent-Type: text/html\r\nContent-Range: bytes 10-19/81\r\n\r\nd>A\r\n--BOUNDARY\r\nContent-Type: text/html\r\nContent-Range: bytes 30-39/81\r\n\r\ntle></head\r\n--BOUNDARY\r\nContent-Type: text/html\r\nContent-Range: bytes 50-59/81\r\n\r\ne's some c\r\n--BOUNDARY--\r\n") + #"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: multipart/byteranges; boundary=BOUNDARY\r\nAccept-Ranges: bytes\r\nContent-Length: 266\r\n\r\n--BOUNDARY\r\nContent-Type: text/html\r\nContent-Range: bytes 10-19/81\r\n\r\nd><title>A\r\n\r\n--BOUNDARY\r\nContent-Type: text/html\r\nContent-Range: bytes 30-39/81\r\n\r\ntle></head\r\n\r\n--BOUNDARY\r\nContent-Type: text/html\r\nContent-Range: bytes 50-59/81\r\n\r\ne's some c\r\n\r\n--BOUNDARY--\r\n") (test-equi? "(get) some bad ranges" (parameterize ([current-error-port (open-output-nowhere)]) (output output-file/boundary tmp-file #"GET" #"text/html" '((10 . 19) (1000 . 1050) (30 . 39) (50 . 49)) #"BOUNDARY")) - #"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: multipart/byteranges; boundary=BOUNDARY\r\nAccept-Ranges: bytes\r\nContent-Length: 178\r\n\r\n--BOUNDARY\r\nContent-Type: text/html\r\nContent-Range: bytes 10-19/81\r\n\r\nd><title>A\r\n--BOUNDARY\r\nContent-Type: text/html\r\nContent-Range: bytes 30-39/81\r\n\r\ntle></head\r\n--BOUNDARY--\r\n") + #"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: multipart/byteranges; boundary=BOUNDARY\r\nAccept-Ranges: bytes\r\nContent-Length: 182\r\n\r\n--BOUNDARY\r\nContent-Type: text/html\r\nContent-Range: bytes 10-19/81\r\n\r\nd><title>A\r\n\r\n--BOUNDARY\r\nContent-Type: text/html\r\nContent-Range: bytes 30-39/81\r\n\r\ntle></head\r\n\r\n--BOUNDARY--\r\n") (test-equi? "(get) all bad ranges" (parameterize ([current-error-port (open-output-nowhere)]) @@ -281,11 +286,11 @@ (test-equi? "(head) multiple ranges" (output output-file/boundary tmp-file #"HEAD" #"text/html" '((10 . 19) (30 . 39) (50 . 59)) #"BOUNDARY") - #"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: multipart/byteranges; boundary=BOUNDARY\r\nAccept-Ranges: bytes\r\nContent-Length: 260\r\n\r\n") + #"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: multipart/byteranges; boundary=BOUNDARY\r\nAccept-Ranges: bytes\r\nContent-Length: 266\r\n\r\n") (test-equi? "(head) some bad ranges" (output output-file/boundary tmp-file #"HEAD" #"text/html" '((10 . 19) (1000 . 1050) (30 . 39) (50 . 49)) #"BOUNDARY") - #"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: multipart/byteranges; boundary=BOUNDARY\r\nAccept-Ranges: bytes\r\nContent-Length: 178\r\n\r\n") + #"HTTP/1.1 206 Partial content\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: Racket\r\nContent-Type: multipart/byteranges; boundary=BOUNDARY\r\nAccept-Ranges: bytes\r\nContent-Length: 182\r\n\r\n") (test-equi? "(head) all bad ranges" (parameterize ([current-error-port (open-output-nowhere)]) @@ -301,4 +306,4 @@ (get-output-string os)) "convert-http-ranges: No satisfiable ranges in ((-10 . -5) (1000 . 1050) (50 . 49))/81.") - )))) \ No newline at end of file + )))) diff --git a/collects/web-server/dispatchers/dispatch-files.rkt b/collects/web-server/dispatchers/dispatch-files.rkt index 037f311647..72297496a9 100644 --- a/collects/web-server/dispatchers/dispatch-files.rkt +++ b/collects/web-server/dispatchers/dispatch-files.rkt @@ -14,7 +14,7 @@ [read-range-header (-> (listof header?) (or/c (listof pair?) false/c))] [make (->* (#:url->path url->path/c) - (#:path->mime-type (path-string? . -> . bytes?) + (#:path->mime-type (path-string? . -> . (or/c false/c bytes?)) #:indices (listof path-string?)) dispatcher/c)]) @@ -27,7 +27,7 @@ (define interface-version 'v1) (define (make #:url->path url->path - #:path->mime-type [path->mime-type (lambda (path) TEXT/HTML-MIME-TYPE)] + #:path->mime-type [path->mime-type (lambda (path) #f)] #:indices [indices (list "index.html" "index.htm")]) (lambda (conn req) (define uri (request-uri req)) diff --git a/collects/web-server/http/response-structs.rkt b/collects/web-server/http/response-structs.rkt index 49748c9db8..3f63724828 100644 --- a/collects/web-server/http/response-structs.rkt +++ b/collects/web-server/http/response-structs.rkt @@ -24,8 +24,8 @@ ([code number?] [message bytes?] [seconds number?] - [mime bytes?] + [mime (or/c false/c bytes?)] [headers (listof header?)] [output (output-port? . -> . void)])] - [response/full (-> number? bytes? number? bytes? (listof header?) (listof bytes?) response?)] + [response/full (-> number? bytes? number? (or/c false/c bytes?) (listof header?) (listof bytes?) response?)] [TEXT/HTML-MIME-TYPE bytes?]) diff --git a/collects/web-server/http/response.rkt b/collects/web-server/http/response.rkt index f6b041cc88..f64c629b0c 100644 --- a/collects/web-server/http/response.rkt +++ b/collects/web-server/http/response.rkt @@ -16,7 +16,7 @@ [print-headers (output-port? (listof header?) . -> . void)] [rename ext:output-response output-response (connection? response? . -> . void)] [rename ext:output-response/method output-response/method (connection? response? bytes? . -> . void)] - [rename ext:output-file output-file (connection? path-string? bytes? bytes? (or/c pair? false/c) . -> . void)]) + [rename ext:output-file output-file (connection? path-string? bytes? (or/c bytes? false/c) (or/c pair? false/c) . -> . void)]) (define (output-response conn resp) (output-response/method conn resp #"GET")) @@ -59,9 +59,13 @@ [#"Last-Modified" (string->bytes/utf-8 (seconds->gmt-string (response-seconds bresp)))] [#"Server" - #"Racket"] - [#"Content-Type" - (response-mime bresp)]) + #"Racket"]) + (if (response-mime bresp) + (maybe-headers + seen? + [#"Content-Type" + (response-mime bresp)]) + empty) (if (connection-close? conn) (maybe-headers seen? @@ -152,12 +156,12 @@ ;; A boundary is generated only if a multipart/byteranges response needs ;; to be generated (i.e. if a Ranges header was specified with more than ;; one range in it). -(define (output-file conn file-path method mime-type ranges) +(define (output-file conn file-path method maybe-mime-type ranges) (output-file/boundary conn file-path method - mime-type + maybe-mime-type ranges (if (and ranges (> (length ranges) 1)) (md5 (string->bytes/utf-8 (number->string (current-inexact-milliseconds)))) @@ -170,7 +174,7 @@ ;; (U (listof (U byte-range-spec suffix-byte-range-spec)) #f) ;; (U bytes #f) ;; -> void -(define (output-file/boundary conn file-path method mime-type ranges boundary) +(define (output-file/boundary conn file-path method maybe-mime-type ranges boundary) ; total-file-length : integer (define total-file-length (file-size file-path)) @@ -189,7 +193,7 @@ (exn-message exn)) (output-response-head conn - (make-416-response modified-seconds mime-type)))]) + (make-416-response modified-seconds maybe-mime-type)))]) (let* (; converted-ranges : (alist-of integer integer) ; This is a list of actual start and end offsets in the file. ; See the comments for convert-http-ranges for more information. @@ -203,7 +207,7 @@ ; response. This *must be* the same length as converted-ranges. [multipart-headers (if (> (length converted-ranges) 1) - (prerender-multipart/byteranges-headers mime-type converted-ranges total-file-length) + (prerender-multipart/byteranges-headers maybe-mime-type converted-ranges total-file-length) (list #""))] ; total-content-length : integer [total-content-length @@ -226,8 +230,8 @@ (output-response-head conn (if ranges - (make-206-response modified-seconds mime-type total-content-length total-file-length converted-ranges boundary) - (make-200-response modified-seconds mime-type total-content-length))) + (make-206-response modified-seconds maybe-mime-type total-content-length total-file-length converted-ranges boundary) + (make-200-response modified-seconds maybe-mime-type total-content-length))) ; Send the appropriate file content: (when (bytes-ci=? method #"GET") (adjust-connection-timeout! ; Give it one second per byte. @@ -261,13 +265,14 @@ (loop rest (cdr multipart-headers))])))))))))) ;; prerender-multipart/byteranges-headers : bytes (alist-of integer integer) integer -> (list-of bytes) -(define (prerender-multipart/byteranges-headers mime-type converted-ranges total-file-length) +(define (prerender-multipart/byteranges-headers maybe-mime-type converted-ranges total-file-length) (map (lambda (range) (match range [(list-rest start end) (let ([out (open-output-bytes)]) - (print-headers out (list (make-header #"Content-Type" mime-type) - (make-content-range-header start end total-file-length))) + (when maybe-mime-type + (print-headers out (list (make-header #"Content-Type" maybe-mime-type)))) + (print-headers out (list (make-content-range-header start end total-file-length))) (begin0 (get-output-bytes out) (close-output-port out)))])) converted-ranges)) @@ -326,14 +331,14 @@ converted)) ;; make-206-response : integer bytes integer integer (alist-of integer integer) bytes -> basic-response -(define (make-206-response modified-seconds mime-type total-content-length total-file-length converted-ranges boundary) +(define (make-206-response modified-seconds maybe-mime-type total-content-length total-file-length converted-ranges boundary) (if (= (length converted-ranges) 1) (let ([start (caar converted-ranges)] [end (cdar converted-ranges)]) (response 206 #"Partial content" modified-seconds - mime-type + maybe-mime-type (list (make-header #"Accept-Ranges" #"bytes") (make-content-length-header total-content-length) (make-content-range-header start end total-file-length)) @@ -347,21 +352,21 @@ void))) ;; make-200-response : integer bytes integer -> basic-response -(define (make-200-response modified-seconds mime-type total-content-length) +(define (make-200-response modified-seconds maybe-mime-type total-content-length) (response 200 #"OK" modified-seconds - mime-type + maybe-mime-type (list (make-header #"Accept-Ranges" #"bytes") (make-content-length-header total-content-length)) void)) ;; make-416-response : integer bytes -> basic-response -(define (make-416-response modified-seconds mime-type) +(define (make-416-response modified-seconds maybe-mime-type) (response 416 #"Invalid range request" modified-seconds - mime-type + maybe-mime-type null void)) diff --git a/collects/web-server/http/xexpr.rkt b/collects/web-server/http/xexpr.rkt index 708066461d..298be367f8 100644 --- a/collects/web-server/http/xexpr.rkt +++ b/collects/web-server/http/xexpr.rkt @@ -28,5 +28,5 @@ (provide/contract [response/xexpr ((pretty-xexpr/c) - (#:code number? #:message bytes? #:seconds number? #:mime-type bytes? #:cookies (listof cookie?) #:headers (listof header?) #:preamble bytes?) + (#:code number? #:message bytes? #:seconds number? #:mime-type (or/c false/c bytes?) #:cookies (listof cookie?) #:headers (listof header?) #:preamble bytes?) . ->* . response?)]) diff --git a/collects/web-server/private/mime-types.rkt b/collects/web-server/private/mime-types.rkt index 1a7346f709..3f48b5ab77 100644 --- a/collects/web-server/private/mime-types.rkt +++ b/collects/web-server/private/mime-types.rkt @@ -6,7 +6,7 @@ web-server/http) (provide/contract [read-mime-types (path-string? . -> . (hash/c symbol? bytes?))] - [make-path->mime-type (path-string? . -> . (path? . -> . bytes?))]) + [make-path->mime-type (path-string? . -> . (path? . -> . (or/c false/c bytes?)))]) ; read-mime-types : path? -> hash-table? (define (read-mime-types a-path) @@ -40,5 +40,5 @@ [(regexp #rx#".*\\.([^\\.]*$)" (list _ sffx)) (hash-ref (force MIME-TYPE-TABLE) (lowercase-symbol! sffx) - TEXT/HTML-MIME-TYPE)] - [_ TEXT/HTML-MIME-TYPE]))) + #f)] + [_ #f]))) diff --git a/collects/web-server/scribblings/dispatchers.scrbl b/collects/web-server/scribblings/dispatchers.scrbl index 5d0fa65e89..6d228e8ab7 100644 --- a/collects/web-server/scribblings/dispatchers.scrbl +++ b/collects/web-server/scribblings/dispatchers.scrbl @@ -316,7 +316,7 @@ a URL that refreshes the password file, servlet cache, etc.} It defines a dispatcher construction procedure.}]{ @defproc[(make [#:url->path url->path url->path/c] - [#:path->mime-type path->mime-type (path? . -> . bytes?) (lambda (path) TEXT/HTML-MIME-TYPE)] + [#:path->mime-type path->mime-type (path? . -> . (or/c false/c bytes)?) (lambda (path) #f)] [#:indices indices (listof string?) (list "index.html" "index.htm")]) dispatcher/c]{ Uses @racket[url->path] to extract a path from the URL in the request diff --git a/collects/web-server/scribblings/http.scrbl b/collects/web-server/scribblings/http.scrbl index 299441b7e0..15b9c3b1b9 100644 --- a/collects/web-server/scribblings/http.scrbl +++ b/collects/web-server/scribblings/http.scrbl @@ -164,7 +164,7 @@ Here is an example typical of what you will find in many applications: ([code number?] [message bytes?] [seconds number?] - [mime bytes?] + [mime (or/c false/c bytes?)] [headers (listof header?)] [output (output-port? . -> . void)])]{ An HTTP response where @racket[output] produces the body. @racket[code] is the response code, @@ -182,7 +182,7 @@ Here is an example typical of what you will find in many applications: ] } -@defproc[(response/full [code number?] [message bytes?] [seconds number?] [mime bytes?] +@defproc[(response/full [code number?] [message bytes?] [seconds number?] [mime (or/c false/c bytes?)] [headers (listof header?)] [body (listof bytes?)]) response?]{ A constructor for responses where @racket[body] is the response body. @@ -481,7 +481,7 @@ web-server/insta [#:code code number? 200] [#:message message bytes? #"Okay"] [#:seconds seconds number? (current-seconds)] - [#:mime-type mime-type bytes? TEXT/HTML-MIME-TYPE] + [#:mime-type mime-type (or/c false/c bytes?) TEXT/HTML-MIME-TYPE] [#:headers headers (listof header?) empty] [#:cookies cookies (listof cookie?) empty] [#:preamble preamble bytes? #""]) diff --git a/collects/web-server/scribblings/mime-types.scrbl b/collects/web-server/scribblings/mime-types.scrbl index 440d8f0288..0fd121d1cb 100644 --- a/collects/web-server/scribblings/mime-types.scrbl +++ b/collects/web-server/scribblings/mime-types.scrbl @@ -17,7 +17,7 @@ files. } @defproc[(make-path->mime-type [p path-string?]) - (path? . -> . bytes?)]{ + (path? . -> . (or/c false/c bytes?))]{ Uses a @racket[read-mime-types] with @racket[p] and constructs a function from paths to their MIME type. } From 7347b1b67173ac04a9a440e57e2d2bf5af176733 Mon Sep 17 00:00:00 2001 From: Jay McCarthy <jay@racket-lang.org> Date: Tue, 6 Sep 2011 15:42:00 -0600 Subject: [PATCH 197/235] Getting ready for new graphs --- collects/meta/drdr/render.rkt | 44 ++++++++++++++++++++++++----------- 1 file changed, 31 insertions(+), 13 deletions(-) diff --git a/collects/meta/drdr/render.rkt b/collects/meta/drdr/render.rkt index 9b4f1e7f50..2f1486fa5c 100644 --- a/collects/meta/drdr/render.rkt +++ b/collects/meta/drdr/render.rkt @@ -282,20 +282,38 @@ [(struct stderr (bs)) `(pre ([class "stderr"]) ,(bytes->string/utf-8 bs))]))) +(define (json-out out x) + (cond + [(list? x) + (fprintf out "[") + (let loop ([l x]) + (match l + [(list) + (void)] + [(list e) + (json-out out e)] + [(list-rest e es) + (json-out out e) + (fprintf out ",") + (loop es)])) + (fprintf out "]")] + [else + (display x out)])) + (define (json-timing req path-to-file) - (let* ([timing-pth (path-timing-log (apply build-path path-to-file))] - [s (file->string timing-pth)] - [s (regexp-replace* (regexp-quote "(") s "[")] - [s (regexp-replace* (regexp-quote ")") s "]")] - [s (format "[~a]" s)]) - (response - 200 #"Okay" - (file-or-directory-modify-seconds timing-pth) - #"application/json" - (list (make-header #"Access-Control-Allow-Origin" - #"*")) - (lambda (out) - (write-string s out))))) + (define timing-pth (path-timing-log (apply build-path path-to-file))) + (define ts (file->list timing-pth)) + (response + 200 #"Okay" + (file-or-directory-modify-seconds timing-pth) + #"application/json" + (list (make-header #"Access-Control-Allow-Origin" + #"*")) + (lambda (out) + (fprintf out "[") + (for ([l (in-list (add-between ts ","))]) + (json-out out l)) + (fprintf out "]")))) (define (render-log log-pth) (match (log-rendering log-pth) From 0dde6af58152c39d8ce8023bcb4ea7a52dcd98c1 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt <samth@racket-lang.org> Date: Tue, 6 Sep 2011 17:32:03 -0400 Subject: [PATCH 198/235] Fancy Flot-based JS charting for DrDr timing. Signed-off-by: Jay McCarthy <jay@racket-lang.org> --- collects/meta/drdr/render.rkt | 11 + collects/meta/drdr/static/chart.js | 135 + collects/meta/drdr/static/jquery-1.6.2.min.js | 18 + collects/meta/drdr/static/jquery.flot.js | 2599 +++++++++++++++++ .../meta/drdr/static/jquery.flot.selection.js | 344 +++ 5 files changed, 3107 insertions(+) create mode 100644 collects/meta/drdr/static/chart.js create mode 100644 collects/meta/drdr/static/jquery-1.6.2.min.js create mode 100644 collects/meta/drdr/static/jquery.flot.js create mode 100644 collects/meta/drdr/static/jquery.flot.selection.js diff --git a/collects/meta/drdr/render.rkt b/collects/meta/drdr/render.rkt index 2f1486fa5c..15dbd4a813 100644 --- a/collects/meta/drdr/render.rkt +++ b/collects/meta/drdr/render.rkt @@ -340,6 +340,9 @@ (define output (map render-event output-log)) (response/xexpr `(html (head (title ,title) + (script ([language "javascript"] [type "text/javascript"] [src "jquery-1.6.2.min.js"])) + (script ([language "javascript"] [type "text/javascript"] [src "jquery.flot.js"])) + (script ([language "javascript"] [type "text/javascript"] [src "jquery.flot.selection.js"])) (link ([rel "stylesheet"] [type "text/css"] [href "/render.css"]))) (body (div ([class "log, content"]) @@ -370,6 +373,14 @@ '() `((div ([class "output"]) " " ,@output))) + (div ([id "_chart"] [style "width:800px;height:300px;"])) + (script ([language "javascript"] [type "text/javascript"] [src "chart.js"])) + (script ([language "javascript"] [type "text/javascript"]) + ,(format "get_data('/json/timing/~a');" the-base-path)) + (button ([onclick "reset_chart()"]) "Reset") + (button ([id "setlegend"] [onclick "set_legend(!cur_options.legend.show)"]) + "Hide Legend") + ,(with-handlers ([exn:fail? ; XXX Remove this eventually (lambda (x) diff --git a/collects/meta/drdr/static/chart.js b/collects/meta/drdr/static/chart.js new file mode 100644 index 0000000000..ff3ad5f48b --- /dev/null +++ b/collects/meta/drdr/static/chart.js @@ -0,0 +1,135 @@ +function moving_avg(arr, i, _acc, _m) { + var acc = _acc || function(j) { return arr[j]; }; + var m = _m || 5; + var top = Math.min(i + m, arr.length); + var bot = Math.max(0, i - m); + var n = top - bot; + var sum = 0; + for (var i = bot; i < top; i++) + sum += acc(i); + return sum/n; +} + +var data = null; +var sub_times = []; +var overall_times = []; +var overall_avg = []; +var chart_data = []; +var options = { selection: { mode: "xy" }, + legend: { backgroundOpacity: 0, position: "sw", show: true }, + xaxes: [{label: 'push'}], + yaxes: [{}, {position: "right"}], + grid: { hoverable : true } + }; +var placeholder = $("#_chart"); +var cur_options = options; +var previousPoint = null; + +function showTooltip(x, y, contents) { + $('<div id="tooltip">' + contents + '</div>').css( { + position: 'absolute', + display: 'none', + top: y + 5, + left: x + 5, + border: '1px solid #fdd', + padding: '2px', + 'background-color': '#fee', + opacity: 0.80 + }).appendTo("body").fadeIn(200); +} + +placeholder.bind("plotselected", handle_selection); + +placeholder.bind("plothover", function (event, pos, item) { + if (item) { + if (previousPoint != item.dataIndex) { + previousPoint = item.dataIndex; + + $("#tooltip").remove(); + var x = item.datapoint[0], + y = item.datapoint[1].toFixed(2); + + showTooltip(item.pageX, item.pageY, + item.series.label + " at push " + x + ": " + + y + " ms"); + } + } + else { + $("#tooltip").remove(); + previousPoint = null; + } +}); + +function load_data(d) { + chart_data = []; + overall_times = []; + overall_avg = []; + sub_times = []; + pdata = [] + reset_chart(); + data = d; + + pdata = data && JSON.parse(data); + + var max_overall = 0; + var max_sub = 0; + + // build the timing data arrays + for (var i = 0; i < pdata.length; i++) { + overall_times.push([pdata[i][0], pdata[i][1]]); + overall_avg.push([pdata[i][0], + moving_avg(pdata, i, + function(j) { return pdata[j][1]; })]); + max_overall = Math.max(max_overall, pdata[i][1]); + if (pdata[i][2].length != 0) { + for (var j = 0; j < pdata[i][2].length; j++) { + sub_times[j] = sub_times[j] || []; + sub_times[j].push([pdata[i][0],pdata[i][2][j][0]]); + max_sub = Math.max(max_sub, pdata[i][2][j][0]); + } + } + }; + + // is there a significant difference between the overall times + // and the internal timings? + + var ya = 1; + if (max_overall > (5 * max_sub)) { ya = 2; } + + // put the data into the chart format + chart_data.push({data: overall_times, label: "Overall Time"}); + chart_data.push({data: overall_avg, label: "Overall Moving Avg"}); + for(var i = 0; i < sub_times.length; i++) { + chart_data.push({data: sub_times[i], label: "Timer "+ (i+1), points: { show: true }, yaxis: ya}); + } +} + +function get_data(url) { + //console.log("URL:", url); + $.ajax({url: url, + beforeSend: function(xhr) { + xhr.overrideMimeType( 'text/plain; charset=x-user-defined' ); + }, + success: function(d) { load_data(d); show(); }}); +} + + +function show() { $.plot(placeholder, chart_data, cur_options); } + +function handle_selection(event, ranges) { + cur_options = $.extend(true, {}, cur_options, { + yaxis: { min: ranges.yaxis.from, max: ranges.yaxis.to }, + xaxis: { min: ranges.xaxis.from, max: ranges.xaxis.to }}); + show(); +} + +function set_legend(new_val) { + cur_options = $.extend(true,{},cur_options, {legend: {show: new_val}}); + show(); + if (new_val) + $("#setlegend").text("Hide Legend") + else + $("#setlegend").text("Show Legend") +} + +function reset_chart() { cur_options = options; show(); } diff --git a/collects/meta/drdr/static/jquery-1.6.2.min.js b/collects/meta/drdr/static/jquery-1.6.2.min.js new file mode 100644 index 0000000000..48590ecb96 --- /dev/null +++ b/collects/meta/drdr/static/jquery-1.6.2.min.js @@ -0,0 +1,18 @@ +/*! + * jQuery JavaScript Library v1.6.2 + * http://jquery.com/ + * + * Copyright 2011, John Resig + * Dual licensed under the MIT or GPL Version 2 licenses. + * http://jquery.org/license + * + * Includes Sizzle.js + * http://sizzlejs.com/ + * Copyright 2011, The Dojo Foundation + * Released under the MIT, BSD, and GPL Licenses. + * + * Date: Thu Jun 30 14:16:56 2011 -0400 + */ +(function(a,b){function cv(a){return f.isWindow(a)?a:a.nodeType===9?a.defaultView||a.parentWindow:!1}function cs(a){if(!cg[a]){var b=c.body,d=f("<"+a+">").appendTo(b),e=d.css("display");d.remove();if(e==="none"||e===""){ch||(ch=c.createElement("iframe"),ch.frameBorder=ch.width=ch.height=0),b.appendChild(ch);if(!ci||!ch.createElement)ci=(ch.contentWindow||ch.contentDocument).document,ci.write((c.compatMode==="CSS1Compat"?"<!doctype html>":"")+"<html><body>"),ci.close();d=ci.createElement(a),ci.body.appendChild(d),e=f.css(d,"display"),b.removeChild(ch)}cg[a]=e}return cg[a]}function cr(a,b){var c={};f.each(cm.concat.apply([],cm.slice(0,b)),function(){c[this]=a});return c}function cq(){cn=b}function cp(){setTimeout(cq,0);return cn=f.now()}function cf(){try{return new a.ActiveXObject("Microsoft.XMLHTTP")}catch(b){}}function ce(){try{return new a.XMLHttpRequest}catch(b){}}function b$(a,c){a.dataFilter&&(c=a.dataFilter(c,a.dataType));var d=a.dataTypes,e={},g,h,i=d.length,j,k=d[0],l,m,n,o,p;for(g=1;g<i;g++){if(g===1)for(h in a.converters)typeof h=="string"&&(e[h.toLowerCase()]=a.converters[h]);l=k,k=d[g];if(k==="*")k=l;else if(l!=="*"&&l!==k){m=l+" "+k,n=e[m]||e["* "+k];if(!n){p=b;for(o in e){j=o.split(" ");if(j[0]===l||j[0]==="*"){p=e[j[1]+" "+k];if(p){o=e[o],o===!0?n=p:p===!0&&(n=o);break}}}}!n&&!p&&f.error("No conversion from "+m.replace(" "," to ")),n!==!0&&(c=n?n(c):p(o(c)))}}return c}function bZ(a,c,d){var e=a.contents,f=a.dataTypes,g=a.responseFields,h,i,j,k;for(i in g)i in d&&(c[g[i]]=d[i]);while(f[0]==="*")f.shift(),h===b&&(h=a.mimeType||c.getResponseHeader("content-type"));if(h)for(i in e)if(e[i]&&e[i].test(h)){f.unshift(i);break}if(f[0]in d)j=f[0];else{for(i in d){if(!f[0]||a.converters[i+" "+f[0]]){j=i;break}k||(k=i)}j=j||k}if(j){j!==f[0]&&f.unshift(j);return d[j]}}function bY(a,b,c,d){if(f.isArray(b))f.each(b,function(b,e){c||bC.test(a)?d(a,e):bY(a+"["+(typeof e=="object"||f.isArray(e)?b:"")+"]",e,c,d)});else if(!c&&b!=null&&typeof b=="object")for(var e in b)bY(a+"["+e+"]",b[e],c,d);else d(a,b)}function bX(a,c,d,e,f,g){f=f||c.dataTypes[0],g=g||{},g[f]=!0;var h=a[f],i=0,j=h?h.length:0,k=a===bR,l;for(;i<j&&(k||!l);i++)l=h[i](c,d,e),typeof l=="string"&&(!k||g[l]?l=b:(c.dataTypes.unshift(l),l=bX(a,c,d,e,l,g)));(k||!l)&&!g["*"]&&(l=bX(a,c,d,e,"*",g));return l}function bW(a){return function(b,c){typeof b!="string"&&(c=b,b="*");if(f.isFunction(c)){var d=b.toLowerCase().split(bN),e=0,g=d.length,h,i,j;for(;e<g;e++)h=d[e],j=/^\+/.test(h),j&&(h=h.substr(1)||"*"),i=a[h]=a[h]||[],i[j?"unshift":"push"](c)}}}function bA(a,b,c){var d=b==="width"?a.offsetWidth:a.offsetHeight,e=b==="width"?bv:bw;if(d>0){c!=="border"&&f.each(e,function(){c||(d-=parseFloat(f.css(a,"padding"+this))||0),c==="margin"?d+=parseFloat(f.css(a,c+this))||0:d-=parseFloat(f.css(a,"border"+this+"Width"))||0});return d+"px"}d=bx(a,b,b);if(d<0||d==null)d=a.style[b]||0;d=parseFloat(d)||0,c&&f.each(e,function(){d+=parseFloat(f.css(a,"padding"+this))||0,c!=="padding"&&(d+=parseFloat(f.css(a,"border"+this+"Width"))||0),c==="margin"&&(d+=parseFloat(f.css(a,c+this))||0)});return d+"px"}function bm(a,b){b.src?f.ajax({url:b.src,async:!1,dataType:"script"}):f.globalEval((b.text||b.textContent||b.innerHTML||"").replace(be,"/*$0*/")),b.parentNode&&b.parentNode.removeChild(b)}function bl(a){f.nodeName(a,"input")?bk(a):"getElementsByTagName"in a&&f.grep(a.getElementsByTagName("input"),bk)}function bk(a){if(a.type==="checkbox"||a.type==="radio")a.defaultChecked=a.checked}function bj(a){return"getElementsByTagName"in a?a.getElementsByTagName("*"):"querySelectorAll"in a?a.querySelectorAll("*"):[]}function bi(a,b){var c;if(b.nodeType===1){b.clearAttributes&&b.clearAttributes(),b.mergeAttributes&&b.mergeAttributes(a),c=b.nodeName.toLowerCase();if(c==="object")b.outerHTML=a.outerHTML;else if(c!=="input"||a.type!=="checkbox"&&a.type!=="radio"){if(c==="option")b.selected=a.defaultSelected;else if(c==="input"||c==="textarea")b.defaultValue=a.defaultValue}else a.checked&&(b.defaultChecked=b.checked=a.checked),b.value!==a.value&&(b.value=a.value);b.removeAttribute(f.expando)}}function bh(a,b){if(b.nodeType===1&&!!f.hasData(a)){var c=f.expando,d=f.data(a),e=f.data(b,d);if(d=d[c]){var g=d.events;e=e[c]=f.extend({},d);if(g){delete e.handle,e.events={};for(var h in g)for(var i=0,j=g[h].length;i<j;i++)f.event.add(b,h+(g[h][i].namespace?".":"")+g[h][i].namespace,g[h][i],g[h][i].data)}}}}function bg(a,b){return f.nodeName(a,"table")?a.getElementsByTagName("tbody")[0]||a.appendChild(a.ownerDocument.createElement("tbody")):a}function W(a,b,c){b=b||0;if(f.isFunction(b))return f.grep(a,function(a,d){var e=!!b.call(a,d,a);return e===c});if(b.nodeType)return f.grep(a,function(a,d){return a===b===c});if(typeof b=="string"){var d=f.grep(a,function(a){return a.nodeType===1});if(R.test(b))return f.filter(b,d,!c);b=f.filter(b,d)}return f.grep(a,function(a,d){return f.inArray(a,b)>=0===c})}function V(a){return!a||!a.parentNode||a.parentNode.nodeType===11}function N(a,b){return(a&&a!=="*"?a+".":"")+b.replace(z,"`").replace(A,"&")}function M(a){var b,c,d,e,g,h,i,j,k,l,m,n,o,p=[],q=[],r=f._data(this,"events");if(!(a.liveFired===this||!r||!r.live||a.target.disabled||a.button&&a.type==="click")){a.namespace&&(n=new RegExp("(^|\\.)"+a.namespace.split(".").join("\\.(?:.*\\.)?")+"(\\.|$)")),a.liveFired=this;var s=r.live.slice(0);for(i=0;i<s.length;i++)g=s[i],g.origType.replace(x,"")===a.type?q.push(g.selector):s.splice(i--,1);e=f(a.target).closest(q,a.currentTarget);for(j=0,k=e.length;j<k;j++){m=e[j];for(i=0;i<s.length;i++){g=s[i];if(m.selector===g.selector&&(!n||n.test(g.namespace))&&!m.elem.disabled){h=m.elem,d=null;if(g.preType==="mouseenter"||g.preType==="mouseleave")a.type=g.preType,d=f(a.relatedTarget).closest(g.selector)[0],d&&f.contains(h,d)&&(d=h);(!d||d!==h)&&p.push({elem:h,handleObj:g,level:m.level})}}}for(j=0,k=p.length;j<k;j++){e=p[j];if(c&&e.level>c)break;a.currentTarget=e.elem,a.data=e.handleObj.data,a.handleObj=e.handleObj,o=e.handleObj.origHandler.apply(e.elem,arguments);if(o===!1||a.isPropagationStopped()){c=e.level,o===!1&&(b=!1);if(a.isImmediatePropagationStopped())break}}return b}}function K(a,c,d){var e=f.extend({},d[0]);e.type=a,e.originalEvent={},e.liveFired=b,f.event.handle.call(c,e),e.isDefaultPrevented()&&d[0].preventDefault()}function E(){return!0}function D(){return!1}function m(a,c,d){var e=c+"defer",g=c+"queue",h=c+"mark",i=f.data(a,e,b,!0);i&&(d==="queue"||!f.data(a,g,b,!0))&&(d==="mark"||!f.data(a,h,b,!0))&&setTimeout(function(){!f.data(a,g,b,!0)&&!f.data(a,h,b,!0)&&(f.removeData(a,e,!0),i.resolve())},0)}function l(a){for(var b in a)if(b!=="toJSON")return!1;return!0}function k(a,c,d){if(d===b&&a.nodeType===1){var e="data-"+c.replace(j,"$1-$2").toLowerCase();d=a.getAttribute(e);if(typeof d=="string"){try{d=d==="true"?!0:d==="false"?!1:d==="null"?null:f.isNaN(d)?i.test(d)?f.parseJSON(d):d:parseFloat(d)}catch(g){}f.data(a,c,d)}else d=b}return d}var c=a.document,d=a.navigator,e=a.location,f=function(){function J(){if(!e.isReady){try{c.documentElement.doScroll("left")}catch(a){setTimeout(J,1);return}e.ready()}}var e=function(a,b){return new e.fn.init(a,b,h)},f=a.jQuery,g=a.$,h,i=/^(?:[^<]*(<[\w\W]+>)[^>]*$|#([\w\-]*)$)/,j=/\S/,k=/^\s+/,l=/\s+$/,m=/\d/,n=/^<(\w+)\s*\/?>(?:<\/\1>)?$/,o=/^[\],:{}\s]*$/,p=/\\(?:["\\\/bfnrt]|u[0-9a-fA-F]{4})/g,q=/"[^"\\\n\r]*"|true|false|null|-?\d+(?:\.\d*)?(?:[eE][+\-]?\d+)?/g,r=/(?:^|:|,)(?:\s*\[)+/g,s=/(webkit)[ \/]([\w.]+)/,t=/(opera)(?:.*version)?[ \/]([\w.]+)/,u=/(msie) ([\w.]+)/,v=/(mozilla)(?:.*? rv:([\w.]+))?/,w=/-([a-z])/ig,x=function(a,b){return b.toUpperCase()},y=d.userAgent,z,A,B,C=Object.prototype.toString,D=Object.prototype.hasOwnProperty,E=Array.prototype.push,F=Array.prototype.slice,G=String.prototype.trim,H=Array.prototype.indexOf,I={};e.fn=e.prototype={constructor:e,init:function(a,d,f){var g,h,j,k;if(!a)return this;if(a.nodeType){this.context=this[0]=a,this.length=1;return this}if(a==="body"&&!d&&c.body){this.context=c,this[0]=c.body,this.selector=a,this.length=1;return this}if(typeof a=="string"){a.charAt(0)!=="<"||a.charAt(a.length-1)!==">"||a.length<3?g=i.exec(a):g=[null,a,null];if(g&&(g[1]||!d)){if(g[1]){d=d instanceof e?d[0]:d,k=d?d.ownerDocument||d:c,j=n.exec(a),j?e.isPlainObject(d)?(a=[c.createElement(j[1])],e.fn.attr.call(a,d,!0)):a=[k.createElement(j[1])]:(j=e.buildFragment([g[1]],[k]),a=(j.cacheable?e.clone(j.fragment):j.fragment).childNodes);return e.merge(this,a)}h=c.getElementById(g[2]);if(h&&h.parentNode){if(h.id!==g[2])return f.find(a);this.length=1,this[0]=h}this.context=c,this.selector=a;return this}return!d||d.jquery?(d||f).find(a):this.constructor(d).find(a)}if(e.isFunction(a))return f.ready(a);a.selector!==b&&(this.selector=a.selector,this.context=a.context);return e.makeArray(a,this)},selector:"",jquery:"1.6.2",length:0,size:function(){return this.length},toArray:function(){return F.call(this,0)},get:function(a){return a==null?this.toArray():a<0?this[this.length+a]:this[a]},pushStack:function(a,b,c){var d=this.constructor();e.isArray(a)?E.apply(d,a):e.merge(d,a),d.prevObject=this,d.context=this.context,b==="find"?d.selector=this.selector+(this.selector?" ":"")+c:b&&(d.selector=this.selector+"."+b+"("+c+")");return d},each:function(a,b){return e.each(this,a,b)},ready:function(a){e.bindReady(),A.done(a);return this},eq:function(a){return a===-1?this.slice(a):this.slice(a,+a+1)},first:function(){return this.eq(0)},last:function(){return this.eq(-1)},slice:function(){return this.pushStack(F.apply(this,arguments),"slice",F.call(arguments).join(","))},map:function(a){return this.pushStack(e.map(this,function(b,c){return a.call(b,c,b)}))},end:function(){return this.prevObject||this.constructor(null)},push:E,sort:[].sort,splice:[].splice},e.fn.init.prototype=e.fn,e.extend=e.fn.extend=function(){var a,c,d,f,g,h,i=arguments[0]||{},j=1,k=arguments.length,l=!1;typeof i=="boolean"&&(l=i,i=arguments[1]||{},j=2),typeof i!="object"&&!e.isFunction(i)&&(i={}),k===j&&(i=this,--j);for(;j<k;j++)if((a=arguments[j])!=null)for(c in a){d=i[c],f=a[c];if(i===f)continue;l&&f&&(e.isPlainObject(f)||(g=e.isArray(f)))?(g?(g=!1,h=d&&e.isArray(d)?d:[]):h=d&&e.isPlainObject(d)?d:{},i[c]=e.extend(l,h,f)):f!==b&&(i[c]=f)}return i},e.extend({noConflict:function(b){a.$===e&&(a.$=g),b&&a.jQuery===e&&(a.jQuery=f);return e},isReady:!1,readyWait:1,holdReady:function(a){a?e.readyWait++:e.ready(!0)},ready:function(a){if(a===!0&&!--e.readyWait||a!==!0&&!e.isReady){if(!c.body)return setTimeout(e.ready,1);e.isReady=!0;if(a!==!0&&--e.readyWait>0)return;A.resolveWith(c,[e]),e.fn.trigger&&e(c).trigger("ready").unbind("ready")}},bindReady:function(){if(!A){A=e._Deferred();if(c.readyState==="complete")return setTimeout(e.ready,1);if(c.addEventListener)c.addEventListener("DOMContentLoaded",B,!1),a.addEventListener("load",e.ready,!1);else if(c.attachEvent){c.attachEvent("onreadystatechange",B),a.attachEvent("onload",e.ready);var b=!1;try{b=a.frameElement==null}catch(d){}c.documentElement.doScroll&&b&&J()}}},isFunction:function(a){return e.type(a)==="function"},isArray:Array.isArray||function(a){return e.type(a)==="array"},isWindow:function(a){return a&&typeof a=="object"&&"setInterval"in a},isNaN:function(a){return a==null||!m.test(a)||isNaN(a)},type:function(a){return a==null?String(a):I[C.call(a)]||"object"},isPlainObject:function(a){if(!a||e.type(a)!=="object"||a.nodeType||e.isWindow(a))return!1;if(a.constructor&&!D.call(a,"constructor")&&!D.call(a.constructor.prototype,"isPrototypeOf"))return!1;var c;for(c in a);return c===b||D.call(a,c)},isEmptyObject:function(a){for(var b in a)return!1;return!0},error:function(a){throw a},parseJSON:function(b){if(typeof b!="string"||!b)return null;b=e.trim(b);if(a.JSON&&a.JSON.parse)return a.JSON.parse(b);if(o.test(b.replace(p,"@").replace(q,"]").replace(r,"")))return(new Function("return "+b))();e.error("Invalid JSON: "+b)},parseXML:function(b,c,d){a.DOMParser?(d=new DOMParser,c=d.parseFromString(b,"text/xml")):(c=new ActiveXObject("Microsoft.XMLDOM"),c.async="false",c.loadXML(b)),d=c.documentElement,(!d||!d.nodeName||d.nodeName==="parsererror")&&e.error("Invalid XML: "+b);return c},noop:function(){},globalEval:function(b){b&&j.test(b)&&(a.execScript||function(b){a.eval.call(a,b)})(b)},camelCase:function(a){return a.replace(w,x)},nodeName:function(a,b){return a.nodeName&&a.nodeName.toUpperCase()===b.toUpperCase()},each:function(a,c,d){var f,g=0,h=a.length,i=h===b||e.isFunction(a);if(d){if(i){for(f in a)if(c.apply(a[f],d)===!1)break}else for(;g<h;)if(c.apply(a[g++],d)===!1)break}else if(i){for(f in a)if(c.call(a[f],f,a[f])===!1)break}else for(;g<h;)if(c.call(a[g],g,a[g++])===!1)break;return a},trim:G?function(a){return a==null?"":G.call(a)}:function(a){return a==null?"":(a+"").replace(k,"").replace(l,"")},makeArray:function(a,b){var c=b||[];if(a!=null){var d=e.type(a);a.length==null||d==="string"||d==="function"||d==="regexp"||e.isWindow(a)?E.call(c,a):e.merge(c,a)}return c},inArray:function(a,b){if(H)return H.call(b,a);for(var c=0,d=b.length;c<d;c++)if(b[c]===a)return c;return-1},merge:function(a,c){var d=a.length,e=0;if(typeof c.length=="number")for(var f=c.length;e<f;e++)a[d++]=c[e];else while(c[e]!==b)a[d++]=c[e++];a.length=d;return a},grep:function(a,b,c){var d=[],e;c=!!c;for(var f=0,g=a.length;f<g;f++)e=!!b(a[f],f),c!==e&&d.push(a[f]);return d},map:function(a,c,d){var f,g,h=[],i=0,j=a.length,k=a instanceof e||j!==b&&typeof j=="number"&&(j>0&&a[0]&&a[j-1]||j===0||e.isArray(a));if(k)for(;i<j;i++)f=c(a[i],i,d),f!=null&&(h[h.length]=f);else for(g in a)f=c(a[g],g,d),f!=null&&(h[h.length]=f);return h.concat.apply([],h)},guid:1,proxy:function(a,c){if(typeof c=="string"){var d=a[c];c=a,a=d}if(!e.isFunction(a))return b;var f=F.call(arguments,2),g=function(){return a.apply(c,f.concat(F.call(arguments)))};g.guid=a.guid=a.guid||g.guid||e.guid++;return g},access:function(a,c,d,f,g,h){var i=a.length;if(typeof c=="object"){for(var j in c)e.access(a,j,c[j],f,g,d);return a}if(d!==b){f=!h&&f&&e.isFunction(d);for(var k=0;k<i;k++)g(a[k],c,f?d.call(a[k],k,g(a[k],c)):d,h);return a}return i?g(a[0],c):b},now:function(){return(new Date).getTime()},uaMatch:function(a){a=a.toLowerCase();var b=s.exec(a)||t.exec(a)||u.exec(a)||a.indexOf("compatible")<0&&v.exec(a)||[];return{browser:b[1]||"",version:b[2]||"0"}},sub:function(){function a(b,c){return new a.fn.init(b,c)}e.extend(!0,a,this),a.superclass=this,a.fn=a.prototype=this(),a.fn.constructor=a,a.sub=this.sub,a.fn.init=function(d,f){f&&f instanceof e&&!(f instanceof a)&&(f=a(f));return e.fn.init.call(this,d,f,b)},a.fn.init.prototype=a.fn;var b=a(c);return a},browser:{}}),e.each("Boolean Number String Function Array Date RegExp Object".split(" "),function(a,b){I["[object "+b+"]"]=b.toLowerCase()}),z=e.uaMatch(y),z.browser&&(e.browser[z.browser]=!0,e.browser.version=z.version),e.browser.webkit&&(e.browser.safari=!0),j.test(" ")&&(k=/^[\s\xA0]+/,l=/[\s\xA0]+$/),h=e(c),c.addEventListener?B=function(){c.removeEventListener("DOMContentLoaded",B,!1),e.ready()}:c.attachEvent&&(B=function(){c.readyState==="complete"&&(c.detachEvent("onreadystatechange",B),e.ready())});return e}(),g="done fail isResolved isRejected promise then always pipe".split(" "),h=[].slice;f.extend({_Deferred:function(){var a=[],b,c,d,e={done:function(){if(!d){var c=arguments,g,h,i,j,k;b&&(k=b,b=0);for(g=0,h=c.length;g<h;g++)i=c[g],j=f.type(i),j==="array"?e.done.apply(e,i):j==="function"&&a.push(i);k&&e.resolveWith(k[0],k[1])}return this},resolveWith:function(e,f){if(!d&&!b&&!c){f=f||[],c=1;try{while(a[0])a.shift().apply(e,f)}finally{b=[e,f],c=0}}return this},resolve:function(){e.resolveWith(this,arguments);return this},isResolved:function(){return!!c||!!b},cancel:function(){d=1,a=[];return this}};return e},Deferred:function(a){var b=f._Deferred(),c=f._Deferred(),d;f.extend(b,{then:function(a,c){b.done(a).fail(c);return this},always:function(){return b.done.apply(b,arguments).fail.apply(this,arguments)},fail:c.done,rejectWith:c.resolveWith,reject:c.resolve,isRejected:c.isResolved,pipe:function(a,c){return f.Deferred(function(d){f.each({done:[a,"resolve"],fail:[c,"reject"]},function(a,c){var e=c[0],g=c[1],h;f.isFunction(e)?b[a](function(){h=e.apply(this,arguments),h&&f.isFunction(h.promise)?h.promise().then(d.resolve,d.reject):d[g](h)}):b[a](d[g])})}).promise()},promise:function(a){if(a==null){if(d)return d;d=a={}}var c=g.length;while(c--)a[g[c]]=b[g[c]];return a}}),b.done(c.cancel).fail(b.cancel),delete b.cancel,a&&a.call(b,b);return b},when:function(a){function i(a){return function(c){b[a]=arguments.length>1?h.call(arguments,0):c,--e||g.resolveWith(g,h.call(b,0))}}var b=arguments,c=0,d=b.length,e=d,g=d<=1&&a&&f.isFunction(a.promise)?a:f.Deferred();if(d>1){for(;c<d;c++)b[c]&&f.isFunction(b[c].promise)?b[c].promise().then(i(c),g.reject):--e;e||g.resolveWith(g,b)}else g!==a&&g.resolveWith(g,d?[a]:[]);return g.promise()}}),f.support=function(){var a=c.createElement("div"),b=c.documentElement,d,e,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u;a.setAttribute("className","t"),a.innerHTML=" <link/><table></table><a href='/a' style='top:1px;float:left;opacity:.55;'>a</a><input type='checkbox'/>",d=a.getElementsByTagName("*"),e=a.getElementsByTagName("a")[0];if(!d||!d.length||!e)return{};g=c.createElement("select"),h=g.appendChild(c.createElement("option")),i=a.getElementsByTagName("input")[0],k={leadingWhitespace:a.firstChild.nodeType===3,tbody:!a.getElementsByTagName("tbody").length,htmlSerialize:!!a.getElementsByTagName("link").length,style:/top/.test(e.getAttribute("style")),hrefNormalized:e.getAttribute("href")==="/a",opacity:/^0.55$/.test(e.style.opacity),cssFloat:!!e.style.cssFloat,checkOn:i.value==="on",optSelected:h.selected,getSetAttribute:a.className!=="t",submitBubbles:!0,changeBubbles:!0,focusinBubbles:!1,deleteExpando:!0,noCloneEvent:!0,inlineBlockNeedsLayout:!1,shrinkWrapBlocks:!1,reliableMarginRight:!0},i.checked=!0,k.noCloneChecked=i.cloneNode(!0).checked,g.disabled=!0,k.optDisabled=!h.disabled;try{delete a.test}catch(v){k.deleteExpando=!1}!a.addEventListener&&a.attachEvent&&a.fireEvent&&(a.attachEvent("onclick",function(){k.noCloneEvent=!1}),a.cloneNode(!0).fireEvent("onclick")),i=c.createElement("input"),i.value="t",i.setAttribute("type","radio"),k.radioValue=i.value==="t",i.setAttribute("checked","checked"),a.appendChild(i),l=c.createDocumentFragment(),l.appendChild(a.firstChild),k.checkClone=l.cloneNode(!0).cloneNode(!0).lastChild.checked,a.innerHTML="",a.style.width=a.style.paddingLeft="1px",m=c.getElementsByTagName("body")[0],o=c.createElement(m?"div":"body"),p={visibility:"hidden",width:0,height:0,border:0,margin:0},m&&f.extend(p,{position:"absolute",left:-1e3,top:-1e3});for(t in p)o.style[t]=p[t];o.appendChild(a),n=m||b,n.insertBefore(o,n.firstChild),k.appendChecked=i.checked,k.boxModel=a.offsetWidth===2,"zoom"in a.style&&(a.style.display="inline",a.style.zoom=1,k.inlineBlockNeedsLayout=a.offsetWidth===2,a.style.display="",a.innerHTML="<div style='width:4px;'></div>",k.shrinkWrapBlocks=a.offsetWidth!==2),a.innerHTML="<table><tr><td style='padding:0;border:0;display:none'></td><td>t</td></tr></table>",q=a.getElementsByTagName("td"),u=q[0].offsetHeight===0,q[0].style.display="",q[1].style.display="none",k.reliableHiddenOffsets=u&&q[0].offsetHeight===0,a.innerHTML="",c.defaultView&&c.defaultView.getComputedStyle&&(j=c.createElement("div"),j.style.width="0",j.style.marginRight="0",a.appendChild(j),k.reliableMarginRight=(parseInt((c.defaultView.getComputedStyle(j,null)||{marginRight:0}).marginRight,10)||0)===0),o.innerHTML="",n.removeChild(o);if(a.attachEvent)for(t in{submit:1,change:1,focusin:1})s="on"+t,u=s in a,u||(a.setAttribute(s,"return;"),u=typeof a[s]=="function"),k[t+"Bubbles"]=u;o=l=g=h=m=j=a=i=null;return k}(),f.boxModel=f.support.boxModel;var i=/^(?:\{.*\}|\[.*\])$/,j=/([a-z])([A-Z])/g;f.extend({cache:{},uuid:0,expando:"jQuery"+(f.fn.jquery+Math.random()).replace(/\D/g,""),noData:{embed:!0,object:"clsid:D27CDB6E-AE6D-11cf-96B8-444553540000",applet:!0},hasData:function(a){a=a.nodeType?f.cache[a[f.expando]]:a[f.expando];return!!a&&!l(a)},data:function(a,c,d,e){if(!!f.acceptData(a)){var g=f.expando,h=typeof c=="string",i,j=a.nodeType,k=j?f.cache:a,l=j?a[f.expando]:a[f.expando]&&f.expando;if((!l||e&&l&&!k[l][g])&&h&&d===b)return;l||(j?a[f.expando]=l=++f.uuid:l=f.expando),k[l]||(k[l]={},j||(k[l].toJSON=f.noop));if(typeof c=="object"||typeof c=="function")e?k[l][g]=f.extend(k[l][g],c):k[l]=f.extend(k[l],c);i=k[l],e&&(i[g]||(i[g]={}),i=i[g]),d!==b&&(i[f.camelCase(c)]=d);if(c==="events"&&!i[c])return i[g]&&i[g].events;return h?i[f.camelCase(c)]||i[c]:i}},removeData:function(b,c,d){if(!!f.acceptData(b)){var e=f.expando,g=b.nodeType,h=g?f.cache:b,i=g?b[f.expando]:f.expando;if(!h[i])return;if(c){var j=d?h[i][e]:h[i];if(j){delete j[c];if(!l(j))return}}if(d){delete h[i][e];if(!l(h[i]))return}var k=h[i][e];f.support.deleteExpando||h!=a?delete h[i]:h[i]=null,k?(h[i]={},g||(h[i].toJSON=f.noop),h[i][e]=k):g&&(f.support.deleteExpando?delete b[f.expando]:b.removeAttribute?b.removeAttribute(f.expando):b[f.expando]=null)}},_data:function(a,b,c){return f.data(a,b,c,!0)},acceptData:function(a){if(a.nodeName){var b=f.noData[a.nodeName.toLowerCase()];if(b)return b!==!0&&a.getAttribute("classid")===b}return!0}}),f.fn.extend({data:function(a,c){var d=null;if(typeof a=="undefined"){if(this.length){d=f.data(this[0]);if(this[0].nodeType===1){var e=this[0].attributes,g;for(var h=0,i=e.length;h<i;h++)g=e[h].name,g.indexOf("data-")===0&&(g=f.camelCase(g.substring(5)),k(this[0],g,d[g]))}}return d}if(typeof a=="object")return this.each(function(){f.data(this,a)});var j=a.split(".");j[1]=j[1]?"."+j[1]:"";if(c===b){d=this.triggerHandler("getData"+j[1]+"!",[j[0]]),d===b&&this.length&&(d=f.data(this[0],a),d=k(this[0],a,d));return d===b&&j[1]?this.data(j[0]):d}return this.each(function(){var b=f(this),d=[j[0],c];b.triggerHandler("setData"+j[1]+"!",d),f.data(this,a,c),b.triggerHandler("changeData"+j[1]+"!",d)})},removeData:function(a){return this.each(function(){f.removeData(this,a)})}}),f.extend({_mark:function(a,c){a&&(c=(c||"fx")+"mark",f.data(a,c,(f.data(a,c,b,!0)||0)+1,!0))},_unmark:function(a,c,d){a!==!0&&(d=c,c=a,a=!1);if(c){d=d||"fx";var e=d+"mark",g=a?0:(f.data(c,e,b,!0)||1)-1;g?f.data(c,e,g,!0):(f.removeData(c,e,!0),m(c,d,"mark"))}},queue:function(a,c,d){if(a){c=(c||"fx")+"queue";var e=f.data(a,c,b,!0);d&&(!e||f.isArray(d)?e=f.data(a,c,f.makeArray(d),!0):e.push(d));return e||[]}},dequeue:function(a,b){b=b||"fx";var c=f.queue(a,b),d=c.shift(),e;d==="inprogress"&&(d=c.shift()),d&&(b==="fx"&&c.unshift("inprogress"),d.call(a,function(){f.dequeue(a,b)})),c.length||(f.removeData(a,b+"queue",!0),m(a,b,"queue"))}}),f.fn.extend({queue:function(a,c){typeof a!="string"&&(c=a,a="fx");if(c===b)return f.queue(this[0],a);return this.each(function(){var b=f.queue(this,a,c);a==="fx"&&b[0]!=="inprogress"&&f.dequeue(this,a)})},dequeue:function(a){return this.each(function(){f.dequeue(this,a)})},delay:function(a,b){a=f.fx?f.fx.speeds[a]||a:a,b=b||"fx";return this.queue(b,function(){var c=this;setTimeout(function(){f.dequeue(c,b)},a)})},clearQueue:function(a){return this.queue(a||"fx",[])},promise:function(a,c){function m(){--h||d.resolveWith(e,[e])}typeof a!="string"&&(c=a,a=b),a=a||"fx";var d=f.Deferred(),e=this,g=e.length,h=1,i=a+"defer",j=a+"queue",k=a+"mark",l;while(g--)if(l=f.data(e[g],i,b,!0)||(f.data(e[g],j,b,!0)||f.data(e[g],k,b,!0))&&f.data(e[g],i,f._Deferred(),!0))h++,l.done(m);m();return d.promise()}});var n=/[\n\t\r]/g,o=/\s+/,p=/\r/g,q=/^(?:button|input)$/i,r=/^(?:button|input|object|select|textarea)$/i,s=/^a(?:rea)?$/i,t=/^(?:autofocus|autoplay|async|checked|controls|defer|disabled|hidden|loop|multiple|open|readonly|required|scoped|selected)$/i,u=/\:|^on/,v,w;f.fn.extend({attr:function(a,b){return f.access(this,a,b,!0,f.attr)},removeAttr:function(a){return this.each(function(){f.removeAttr(this,a)})},prop:function(a,b){return f.access(this,a,b,!0,f.prop)},removeProp:function(a){a=f.propFix[a]||a;return this.each(function(){try{this[a]=b,delete this[a]}catch(c){}})},addClass:function(a){var b,c,d,e,g,h,i;if(f.isFunction(a))return this.each(function(b){f(this).addClass(a.call(this,b,this.className))});if(a&&typeof a=="string"){b=a.split(o);for(c=0,d=this.length;c<d;c++){e=this[c];if(e.nodeType===1)if(!e.className&&b.length===1)e.className=a;else{g=" "+e.className+" ";for(h=0,i=b.length;h<i;h++)~g.indexOf(" "+b[h]+" ")||(g+=b[h]+" ");e.className=f.trim(g)}}}return this},removeClass:function(a){var c,d,e,g,h,i,j;if(f.isFunction(a))return this.each(function(b){f(this).removeClass(a.call(this,b,this.className))});if(a&&typeof a=="string"||a===b){c=(a||"").split(o);for(d=0,e=this.length;d<e;d++){g=this[d];if(g.nodeType===1&&g.className)if(a){h=(" "+g.className+" ").replace(n," ");for(i=0,j=c.length;i<j;i++)h=h.replace(" "+c[i]+" "," ");g.className=f.trim(h)}else g.className=""}}return this},toggleClass:function(a,b){var c=typeof a,d=typeof b=="boolean";if(f.isFunction(a))return this.each(function(c){f(this).toggleClass(a.call(this,c,this.className,b),b)});return this.each(function(){if(c==="string"){var e,g=0,h=f(this),i=b,j=a.split(o);while(e=j[g++])i=d?i:!h.hasClass(e),h[i?"addClass":"removeClass"](e)}else if(c==="undefined"||c==="boolean")this.className&&f._data(this,"__className__",this.className),this.className=this.className||a===!1?"":f._data(this,"__className__")||""})},hasClass:function(a){var b=" "+a+" ";for(var c=0,d=this.length;c<d;c++)if((" "+this[c].className+" ").replace(n," ").indexOf(b)>-1)return!0;return!1},val:function(a){var c,d,e=this[0];if(!arguments.length){if(e){c=f.valHooks[e.nodeName.toLowerCase()]||f.valHooks[e.type];if(c&&"get"in c&&(d=c.get(e,"value"))!==b)return d;d=e.value;return typeof d=="string"?d.replace(p,""):d==null?"":d}return b}var g=f.isFunction(a);return this.each(function(d){var e=f(this),h;if(this.nodeType===1){g?h=a.call(this,d,e.val()):h=a,h==null?h="":typeof h=="number"?h+="":f.isArray(h)&&(h=f.map(h,function(a){return a==null?"":a+""})),c=f.valHooks[this.nodeName.toLowerCase()]||f.valHooks[this.type];if(!c||!("set"in c)||c.set(this,h,"value")===b)this.value=h}})}}),f.extend({valHooks:{option:{get:function(a){var b=a.attributes.value;return!b||b.specified?a.value:a.text}},select:{get:function(a){var b,c=a.selectedIndex,d=[],e=a.options,g=a.type==="select-one";if(c<0)return null;for(var h=g?c:0,i=g?c+1:e.length;h<i;h++){var j=e[h];if(j.selected&&(f.support.optDisabled?!j.disabled:j.getAttribute("disabled")===null)&&(!j.parentNode.disabled||!f.nodeName(j.parentNode,"optgroup"))){b=f(j).val();if(g)return b;d.push(b)}}if(g&&!d.length&&e.length)return f(e[c]).val();return d},set:function(a,b){var c=f.makeArray(b);f(a).find("option").each(function(){this.selected=f.inArray(f(this).val(),c)>=0}),c.length||(a.selectedIndex=-1);return c}}},attrFn:{val:!0,css:!0,html:!0,text:!0,data:!0,width:!0,height:!0,offset:!0},attrFix:{tabindex:"tabIndex"},attr:function(a,c,d,e){var g=a.nodeType;if(!a||g===3||g===8||g===2)return b;if(e&&c in f.attrFn)return f(a)[c](d);if(!("getAttribute"in a))return f.prop(a,c,d);var h,i,j=g!==1||!f.isXMLDoc(a);j&&(c=f.attrFix[c]||c,i=f.attrHooks[c],i||(t.test(c)?i=w:v&&c!=="className"&&(f.nodeName(a,"form")||u.test(c))&&(i=v)));if(d!==b){if(d===null){f.removeAttr(a,c);return b}if(i&&"set"in i&&j&&(h=i.set(a,d,c))!==b)return h;a.setAttribute(c,""+d);return d}if(i&&"get"in i&&j&&(h=i.get(a,c))!==null)return h;h=a.getAttribute(c);return h===null?b:h},removeAttr:function(a,b){var c;a.nodeType===1&&(b=f.attrFix[b]||b,f.support.getSetAttribute?a.removeAttribute(b):(f.attr(a,b,""),a.removeAttributeNode(a.getAttributeNode(b))),t.test(b)&&(c=f.propFix[b]||b)in a&&(a[c]=!1))},attrHooks:{type:{set:function(a,b){if(q.test(a.nodeName)&&a.parentNode)f.error("type property can't be changed");else if(!f.support.radioValue&&b==="radio"&&f.nodeName(a,"input")){var c=a.value;a.setAttribute("type",b),c&&(a.value=c);return b}}},tabIndex:{get:function(a){var c=a.getAttributeNode("tabIndex");return c&&c.specified?parseInt(c.value,10):r.test(a.nodeName)||s.test(a.nodeName)&&a.href?0:b}},value:{get:function(a,b){if(v&&f.nodeName(a,"button"))return v.get(a,b);return b in a?a.value:null},set:function(a,b,c){if(v&&f.nodeName(a,"button"))return v.set(a,b,c);a.value=b}}},propFix:{tabindex:"tabIndex",readonly:"readOnly","for":"htmlFor","class":"className",maxlength:"maxLength",cellspacing:"cellSpacing",cellpadding:"cellPadding",rowspan:"rowSpan",colspan:"colSpan",usemap:"useMap",frameborder:"frameBorder",contenteditable:"contentEditable"},prop:function(a,c,d){var e=a.nodeType;if(!a||e===3||e===8||e===2)return b;var g,h,i=e!==1||!f.isXMLDoc(a);i&&(c=f.propFix[c]||c,h=f.propHooks[c]);return d!==b?h&&"set"in h&&(g=h.set(a,d,c))!==b?g:a[c]=d:h&&"get"in h&&(g=h.get(a,c))!==b?g:a[c]},propHooks:{}}),w={get:function(a,c){return f.prop(a,c)?c.toLowerCase():b},set:function(a,b,c){var d;b===!1?f.removeAttr(a,c):(d=f.propFix[c]||c,d in a&&(a[d]=!0),a.setAttribute(c,c.toLowerCase()));return c}},f.support.getSetAttribute||(f.attrFix=f.propFix,v=f.attrHooks.name=f.attrHooks.title=f.valHooks.button={get:function(a,c){var d;d=a.getAttributeNode(c);return d&&d.nodeValue!==""?d.nodeValue:b},set:function(a,b,c){var d=a.getAttributeNode(c);if(d){d.nodeValue=b;return b}}},f.each(["width","height"],function(a,b){f.attrHooks[b]=f.extend(f.attrHooks[b],{set:function(a,c){if(c===""){a.setAttribute(b,"auto");return c}}})})),f.support.hrefNormalized||f.each(["href","src","width","height"],function(a,c){f.attrHooks[c]=f.extend(f.attrHooks[c],{get:function(a){var d=a.getAttribute(c,2);return d===null?b:d}})}),f.support.style||(f.attrHooks.style={get:function(a){return a.style.cssText.toLowerCase()||b},set:function(a,b){return a.style.cssText=""+b}}),f.support.optSelected||(f.propHooks.selected=f.extend(f.propHooks.selected,{get:function(a){var b=a.parentNode;b&&(b.selectedIndex,b.parentNode&&b.parentNode.selectedIndex)}})),f.support.checkOn||f.each(["radio","checkbox"],function(){f.valHooks[this]={get:function(a){return a.getAttribute("value")===null?"on":a.value}}}),f.each(["radio","checkbox"],function(){f.valHooks[this]=f.extend(f.valHooks[this],{set:function(a,b){if(f.isArray(b))return a.checked=f.inArray(f(a).val(),b)>=0}})});var x=/\.(.*)$/,y=/^(?:textarea|input|select)$/i,z=/\./g,A=/ /g,B=/[^\w\s.|`]/g,C=function(a){return a.replace(B,"\\$&")};f.event={add:function(a,c,d,e){if(a.nodeType!==3&&a.nodeType!==8){if(d===!1)d=D;else if(!d)return;var g,h;d.handler&&(g=d,d=g.handler),d.guid||(d.guid=f.guid++);var i=f._data(a);if(!i)return;var j=i.events,k=i.handle;j||(i.events=j={}),k||(i.handle=k=function(a){return typeof f!="undefined"&&(!a||f.event.triggered!==a.type)?f.event.handle.apply(k.elem,arguments):b}),k.elem=a,c=c.split(" ");var l,m=0,n;while(l=c[m++]){h=g?f.extend({},g):{handler:d,data:e},l.indexOf(".")>-1?(n=l.split("."),l=n.shift(),h.namespace=n.slice(0).sort().join(".")):(n=[],h.namespace=""),h.type=l,h.guid||(h.guid=d.guid);var o=j[l],p=f.event.special[l]||{};if(!o){o=j[l]=[];if(!p.setup||p.setup.call(a,e,n,k)===!1)a.addEventListener?a.addEventListener(l,k,!1):a.attachEvent&&a.attachEvent("on"+l,k)}p.add&&(p.add.call(a,h),h.handler.guid||(h.handler.guid=d.guid)),o.push(h),f.event.global[l]=!0}a=null}},global:{},remove:function(a,c,d,e){if(a.nodeType!==3&&a.nodeType!==8){d===!1&&(d=D);var g,h,i,j,k=0,l,m,n,o,p,q,r,s=f.hasData(a)&&f._data(a),t=s&&s.events;if(!s||!t)return;c&&c.type&&(d=c.handler,c=c.type);if(!c||typeof c=="string"&&c.charAt(0)==="."){c=c||"";for(h in t)f.event.remove(a,h+c);return}c=c.split(" ");while(h=c[k++]){r=h,q=null,l=h.indexOf(".")<0,m=[],l||(m=h.split("."),h=m.shift(),n=new RegExp("(^|\\.)"+f.map(m.slice(0).sort(),C).join("\\.(?:.*\\.)?")+"(\\.|$)")),p=t[h];if(!p)continue;if(!d){for(j=0;j<p.length;j++){q=p[j];if(l||n.test(q.namespace))f.event.remove(a,r,q.handler,j),p.splice(j--,1)}continue}o=f.event.special[h]||{};for(j=e||0;j<p.length;j++){q=p[j];if(d.guid===q.guid){if(l||n.test(q.namespace))e==null&&p.splice(j--,1),o.remove&&o.remove.call(a,q);if(e!=null)break}}if(p.length===0||e!=null&&p.length===1)(!o.teardown||o.teardown.call(a,m)===!1)&&f.removeEvent(a,h,s.handle),g=null,delete t[h]}if(f.isEmptyObject(t)){var u=s.handle;u&&(u.elem=null),delete s.events,delete s.handle,f.isEmptyObject(s)&&f.removeData(a,b,!0)}}},customEvent:{getData:!0,setData:!0,changeData:!0},trigger:function(c,d,e,g){var h=c.type||c,i=[],j;h.indexOf("!")>=0&&(h=h.slice(0,-1),j=!0),h.indexOf(".")>=0&&(i=h.split("."),h=i. +shift(),i.sort());if(!!e&&!f.event.customEvent[h]||!!f.event.global[h]){c=typeof c=="object"?c[f.expando]?c:new f.Event(h,c):new f.Event(h),c.type=h,c.exclusive=j,c.namespace=i.join("."),c.namespace_re=new RegExp("(^|\\.)"+i.join("\\.(?:.*\\.)?")+"(\\.|$)");if(g||!e)c.preventDefault(),c.stopPropagation();if(!e){f.each(f.cache,function(){var a=f.expando,b=this[a];b&&b.events&&b.events[h]&&f.event.trigger(c,d,b.handle.elem)});return}if(e.nodeType===3||e.nodeType===8)return;c.result=b,c.target=e,d=d!=null?f.makeArray(d):[],d.unshift(c);var k=e,l=h.indexOf(":")<0?"on"+h:"";do{var m=f._data(k,"handle");c.currentTarget=k,m&&m.apply(k,d),l&&f.acceptData(k)&&k[l]&&k[l].apply(k,d)===!1&&(c.result=!1,c.preventDefault()),k=k.parentNode||k.ownerDocument||k===c.target.ownerDocument&&a}while(k&&!c.isPropagationStopped());if(!c.isDefaultPrevented()){var n,o=f.event.special[h]||{};if((!o._default||o._default.call(e.ownerDocument,c)===!1)&&(h!=="click"||!f.nodeName(e,"a"))&&f.acceptData(e)){try{l&&e[h]&&(n=e[l],n&&(e[l]=null),f.event.triggered=h,e[h]())}catch(p){}n&&(e[l]=n),f.event.triggered=b}}return c.result}},handle:function(c){c=f.event.fix(c||a.event);var d=((f._data(this,"events")||{})[c.type]||[]).slice(0),e=!c.exclusive&&!c.namespace,g=Array.prototype.slice.call(arguments,0);g[0]=c,c.currentTarget=this;for(var h=0,i=d.length;h<i;h++){var j=d[h];if(e||c.namespace_re.test(j.namespace)){c.handler=j.handler,c.data=j.data,c.handleObj=j;var k=j.handler.apply(this,g);k!==b&&(c.result=k,k===!1&&(c.preventDefault(),c.stopPropagation()));if(c.isImmediatePropagationStopped())break}}return c.result},props:"altKey attrChange attrName bubbles button cancelable charCode clientX clientY ctrlKey currentTarget data detail eventPhase fromElement handler keyCode layerX layerY metaKey newValue offsetX offsetY pageX pageY prevValue relatedNode relatedTarget screenX screenY shiftKey srcElement target toElement view wheelDelta which".split(" "),fix:function(a){if(a[f.expando])return a;var d=a;a=f.Event(d);for(var e=this.props.length,g;e;)g=this.props[--e],a[g]=d[g];a.target||(a.target=a.srcElement||c),a.target.nodeType===3&&(a.target=a.target.parentNode),!a.relatedTarget&&a.fromElement&&(a.relatedTarget=a.fromElement===a.target?a.toElement:a.fromElement);if(a.pageX==null&&a.clientX!=null){var h=a.target.ownerDocument||c,i=h.documentElement,j=h.body;a.pageX=a.clientX+(i&&i.scrollLeft||j&&j.scrollLeft||0)-(i&&i.clientLeft||j&&j.clientLeft||0),a.pageY=a.clientY+(i&&i.scrollTop||j&&j.scrollTop||0)-(i&&i.clientTop||j&&j.clientTop||0)}a.which==null&&(a.charCode!=null||a.keyCode!=null)&&(a.which=a.charCode!=null?a.charCode:a.keyCode),!a.metaKey&&a.ctrlKey&&(a.metaKey=a.ctrlKey),!a.which&&a.button!==b&&(a.which=a.button&1?1:a.button&2?3:a.button&4?2:0);return a},guid:1e8,proxy:f.proxy,special:{ready:{setup:f.bindReady,teardown:f.noop},live:{add:function(a){f.event.add(this,N(a.origType,a.selector),f.extend({},a,{handler:M,guid:a.handler.guid}))},remove:function(a){f.event.remove(this,N(a.origType,a.selector),a)}},beforeunload:{setup:function(a,b,c){f.isWindow(this)&&(this.onbeforeunload=c)},teardown:function(a,b){this.onbeforeunload===b&&(this.onbeforeunload=null)}}}},f.removeEvent=c.removeEventListener?function(a,b,c){a.removeEventListener&&a.removeEventListener(b,c,!1)}:function(a,b,c){a.detachEvent&&a.detachEvent("on"+b,c)},f.Event=function(a,b){if(!this.preventDefault)return new f.Event(a,b);a&&a.type?(this.originalEvent=a,this.type=a.type,this.isDefaultPrevented=a.defaultPrevented||a.returnValue===!1||a.getPreventDefault&&a.getPreventDefault()?E:D):this.type=a,b&&f.extend(this,b),this.timeStamp=f.now(),this[f.expando]=!0},f.Event.prototype={preventDefault:function(){this.isDefaultPrevented=E;var a=this.originalEvent;!a||(a.preventDefault?a.preventDefault():a.returnValue=!1)},stopPropagation:function(){this.isPropagationStopped=E;var a=this.originalEvent;!a||(a.stopPropagation&&a.stopPropagation(),a.cancelBubble=!0)},stopImmediatePropagation:function(){this.isImmediatePropagationStopped=E,this.stopPropagation()},isDefaultPrevented:D,isPropagationStopped:D,isImmediatePropagationStopped:D};var F=function(a){var b=a.relatedTarget,c=!1,d=a.type;a.type=a.data,b!==this&&(b&&(c=f.contains(this,b)),c||(f.event.handle.apply(this,arguments),a.type=d))},G=function(a){a.type=a.data,f.event.handle.apply(this,arguments)};f.each({mouseenter:"mouseover",mouseleave:"mouseout"},function(a,b){f.event.special[a]={setup:function(c){f.event.add(this,b,c&&c.selector?G:F,a)},teardown:function(a){f.event.remove(this,b,a&&a.selector?G:F)}}}),f.support.submitBubbles||(f.event.special.submit={setup:function(a,b){if(!f.nodeName(this,"form"))f.event.add(this,"click.specialSubmit",function(a){var b=a.target,c=b.type;(c==="submit"||c==="image")&&f(b).closest("form").length&&K("submit",this,arguments)}),f.event.add(this,"keypress.specialSubmit",function(a){var b=a.target,c=b.type;(c==="text"||c==="password")&&f(b).closest("form").length&&a.keyCode===13&&K("submit",this,arguments)});else return!1},teardown:function(a){f.event.remove(this,".specialSubmit")}});if(!f.support.changeBubbles){var H,I=function(a){var b=a.type,c=a.value;b==="radio"||b==="checkbox"?c=a.checked:b==="select-multiple"?c=a.selectedIndex>-1?f.map(a.options,function(a){return a.selected}).join("-"):"":f.nodeName(a,"select")&&(c=a.selectedIndex);return c},J=function(c){var d=c.target,e,g;if(!!y.test(d.nodeName)&&!d.readOnly){e=f._data(d,"_change_data"),g=I(d),(c.type!=="focusout"||d.type!=="radio")&&f._data(d,"_change_data",g);if(e===b||g===e)return;if(e!=null||g)c.type="change",c.liveFired=b,f.event.trigger(c,arguments[1],d)}};f.event.special.change={filters:{focusout:J,beforedeactivate:J,click:function(a){var b=a.target,c=f.nodeName(b,"input")?b.type:"";(c==="radio"||c==="checkbox"||f.nodeName(b,"select"))&&J.call(this,a)},keydown:function(a){var b=a.target,c=f.nodeName(b,"input")?b.type:"";(a.keyCode===13&&!f.nodeName(b,"textarea")||a.keyCode===32&&(c==="checkbox"||c==="radio")||c==="select-multiple")&&J.call(this,a)},beforeactivate:function(a){var b=a.target;f._data(b,"_change_data",I(b))}},setup:function(a,b){if(this.type==="file")return!1;for(var c in H)f.event.add(this,c+".specialChange",H[c]);return y.test(this.nodeName)},teardown:function(a){f.event.remove(this,".specialChange");return y.test(this.nodeName)}},H=f.event.special.change.filters,H.focus=H.beforeactivate}f.support.focusinBubbles||f.each({focus:"focusin",blur:"focusout"},function(a,b){function e(a){var c=f.event.fix(a);c.type=b,c.originalEvent={},f.event.trigger(c,null,c.target),c.isDefaultPrevented()&&a.preventDefault()}var d=0;f.event.special[b]={setup:function(){d++===0&&c.addEventListener(a,e,!0)},teardown:function(){--d===0&&c.removeEventListener(a,e,!0)}}}),f.each(["bind","one"],function(a,c){f.fn[c]=function(a,d,e){var g;if(typeof a=="object"){for(var h in a)this[c](h,d,a[h],e);return this}if(arguments.length===2||d===!1)e=d,d=b;c==="one"?(g=function(a){f(this).unbind(a,g);return e.apply(this,arguments)},g.guid=e.guid||f.guid++):g=e;if(a==="unload"&&c!=="one")this.one(a,d,e);else for(var i=0,j=this.length;i<j;i++)f.event.add(this[i],a,g,d);return this}}),f.fn.extend({unbind:function(a,b){if(typeof a=="object"&&!a.preventDefault)for(var c in a)this.unbind(c,a[c]);else for(var d=0,e=this.length;d<e;d++)f.event.remove(this[d],a,b);return this},delegate:function(a,b,c,d){return this.live(b,c,d,a)},undelegate:function(a,b,c){return arguments.length===0?this.unbind("live"):this.die(b,null,c,a)},trigger:function(a,b){return this.each(function(){f.event.trigger(a,b,this)})},triggerHandler:function(a,b){if(this[0])return f.event.trigger(a,b,this[0],!0)},toggle:function(a){var b=arguments,c=a.guid||f.guid++,d=0,e=function(c){var e=(f.data(this,"lastToggle"+a.guid)||0)%d;f.data(this,"lastToggle"+a.guid,e+1),c.preventDefault();return b[e].apply(this,arguments)||!1};e.guid=c;while(d<b.length)b[d++].guid=c;return this.click(e)},hover:function(a,b){return this.mouseenter(a).mouseleave(b||a)}});var L={focus:"focusin",blur:"focusout",mouseenter:"mouseover",mouseleave:"mouseout"};f.each(["live","die"],function(a,c){f.fn[c]=function(a,d,e,g){var h,i=0,j,k,l,m=g||this.selector,n=g?this:f(this.context);if(typeof a=="object"&&!a.preventDefault){for(var o in a)n[c](o,d,a[o],m);return this}if(c==="die"&&!a&&g&&g.charAt(0)==="."){n.unbind(g);return this}if(d===!1||f.isFunction(d))e=d||D,d=b;a=(a||"").split(" ");while((h=a[i++])!=null){j=x.exec(h),k="",j&&(k=j[0],h=h.replace(x,""));if(h==="hover"){a.push("mouseenter"+k,"mouseleave"+k);continue}l=h,L[h]?(a.push(L[h]+k),h=h+k):h=(L[h]||h)+k;if(c==="live")for(var p=0,q=n.length;p<q;p++)f.event.add(n[p],"live."+N(h,m),{data:d,selector:m,handler:e,origType:h,origHandler:e,preType:l});else n.unbind("live."+N(h,m),e)}return this}}),f.each("blur focus focusin focusout load resize scroll unload click dblclick mousedown mouseup mousemove mouseover mouseout mouseenter mouseleave change select submit keydown keypress keyup error".split(" "),function(a,b){f.fn[b]=function(a,c){c==null&&(c=a,a=null);return arguments.length>0?this.bind(b,a,c):this.trigger(b)},f.attrFn&&(f.attrFn[b]=!0)}),function(){function u(a,b,c,d,e,f){for(var g=0,h=d.length;g<h;g++){var i=d[g];if(i){var j=!1;i=i[a];while(i){if(i.sizcache===c){j=d[i.sizset];break}if(i.nodeType===1){f||(i.sizcache=c,i.sizset=g);if(typeof b!="string"){if(i===b){j=!0;break}}else if(k.filter(b,[i]).length>0){j=i;break}}i=i[a]}d[g]=j}}}function t(a,b,c,d,e,f){for(var g=0,h=d.length;g<h;g++){var i=d[g];if(i){var j=!1;i=i[a];while(i){if(i.sizcache===c){j=d[i.sizset];break}i.nodeType===1&&!f&&(i.sizcache=c,i.sizset=g);if(i.nodeName.toLowerCase()===b){j=i;break}i=i[a]}d[g]=j}}}var a=/((?:\((?:\([^()]+\)|[^()]+)+\)|\[(?:\[[^\[\]]*\]|['"][^'"]*['"]|[^\[\]'"]+)+\]|\\.|[^ >+~,(\[\\]+)+|[>+~])(\s*,\s*)?((?:.|\r|\n)*)/g,d=0,e=Object.prototype.toString,g=!1,h=!0,i=/\\/g,j=/\W/;[0,0].sort(function(){h=!1;return 0});var k=function(b,d,f,g){f=f||[],d=d||c;var h=d;if(d.nodeType!==1&&d.nodeType!==9)return[];if(!b||typeof b!="string")return f;var i,j,n,o,q,r,s,t,u=!0,w=k.isXML(d),x=[],y=b;do{a.exec(""),i=a.exec(y);if(i){y=i[3],x.push(i[1]);if(i[2]){o=i[3];break}}}while(i);if(x.length>1&&m.exec(b))if(x.length===2&&l.relative[x[0]])j=v(x[0]+x[1],d);else{j=l.relative[x[0]]?[d]:k(x.shift(),d);while(x.length)b=x.shift(),l.relative[b]&&(b+=x.shift()),j=v(b,j)}else{!g&&x.length>1&&d.nodeType===9&&!w&&l.match.ID.test(x[0])&&!l.match.ID.test(x[x.length-1])&&(q=k.find(x.shift(),d,w),d=q.expr?k.filter(q.expr,q.set)[0]:q.set[0]);if(d){q=g?{expr:x.pop(),set:p(g)}:k.find(x.pop(),x.length===1&&(x[0]==="~"||x[0]==="+")&&d.parentNode?d.parentNode:d,w),j=q.expr?k.filter(q.expr,q.set):q.set,x.length>0?n=p(j):u=!1;while(x.length)r=x.pop(),s=r,l.relative[r]?s=x.pop():r="",s==null&&(s=d),l.relative[r](n,s,w)}else n=x=[]}n||(n=j),n||k.error(r||b);if(e.call(n)==="[object Array]")if(!u)f.push.apply(f,n);else if(d&&d.nodeType===1)for(t=0;n[t]!=null;t++)n[t]&&(n[t]===!0||n[t].nodeType===1&&k.contains(d,n[t]))&&f.push(j[t]);else for(t=0;n[t]!=null;t++)n[t]&&n[t].nodeType===1&&f.push(j[t]);else p(n,f);o&&(k(o,h,f,g),k.uniqueSort(f));return f};k.uniqueSort=function(a){if(r){g=h,a.sort(r);if(g)for(var b=1;b<a.length;b++)a[b]===a[b-1]&&a.splice(b--,1)}return a},k.matches=function(a,b){return k(a,null,null,b)},k.matchesSelector=function(a,b){return k(b,null,null,[a]).length>0},k.find=function(a,b,c){var d;if(!a)return[];for(var e=0,f=l.order.length;e<f;e++){var g,h=l.order[e];if(g=l.leftMatch[h].exec(a)){var j=g[1];g.splice(1,1);if(j.substr(j.length-1)!=="\\"){g[1]=(g[1]||"").replace(i,""),d=l.find[h](g,b,c);if(d!=null){a=a.replace(l.match[h],"");break}}}}d||(d=typeof b.getElementsByTagName!="undefined"?b.getElementsByTagName("*"):[]);return{set:d,expr:a}},k.filter=function(a,c,d,e){var f,g,h=a,i=[],j=c,m=c&&c[0]&&k.isXML(c[0]);while(a&&c.length){for(var n in l.filter)if((f=l.leftMatch[n].exec(a))!=null&&f[2]){var o,p,q=l.filter[n],r=f[1];g=!1,f.splice(1,1);if(r.substr(r.length-1)==="\\")continue;j===i&&(i=[]);if(l.preFilter[n]){f=l.preFilter[n](f,j,d,i,e,m);if(!f)g=o=!0;else if(f===!0)continue}if(f)for(var s=0;(p=j[s])!=null;s++)if(p){o=q(p,f,s,j);var t=e^!!o;d&&o!=null?t?g=!0:j[s]=!1:t&&(i.push(p),g=!0)}if(o!==b){d||(j=i),a=a.replace(l.match[n],"");if(!g)return[];break}}if(a===h)if(g==null)k.error(a);else break;h=a}return j},k.error=function(a){throw"Syntax error, unrecognized expression: "+a};var l=k.selectors={order:["ID","NAME","TAG"],match:{ID:/#((?:[\w\u00c0-\uFFFF\-]|\\.)+)/,CLASS:/\.((?:[\w\u00c0-\uFFFF\-]|\\.)+)/,NAME:/\[name=['"]*((?:[\w\u00c0-\uFFFF\-]|\\.)+)['"]*\]/,ATTR:/\[\s*((?:[\w\u00c0-\uFFFF\-]|\\.)+)\s*(?:(\S?=)\s*(?:(['"])(.*?)\3|(#?(?:[\w\u00c0-\uFFFF\-]|\\.)*)|)|)\s*\]/,TAG:/^((?:[\w\u00c0-\uFFFF\*\-]|\\.)+)/,CHILD:/:(only|nth|last|first)-child(?:\(\s*(even|odd|(?:[+\-]?\d+|(?:[+\-]?\d*)?n\s*(?:[+\-]\s*\d+)?))\s*\))?/,POS:/:(nth|eq|gt|lt|first|last|even|odd)(?:\((\d*)\))?(?=[^\-]|$)/,PSEUDO:/:((?:[\w\u00c0-\uFFFF\-]|\\.)+)(?:\((['"]?)((?:\([^\)]+\)|[^\(\)]*)+)\2\))?/},leftMatch:{},attrMap:{"class":"className","for":"htmlFor"},attrHandle:{href:function(a){return a.getAttribute("href")},type:function(a){return a.getAttribute("type")}},relative:{"+":function(a,b){var c=typeof b=="string",d=c&&!j.test(b),e=c&&!d;d&&(b=b.toLowerCase());for(var f=0,g=a.length,h;f<g;f++)if(h=a[f]){while((h=h.previousSibling)&&h.nodeType!==1);a[f]=e||h&&h.nodeName.toLowerCase()===b?h||!1:h===b}e&&k.filter(b,a,!0)},">":function(a,b){var c,d=typeof b=="string",e=0,f=a.length;if(d&&!j.test(b)){b=b.toLowerCase();for(;e<f;e++){c=a[e];if(c){var g=c.parentNode;a[e]=g.nodeName.toLowerCase()===b?g:!1}}}else{for(;e<f;e++)c=a[e],c&&(a[e]=d?c.parentNode:c.parentNode===b);d&&k.filter(b,a,!0)}},"":function(a,b,c){var e,f=d++,g=u;typeof b=="string"&&!j.test(b)&&(b=b.toLowerCase(),e=b,g=t),g("parentNode",b,f,a,e,c)},"~":function(a,b,c){var e,f=d++,g=u;typeof b=="string"&&!j.test(b)&&(b=b.toLowerCase(),e=b,g=t),g("previousSibling",b,f,a,e,c)}},find:{ID:function(a,b,c){if(typeof b.getElementById!="undefined"&&!c){var d=b.getElementById(a[1]);return d&&d.parentNode?[d]:[]}},NAME:function(a,b){if(typeof b.getElementsByName!="undefined"){var c=[],d=b.getElementsByName(a[1]);for(var e=0,f=d.length;e<f;e++)d[e].getAttribute("name")===a[1]&&c.push(d[e]);return c.length===0?null:c}},TAG:function(a,b){if(typeof b.getElementsByTagName!="undefined")return b.getElementsByTagName(a[1])}},preFilter:{CLASS:function(a,b,c,d,e,f){a=" "+a[1].replace(i,"")+" ";if(f)return a;for(var g=0,h;(h=b[g])!=null;g++)h&&(e^(h.className&&(" "+h.className+" ").replace(/[\t\n\r]/g," ").indexOf(a)>=0)?c||d.push(h):c&&(b[g]=!1));return!1},ID:function(a){return a[1].replace(i,"")},TAG:function(a,b){return a[1].replace(i,"").toLowerCase()},CHILD:function(a){if(a[1]==="nth"){a[2]||k.error(a[0]),a[2]=a[2].replace(/^\+|\s*/g,"");var b=/(-?)(\d*)(?:n([+\-]?\d*))?/.exec(a[2]==="even"&&"2n"||a[2]==="odd"&&"2n+1"||!/\D/.test(a[2])&&"0n+"+a[2]||a[2]);a[2]=b[1]+(b[2]||1)-0,a[3]=b[3]-0}else a[2]&&k.error(a[0]);a[0]=d++;return a},ATTR:function(a,b,c,d,e,f){var g=a[1]=a[1].replace(i,"");!f&&l.attrMap[g]&&(a[1]=l.attrMap[g]),a[4]=(a[4]||a[5]||"").replace(i,""),a[2]==="~="&&(a[4]=" "+a[4]+" ");return a},PSEUDO:function(b,c,d,e,f){if(b[1]==="not")if((a.exec(b[3])||"").length>1||/^\w/.test(b[3]))b[3]=k(b[3],null,null,c);else{var g=k.filter(b[3],c,d,!0^f);d||e.push.apply(e,g);return!1}else if(l.match.POS.test(b[0])||l.match.CHILD.test(b[0]))return!0;return b},POS:function(a){a.unshift(!0);return a}},filters:{enabled:function(a){return a.disabled===!1&&a.type!=="hidden"},disabled:function(a){return a.disabled===!0},checked:function(a){return a.checked===!0},selected:function(a){a.parentNode&&a.parentNode.selectedIndex;return a.selected===!0},parent:function(a){return!!a.firstChild},empty:function(a){return!a.firstChild},has:function(a,b,c){return!!k(c[3],a).length},header:function(a){return/h\d/i.test(a.nodeName)},text:function(a){var b=a.getAttribute("type"),c=a.type;return a.nodeName.toLowerCase()==="input"&&"text"===c&&(b===c||b===null)},radio:function(a){return a.nodeName.toLowerCase()==="input"&&"radio"===a.type},checkbox:function(a){return a.nodeName.toLowerCase()==="input"&&"checkbox"===a.type},file:function(a){return a.nodeName.toLowerCase()==="input"&&"file"===a.type},password:function(a){return a.nodeName.toLowerCase()==="input"&&"password"===a.type},submit:function(a){var b=a.nodeName.toLowerCase();return(b==="input"||b==="button")&&"submit"===a.type},image:function(a){return a.nodeName.toLowerCase()==="input"&&"image"===a.type},reset:function(a){var b=a.nodeName.toLowerCase();return(b==="input"||b==="button")&&"reset"===a.type},button:function(a){var b=a.nodeName.toLowerCase();return b==="input"&&"button"===a.type||b==="button"},input:function(a){return/input|select|textarea|button/i.test(a.nodeName)},focus:function(a){return a===a.ownerDocument.activeElement}},setFilters:{first:function(a,b){return b===0},last:function(a,b,c,d){return b===d.length-1},even:function(a,b){return b%2===0},odd:function(a,b){return b%2===1},lt:function(a,b,c){return b<c[3]-0},gt:function(a,b,c){return b>c[3]-0},nth:function(a,b,c){return c[3]-0===b},eq:function(a,b,c){return c[3]-0===b}},filter:{PSEUDO:function(a,b,c,d){var e=b[1],f=l.filters[e];if(f)return f(a,c,b,d);if(e==="contains")return(a.textContent||a.innerText||k.getText([a])||"").indexOf(b[3])>=0;if(e==="not"){var g=b[3];for(var h=0,i=g.length;h<i;h++)if(g[h]===a)return!1;return!0}k.error(e)},CHILD:function(a,b){var c=b[1],d=a;switch(c){case"only":case"first":while(d=d.previousSibling)if(d.nodeType===1)return!1;if(c==="first")return!0;d=a;case"last":while(d=d.nextSibling)if(d.nodeType===1)return!1;return!0;case"nth":var e=b[2],f=b[3];if(e===1&&f===0)return!0;var g=b[0],h=a.parentNode;if(h&&(h.sizcache!==g||!a.nodeIndex)){var i=0;for(d=h.firstChild;d;d=d.nextSibling)d.nodeType===1&&(d.nodeIndex=++i);h.sizcache=g}var j=a.nodeIndex-f;return e===0?j===0:j%e===0&&j/e>=0}},ID:function(a,b){return a.nodeType===1&&a.getAttribute("id")===b},TAG:function(a,b){return b==="*"&&a.nodeType===1||a.nodeName.toLowerCase()===b},CLASS:function(a,b){return(" "+(a.className||a.getAttribute("class"))+" ").indexOf(b)>-1},ATTR:function(a,b){var c=b[1],d=l.attrHandle[c]?l.attrHandle[c](a):a[c]!=null?a[c]:a.getAttribute(c),e=d+"",f=b[2],g=b[4];return d==null?f==="!=":f==="="?e===g:f==="*="?e.indexOf(g)>=0:f==="~="?(" "+e+" ").indexOf(g)>=0:g?f==="!="?e!==g:f==="^="?e.indexOf(g)===0:f==="$="?e.substr(e.length-g.length)===g:f==="|="?e===g||e.substr(0,g.length+1)===g+"-":!1:e&&d!==!1},POS:function(a,b,c,d){var e=b[2],f=l.setFilters[e];if(f)return f(a,c,b,d)}}},m=l.match.POS,n=function(a,b){return"\\"+(b-0+1)};for(var o in l.match)l.match[o]=new RegExp(l.match[o].source+/(?![^\[]*\])(?![^\(]*\))/.source),l.leftMatch[o]=new RegExp(/(^(?:.|\r|\n)*?)/.source+l.match[o].source.replace(/\\(\d+)/g,n));var p=function(a,b){a=Array.prototype.slice.call(a,0);if(b){b.push.apply(b,a);return b}return a};try{Array.prototype.slice.call(c.documentElement.childNodes,0)[0].nodeType}catch(q){p=function(a,b){var c=0,d=b||[];if(e.call(a)==="[object Array]")Array.prototype.push.apply(d,a);else if(typeof a.length=="number")for(var f=a.length;c<f;c++)d.push(a[c]);else for(;a[c];c++)d.push(a[c]);return d}}var r,s;c.documentElement.compareDocumentPosition?r=function(a,b){if(a===b){g=!0;return 0}if(!a.compareDocumentPosition||!b.compareDocumentPosition)return a.compareDocumentPosition?-1:1;return a.compareDocumentPosition(b)&4?-1:1}:(r=function(a,b){if(a===b){g=!0;return 0}if(a.sourceIndex&&b.sourceIndex)return a.sourceIndex-b.sourceIndex;var c,d,e=[],f=[],h=a.parentNode,i=b.parentNode,j=h;if(h===i)return s(a,b);if(!h)return-1;if(!i)return 1;while(j)e.unshift(j),j=j.parentNode;j=i;while(j)f.unshift(j),j=j.parentNode;c=e.length,d=f.length;for(var k=0;k<c&&k<d;k++)if(e[k]!==f[k])return s(e[k],f[k]);return k===c?s(a,f[k],-1):s(e[k],b,1)},s=function(a,b,c){if(a===b)return c;var d=a.nextSibling;while(d){if(d===b)return-1;d=d.nextSibling}return 1}),k.getText=function(a){var b="",c;for(var d=0;a[d];d++)c=a[d],c.nodeType===3||c.nodeType===4?b+=c.nodeValue:c.nodeType!==8&&(b+=k.getText(c.childNodes));return b},function(){var a=c.createElement("div"),d="script"+(new Date).getTime(),e=c.documentElement;a.innerHTML="<a name='"+d+"'/>",e.insertBefore(a,e.firstChild),c.getElementById(d)&&(l.find.ID=function(a,c,d){if(typeof c.getElementById!="undefined"&&!d){var e=c.getElementById(a[1]);return e?e.id===a[1]||typeof e.getAttributeNode!="undefined"&&e.getAttributeNode("id").nodeValue===a[1]?[e]:b:[]}},l.filter.ID=function(a,b){var c=typeof a.getAttributeNode!="undefined"&&a.getAttributeNode("id");return a.nodeType===1&&c&&c.nodeValue===b}),e.removeChild(a),e=a=null}(),function(){var a=c.createElement("div");a.appendChild(c.createComment("")),a.getElementsByTagName("*").length>0&&(l.find.TAG=function(a,b){var c=b.getElementsByTagName(a[1]);if(a[1]==="*"){var d=[];for(var e=0;c[e];e++)c[e].nodeType===1&&d.push(c[e]);c=d}return c}),a.innerHTML="<a href='#'></a>",a.firstChild&&typeof a.firstChild.getAttribute!="undefined"&&a.firstChild.getAttribute("href")!=="#"&&(l.attrHandle.href=function(a){return a.getAttribute("href",2)}),a=null}(),c.querySelectorAll&&function(){var a=k,b=c.createElement("div"),d="__sizzle__";b.innerHTML="<p class='TEST'></p>";if(!b.querySelectorAll||b.querySelectorAll(".TEST").length!==0){k=function(b,e,f,g){e=e||c;if(!g&&!k.isXML(e)){var h=/^(\w+$)|^\.([\w\-]+$)|^#([\w\-]+$)/.exec(b);if(h&&(e.nodeType===1||e.nodeType===9)){if(h[1])return p(e.getElementsByTagName(b),f);if(h[2]&&l.find.CLASS&&e.getElementsByClassName)return p(e.getElementsByClassName(h[2]),f)}if(e.nodeType===9){if(b==="body"&&e.body)return p([e.body],f);if(h&&h[3]){var i=e.getElementById(h[3]);if(!i||!i.parentNode)return p([],f);if(i.id===h[3])return p([i],f)}try{return p(e.querySelectorAll(b),f)}catch(j){}}else if(e.nodeType===1&&e.nodeName.toLowerCase()!=="object"){var m=e,n=e.getAttribute("id"),o=n||d,q=e.parentNode,r=/^\s*[+~]/.test(b);n?o=o.replace(/'/g,"\\$&"):e.setAttribute("id",o),r&&q&&(e=e.parentNode);try{if(!r||q)return p(e.querySelectorAll("[id='"+o+"'] "+b),f)}catch(s){}finally{n||m.removeAttribute("id")}}}return a(b,e,f,g)};for(var e in a)k[e]=a[e];b=null}}(),function(){var a=c.documentElement,b=a.matchesSelector||a.mozMatchesSelector||a.webkitMatchesSelector||a.msMatchesSelector;if(b){var d=!b.call(c.createElement("div"),"div"),e=!1;try{b.call(c.documentElement,"[test!='']:sizzle")}catch(f){e=!0}k.matchesSelector=function(a,c){c=c.replace(/\=\s*([^'"\]]*)\s*\]/g,"='$1']");if(!k.isXML(a))try{if(e||!l.match.PSEUDO.test(c)&&!/!=/.test(c)){var f=b.call(a,c);if(f||!d||a.document&&a.document.nodeType!==11)return f}}catch(g){}return k(c,null,null,[a]).length>0}}}(),function(){var a=c.createElement("div");a.innerHTML="<div class='test e'></div><div class='test'></div>";if(!!a.getElementsByClassName&&a.getElementsByClassName("e").length!==0){a.lastChild.className="e";if(a.getElementsByClassName("e").length===1)return;l.order.splice(1,0,"CLASS"),l.find.CLASS=function(a,b,c){if(typeof b.getElementsByClassName!="undefined"&&!c)return b.getElementsByClassName(a[1])},a=null}}(),c.documentElement.contains?k.contains=function(a,b){return a!==b&&(a.contains?a.contains(b):!0)}:c.documentElement.compareDocumentPosition?k.contains=function(a,b){return!!(a.compareDocumentPosition(b)&16)}:k.contains=function(){return!1},k.isXML=function(a){var b=(a?a.ownerDocument||a:0).documentElement;return b?b.nodeName!=="HTML":!1};var v=function(a,b){var c,d=[],e="",f=b.nodeType?[b]:b;while(c=l.match.PSEUDO.exec(a))e+=c[0],a=a.replace(l.match.PSEUDO,"");a=l.relative[a]?a+"*":a;for(var g=0,h=f.length;g<h;g++)k(a,f[g],d);return k.filter(e,d)};f.find=k,f.expr=k.selectors,f.expr[":"]=f.expr.filters,f.unique=k.uniqueSort,f.text=k.getText,f.isXMLDoc=k.isXML,f.contains=k.contains}();var O=/Until$/,P=/^(?:parents|prevUntil|prevAll)/,Q=/,/,R=/^.[^:#\[\.,]*$/,S=Array.prototype.slice,T=f.expr.match.POS,U={children:!0,contents:!0,next:!0,prev:!0};f.fn.extend({find:function(a){var b=this,c,d;if(typeof a!="string")return f(a).filter(function(){for(c=0,d=b.length;c<d;c++)if(f.contains(b[c],this))return!0});var e=this.pushStack("","find",a),g,h,i;for(c=0,d=this.length;c<d;c++){g=e.length,f.find(a,this[c],e);if(c>0)for(h=g;h<e.length;h++)for(i=0;i<g;i++)if(e[i]===e[h]){e.splice(h--,1);break}}return e},has:function(a){var b=f(a);return this.filter(function(){for(var a=0,c=b.length;a<c;a++)if(f.contains(this,b[a]))return!0})},not:function(a){return this.pushStack(W(this,a,!1),"not",a)},filter:function(a){return this.pushStack(W(this,a,!0),"filter",a)},is:function(a){return!!a&&(typeof a=="string"?f.filter(a,this).length>0:this.filter(a).length>0)},closest:function(a,b){var c=[],d,e,g=this[0];if(f.isArray(a)){var h,i,j={},k=1;if(g&&a.length){for(d=0,e=a.length;d<e;d++)i=a[d],j[i]||(j[i]=T.test(i)?f(i,b||this.context):i);while(g&&g.ownerDocument&&g!==b){for(i in j)h=j[i],(h.jquery?h.index(g)>-1:f(g).is(h))&&c.push({selector:i,elem:g,level:k});g=g.parentNode,k++}}return c}var l=T.test(a)||typeof a!="string"?f(a,b||this.context):0;for(d=0,e=this.length;d<e;d++){g=this[d];while(g){if(l?l.index(g)>-1:f.find.matchesSelector(g,a)){c.push(g);break}g=g.parentNode;if(!g||!g.ownerDocument||g===b||g.nodeType===11)break}}c=c.length>1?f.unique(c):c;return this.pushStack(c,"closest",a)},index:function(a){if(!a||typeof a=="string")return f.inArray(this[0],a?f(a):this.parent().children());return f.inArray(a.jquery?a[0]:a,this)},add:function(a,b){var c=typeof a=="string"?f(a,b):f.makeArray(a&&a.nodeType?[a]:a),d=f.merge(this.get(),c);return this.pushStack(V(c[0])||V(d[0])?d:f.unique(d))},andSelf:function(){return this.add(this.prevObject)}}),f.each({parent:function(a){var b=a.parentNode;return b&&b.nodeType!==11?b:null},parents:function(a){return f.dir(a,"parentNode")},parentsUntil:function(a,b,c){return f.dir(a,"parentNode",c)},next:function(a){return f.nth(a,2,"nextSibling")},prev:function(a){return f.nth(a,2,"previousSibling")},nextAll:function(a){return f.dir(a,"nextSibling")},prevAll:function(a){return f.dir(a,"previousSibling")},nextUntil:function(a,b,c){return f.dir(a,"nextSibling",c)},prevUntil:function(a,b,c){return f.dir(a,"previousSibling",c)},siblings:function(a){return f.sibling(a.parentNode.firstChild,a)},children:function(a){return f.sibling(a.firstChild)},contents:function(a){return f.nodeName(a,"iframe")?a.contentDocument||a.contentWindow.document:f.makeArray(a.childNodes)}},function(a,b){f.fn[a]=function(c,d){var e=f.map(this,b,c),g=S.call(arguments);O.test(a)||(d=c),d&&typeof d=="string"&&(e=f.filter(d,e)),e=this.length>1&&!U[a]?f.unique(e):e,(this.length>1||Q.test(d))&&P.test(a)&&(e=e.reverse());return this.pushStack(e,a,g.join(","))}}),f.extend({filter:function(a,b,c){c&&(a=":not("+a+")");return b.length===1?f.find.matchesSelector(b[0],a)?[b[0]]:[]:f.find.matches(a,b)},dir:function(a,c,d){var e=[],g=a[c];while(g&&g.nodeType!==9&&(d===b||g.nodeType!==1||!f(g).is(d)))g.nodeType===1&&e.push(g),g=g[c];return e},nth:function(a,b,c,d){b=b||1;var e=0;for(;a;a=a[c])if(a.nodeType===1&&++e===b)break;return a},sibling:function(a,b){var c=[];for(;a;a=a.nextSibling)a.nodeType===1&&a!==b&&c.push(a);return c}});var X=/ jQuery\d+="(?:\d+|null)"/g,Y=/^\s+/,Z=/<(?!area|br|col|embed|hr|img|input|link|meta|param)(([\w:]+)[^>]*)\/>/ig,$=/<([\w:]+)/,_=/<tbody/i,ba=/<|&#?\w+;/,bb=/<(?:script|object|embed|option|style)/i,bc=/checked\s*(?:[^=]|=\s*.checked.)/i,bd=/\/(java|ecma)script/i,be=/^\s*<!(?:\[CDATA\[|\-\-)/,bf={option:[1,"<select multiple='multiple'>","</select>"],legend:[1,"<fieldset>","</fieldset>"],thead:[1,"<table>","</table>"],tr:[2,"<table><tbody>","</tbody></table>"],td:[3,"<table><tbody><tr>","</tr></tbody></table>"],col:[2,"<table><tbody></tbody><colgroup>","</colgroup></table>"],area:[1,"<map>","</map>"],_default:[0,"",""]};bf.optgroup=bf.option,bf.tbody=bf.tfoot=bf.colgroup=bf.caption=bf.thead,bf.th=bf.td,f.support.htmlSerialize||(bf._default=[1,"div<div>","</div>"]),f.fn.extend({text:function(a){if(f.isFunction(a))return this.each(function(b){var c=f(this);c.text(a.call(this,b,c.text()))});if(typeof a!="object"&&a!==b)return this.empty().append((this[0]&&this[0].ownerDocument||c).createTextNode(a));return f.text(this)},wrapAll:function(a){if(f.isFunction(a))return this.each(function(b){f(this).wrapAll(a.call(this,b))});if(this[0]){var b=f(a,this[0].ownerDocument).eq(0).clone(!0);this[0].parentNode&&b.insertBefore(this[0]),b.map(function(){var a=this;while(a.firstChild&&a.firstChild.nodeType===1)a=a.firstChild;return a}).append(this)}return this},wrapInner:function(a){if(f.isFunction(a))return this.each(function(b){f(this).wrapInner(a.call(this,b))});return this.each(function(){var b=f(this),c=b.contents();c.length?c.wrapAll(a):b.append(a)})},wrap:function(a){return this.each(function(){f(this).wrapAll(a)})},unwrap:function(){return this.parent().each(function(){f.nodeName(this,"body")||f(this).replaceWith(this.childNodes)}).end()},append:function(){return this.domManip(arguments,!0,function(a){this.nodeType===1&&this.appendChild(a)})},prepend:function(){return this.domManip(arguments,!0,function(a){this.nodeType===1&&this.insertBefore(a,this.firstChild)})},before:function(){if(this[0]&&this[0].parentNode)return this.domManip(arguments,!1,function(a){this.parentNode.insertBefore(a,this)});if(arguments.length){var a=f(arguments[0]);a.push.apply(a,this.toArray());return this.pushStack(a,"before",arguments)}},after:function(){if(this[0]&&this[0].parentNode)return this.domManip(arguments,!1,function(a){this.parentNode.insertBefore(a,this.nextSibling)});if(arguments.length){var a=this.pushStack(this,"after",arguments);a.push.apply(a,f(arguments[0]).toArray());return a}},remove:function(a,b){for(var c=0,d;(d=this[c])!=null;c++)if(!a||f.filter(a,[d]).length)!b&&d.nodeType===1&&(f.cleanData(d.getElementsByTagName("*")),f.cleanData([d])),d.parentNode&&d.parentNode.removeChild(d);return this},empty:function(){for(var a=0,b;(b=this[a])!=null;a++){b.nodeType===1&&f.cleanData(b.getElementsByTagName("*"));while(b.firstChild)b.removeChild(b.firstChild)}return this},clone:function(a,b){a=a==null?!1:a,b=b==null?a:b;return this.map(function(){return f.clone(this,a,b)})},html:function(a){if(a===b)return this[0]&&this[0].nodeType===1?this[0].innerHTML.replace(X,""):null;if(typeof a=="string"&&!bb.test(a)&&(f.support.leadingWhitespace||!Y.test(a))&&!bf[($.exec(a)||["",""])[1].toLowerCase()]){a=a.replace(Z,"<$1></$2>");try{for(var c=0,d=this.length;c<d;c++)this[c].nodeType===1&&(f.cleanData(this[c].getElementsByTagName("*")),this[c].innerHTML=a)}catch(e){this.empty().append(a)}}else f.isFunction(a)?this.each(function(b){var c=f(this);c.html(a.call(this,b,c.html()))}):this.empty().append(a);return this},replaceWith:function(a){if(this[0]&&this[0].parentNode){if(f.isFunction(a))return this.each(function(b){var c=f(this),d=c.html();c.replaceWith(a.call(this,b,d))});typeof a!="string"&&(a=f(a).detach());return this.each(function(){var b=this.nextSibling,c=this.parentNode;f(this).remove(),b?f(b).before(a):f(c).append(a)})}return this.length?this.pushStack(f(f.isFunction(a)?a():a),"replaceWith",a):this},detach:function(a){return this.remove(a,!0)},domManip:function(a,c,d){var e,g,h,i,j=a[0],k=[];if(!f.support.checkClone&&arguments.length===3&&typeof j=="string"&&bc.test(j))return this.each(function(){f(this).domManip(a,c,d,!0)});if(f.isFunction(j))return this.each(function(e){var g=f(this);a[0]=j.call(this,e,c?g.html():b),g.domManip(a,c,d)});if(this[0]){i=j&&j.parentNode,f.support.parentNode&&i&&i.nodeType===11&&i.childNodes.length===this.length?e={fragment:i}:e=f.buildFragment(a,this,k),h=e.fragment,h.childNodes.length===1?g=h=h.firstChild:g=h.firstChild;if(g){c=c&&f.nodeName(g,"tr");for(var l=0,m=this.length,n=m-1;l<m;l++)d.call(c?bg(this[l],g):this[l],e.cacheable||m>1&&l<n?f.clone(h,!0,!0):h)}k.length&&f.each(k,bm)}return this}}),f.buildFragment=function(a,b,d){var e,g,h,i;b&&b[0]&&(i=b[0].ownerDocument||b[0]),i.createDocumentFragment||(i=c),a.length===1&&typeof a[0]=="string"&&a[0].length<512&&i===c&&a[0].charAt(0)==="<"&&!bb.test(a[0])&&(f.support.checkClone||!bc.test(a[0]))&&(g=!0,h=f.fragments[a[0]],h&&h!==1&&(e=h)),e||(e=i.createDocumentFragment(),f.clean(a,i,e,d)),g&&(f.fragments[a[0]]=h?e:1);return{fragment:e,cacheable:g}},f.fragments={},f.each({appendTo:"append",prependTo:"prepend",insertBefore:"before",insertAfter:"after",replaceAll:"replaceWith"},function(a,b){f.fn[a]=function(c){var d=[],e=f(c),g=this.length===1&&this[0].parentNode;if(g&&g.nodeType===11&&g.childNodes.length===1&&e.length===1){e[b](this[0]);return this}for(var h=0,i=e.length;h<i;h++){var j=(h>0?this.clone(!0):this).get();f(e[h])[b](j),d=d.concat(j +)}return this.pushStack(d,a,e.selector)}}),f.extend({clone:function(a,b,c){var d=a.cloneNode(!0),e,g,h;if((!f.support.noCloneEvent||!f.support.noCloneChecked)&&(a.nodeType===1||a.nodeType===11)&&!f.isXMLDoc(a)){bi(a,d),e=bj(a),g=bj(d);for(h=0;e[h];++h)bi(e[h],g[h])}if(b){bh(a,d);if(c){e=bj(a),g=bj(d);for(h=0;e[h];++h)bh(e[h],g[h])}}e=g=null;return d},clean:function(a,b,d,e){var g;b=b||c,typeof b.createElement=="undefined"&&(b=b.ownerDocument||b[0]&&b[0].ownerDocument||c);var h=[],i;for(var j=0,k;(k=a[j])!=null;j++){typeof k=="number"&&(k+="");if(!k)continue;if(typeof k=="string")if(!ba.test(k))k=b.createTextNode(k);else{k=k.replace(Z,"<$1></$2>");var l=($.exec(k)||["",""])[1].toLowerCase(),m=bf[l]||bf._default,n=m[0],o=b.createElement("div");o.innerHTML=m[1]+k+m[2];while(n--)o=o.lastChild;if(!f.support.tbody){var p=_.test(k),q=l==="table"&&!p?o.firstChild&&o.firstChild.childNodes:m[1]==="<table>"&&!p?o.childNodes:[];for(i=q.length-1;i>=0;--i)f.nodeName(q[i],"tbody")&&!q[i].childNodes.length&&q[i].parentNode.removeChild(q[i])}!f.support.leadingWhitespace&&Y.test(k)&&o.insertBefore(b.createTextNode(Y.exec(k)[0]),o.firstChild),k=o.childNodes}var r;if(!f.support.appendChecked)if(k[0]&&typeof (r=k.length)=="number")for(i=0;i<r;i++)bl(k[i]);else bl(k);k.nodeType?h.push(k):h=f.merge(h,k)}if(d){g=function(a){return!a.type||bd.test(a.type)};for(j=0;h[j];j++)if(e&&f.nodeName(h[j],"script")&&(!h[j].type||h[j].type.toLowerCase()==="text/javascript"))e.push(h[j].parentNode?h[j].parentNode.removeChild(h[j]):h[j]);else{if(h[j].nodeType===1){var s=f.grep(h[j].getElementsByTagName("script"),g);h.splice.apply(h,[j+1,0].concat(s))}d.appendChild(h[j])}}return h},cleanData:function(a){var b,c,d=f.cache,e=f.expando,g=f.event.special,h=f.support.deleteExpando;for(var i=0,j;(j=a[i])!=null;i++){if(j.nodeName&&f.noData[j.nodeName.toLowerCase()])continue;c=j[f.expando];if(c){b=d[c]&&d[c][e];if(b&&b.events){for(var k in b.events)g[k]?f.event.remove(j,k):f.removeEvent(j,k,b.handle);b.handle&&(b.handle.elem=null)}h?delete j[f.expando]:j.removeAttribute&&j.removeAttribute(f.expando),delete d[c]}}}});var bn=/alpha\([^)]*\)/i,bo=/opacity=([^)]*)/,bp=/([A-Z]|^ms)/g,bq=/^-?\d+(?:px)?$/i,br=/^-?\d/,bs=/^[+\-]=/,bt=/[^+\-\.\de]+/g,bu={position:"absolute",visibility:"hidden",display:"block"},bv=["Left","Right"],bw=["Top","Bottom"],bx,by,bz;f.fn.css=function(a,c){if(arguments.length===2&&c===b)return this;return f.access(this,a,c,!0,function(a,c,d){return d!==b?f.style(a,c,d):f.css(a,c)})},f.extend({cssHooks:{opacity:{get:function(a,b){if(b){var c=bx(a,"opacity","opacity");return c===""?"1":c}return a.style.opacity}}},cssNumber:{fillOpacity:!0,fontWeight:!0,lineHeight:!0,opacity:!0,orphans:!0,widows:!0,zIndex:!0,zoom:!0},cssProps:{"float":f.support.cssFloat?"cssFloat":"styleFloat"},style:function(a,c,d,e){if(!!a&&a.nodeType!==3&&a.nodeType!==8&&!!a.style){var g,h,i=f.camelCase(c),j=a.style,k=f.cssHooks[i];c=f.cssProps[i]||i;if(d===b){if(k&&"get"in k&&(g=k.get(a,!1,e))!==b)return g;return j[c]}h=typeof d;if(h==="number"&&isNaN(d)||d==null)return;h==="string"&&bs.test(d)&&(d=+d.replace(bt,"")+parseFloat(f.css(a,c)),h="number"),h==="number"&&!f.cssNumber[i]&&(d+="px");if(!k||!("set"in k)||(d=k.set(a,d))!==b)try{j[c]=d}catch(l){}}},css:function(a,c,d){var e,g;c=f.camelCase(c),g=f.cssHooks[c],c=f.cssProps[c]||c,c==="cssFloat"&&(c="float");if(g&&"get"in g&&(e=g.get(a,!0,d))!==b)return e;if(bx)return bx(a,c)},swap:function(a,b,c){var d={};for(var e in b)d[e]=a.style[e],a.style[e]=b[e];c.call(a);for(e in b)a.style[e]=d[e]}}),f.curCSS=f.css,f.each(["height","width"],function(a,b){f.cssHooks[b]={get:function(a,c,d){var e;if(c){if(a.offsetWidth!==0)return bA(a,b,d);f.swap(a,bu,function(){e=bA(a,b,d)});return e}},set:function(a,b){if(!bq.test(b))return b;b=parseFloat(b);if(b>=0)return b+"px"}}}),f.support.opacity||(f.cssHooks.opacity={get:function(a,b){return bo.test((b&&a.currentStyle?a.currentStyle.filter:a.style.filter)||"")?parseFloat(RegExp.$1)/100+"":b?"1":""},set:function(a,b){var c=a.style,d=a.currentStyle;c.zoom=1;var e=f.isNaN(b)?"":"alpha(opacity="+b*100+")",g=d&&d.filter||c.filter||"";c.filter=bn.test(g)?g.replace(bn,e):g+" "+e}}),f(function(){f.support.reliableMarginRight||(f.cssHooks.marginRight={get:function(a,b){var c;f.swap(a,{display:"inline-block"},function(){b?c=bx(a,"margin-right","marginRight"):c=a.style.marginRight});return c}})}),c.defaultView&&c.defaultView.getComputedStyle&&(by=function(a,c){var d,e,g;c=c.replace(bp,"-$1").toLowerCase();if(!(e=a.ownerDocument.defaultView))return b;if(g=e.getComputedStyle(a,null))d=g.getPropertyValue(c),d===""&&!f.contains(a.ownerDocument.documentElement,a)&&(d=f.style(a,c));return d}),c.documentElement.currentStyle&&(bz=function(a,b){var c,d=a.currentStyle&&a.currentStyle[b],e=a.runtimeStyle&&a.runtimeStyle[b],f=a.style;!bq.test(d)&&br.test(d)&&(c=f.left,e&&(a.runtimeStyle.left=a.currentStyle.left),f.left=b==="fontSize"?"1em":d||0,d=f.pixelLeft+"px",f.left=c,e&&(a.runtimeStyle.left=e));return d===""?"auto":d}),bx=by||bz,f.expr&&f.expr.filters&&(f.expr.filters.hidden=function(a){var b=a.offsetWidth,c=a.offsetHeight;return b===0&&c===0||!f.support.reliableHiddenOffsets&&(a.style.display||f.css(a,"display"))==="none"},f.expr.filters.visible=function(a){return!f.expr.filters.hidden(a)});var bB=/%20/g,bC=/\[\]$/,bD=/\r?\n/g,bE=/#.*$/,bF=/^(.*?):[ \t]*([^\r\n]*)\r?$/mg,bG=/^(?:color|date|datetime|email|hidden|month|number|password|range|search|tel|text|time|url|week)$/i,bH=/^(?:about|app|app\-storage|.+\-extension|file|widget):$/,bI=/^(?:GET|HEAD)$/,bJ=/^\/\//,bK=/\?/,bL=/<script\b[^<]*(?:(?!<\/script>)<[^<]*)*<\/script>/gi,bM=/^(?:select|textarea)/i,bN=/\s+/,bO=/([?&])_=[^&]*/,bP=/^([\w\+\.\-]+:)(?:\/\/([^\/?#:]*)(?::(\d+))?)?/,bQ=f.fn.load,bR={},bS={},bT,bU;try{bT=e.href}catch(bV){bT=c.createElement("a"),bT.href="",bT=bT.href}bU=bP.exec(bT.toLowerCase())||[],f.fn.extend({load:function(a,c,d){if(typeof a!="string"&&bQ)return bQ.apply(this,arguments);if(!this.length)return this;var e=a.indexOf(" ");if(e>=0){var g=a.slice(e,a.length);a=a.slice(0,e)}var h="GET";c&&(f.isFunction(c)?(d=c,c=b):typeof c=="object"&&(c=f.param(c,f.ajaxSettings.traditional),h="POST"));var i=this;f.ajax({url:a,type:h,dataType:"html",data:c,complete:function(a,b,c){c=a.responseText,a.isResolved()&&(a.done(function(a){c=a}),i.html(g?f("<div>").append(c.replace(bL,"")).find(g):c)),d&&i.each(d,[c,b,a])}});return this},serialize:function(){return f.param(this.serializeArray())},serializeArray:function(){return this.map(function(){return this.elements?f.makeArray(this.elements):this}).filter(function(){return this.name&&!this.disabled&&(this.checked||bM.test(this.nodeName)||bG.test(this.type))}).map(function(a,b){var c=f(this).val();return c==null?null:f.isArray(c)?f.map(c,function(a,c){return{name:b.name,value:a.replace(bD,"\r\n")}}):{name:b.name,value:c.replace(bD,"\r\n")}}).get()}}),f.each("ajaxStart ajaxStop ajaxComplete ajaxError ajaxSuccess ajaxSend".split(" "),function(a,b){f.fn[b]=function(a){return this.bind(b,a)}}),f.each(["get","post"],function(a,c){f[c]=function(a,d,e,g){f.isFunction(d)&&(g=g||e,e=d,d=b);return f.ajax({type:c,url:a,data:d,success:e,dataType:g})}}),f.extend({getScript:function(a,c){return f.get(a,b,c,"script")},getJSON:function(a,b,c){return f.get(a,b,c,"json")},ajaxSetup:function(a,b){b?f.extend(!0,a,f.ajaxSettings,b):(b=a,a=f.extend(!0,f.ajaxSettings,b));for(var c in{context:1,url:1})c in b?a[c]=b[c]:c in f.ajaxSettings&&(a[c]=f.ajaxSettings[c]);return a},ajaxSettings:{url:bT,isLocal:bH.test(bU[1]),global:!0,type:"GET",contentType:"application/x-www-form-urlencoded",processData:!0,async:!0,accepts:{xml:"application/xml, text/xml",html:"text/html",text:"text/plain",json:"application/json, text/javascript","*":"*/*"},contents:{xml:/xml/,html:/html/,json:/json/},responseFields:{xml:"responseXML",text:"responseText"},converters:{"* text":a.String,"text html":!0,"text json":f.parseJSON,"text xml":f.parseXML}},ajaxPrefilter:bW(bR),ajaxTransport:bW(bS),ajax:function(a,c){function w(a,c,l,m){if(s!==2){s=2,q&&clearTimeout(q),p=b,n=m||"",v.readyState=a?4:0;var o,r,u,w=l?bZ(d,v,l):b,x,y;if(a>=200&&a<300||a===304){if(d.ifModified){if(x=v.getResponseHeader("Last-Modified"))f.lastModified[k]=x;if(y=v.getResponseHeader("Etag"))f.etag[k]=y}if(a===304)c="notmodified",o=!0;else try{r=b$(d,w),c="success",o=!0}catch(z){c="parsererror",u=z}}else{u=c;if(!c||a)c="error",a<0&&(a=0)}v.status=a,v.statusText=c,o?h.resolveWith(e,[r,c,v]):h.rejectWith(e,[v,c,u]),v.statusCode(j),j=b,t&&g.trigger("ajax"+(o?"Success":"Error"),[v,d,o?r:u]),i.resolveWith(e,[v,c]),t&&(g.trigger("ajaxComplete",[v,d]),--f.active||f.event.trigger("ajaxStop"))}}typeof a=="object"&&(c=a,a=b),c=c||{};var d=f.ajaxSetup({},c),e=d.context||d,g=e!==d&&(e.nodeType||e instanceof f)?f(e):f.event,h=f.Deferred(),i=f._Deferred(),j=d.statusCode||{},k,l={},m={},n,o,p,q,r,s=0,t,u,v={readyState:0,setRequestHeader:function(a,b){if(!s){var c=a.toLowerCase();a=m[c]=m[c]||a,l[a]=b}return this},getAllResponseHeaders:function(){return s===2?n:null},getResponseHeader:function(a){var c;if(s===2){if(!o){o={};while(c=bF.exec(n))o[c[1].toLowerCase()]=c[2]}c=o[a.toLowerCase()]}return c===b?null:c},overrideMimeType:function(a){s||(d.mimeType=a);return this},abort:function(a){a=a||"abort",p&&p.abort(a),w(0,a);return this}};h.promise(v),v.success=v.done,v.error=v.fail,v.complete=i.done,v.statusCode=function(a){if(a){var b;if(s<2)for(b in a)j[b]=[j[b],a[b]];else b=a[v.status],v.then(b,b)}return this},d.url=((a||d.url)+"").replace(bE,"").replace(bJ,bU[1]+"//"),d.dataTypes=f.trim(d.dataType||"*").toLowerCase().split(bN),d.crossDomain==null&&(r=bP.exec(d.url.toLowerCase()),d.crossDomain=!(!r||r[1]==bU[1]&&r[2]==bU[2]&&(r[3]||(r[1]==="http:"?80:443))==(bU[3]||(bU[1]==="http:"?80:443)))),d.data&&d.processData&&typeof d.data!="string"&&(d.data=f.param(d.data,d.traditional)),bX(bR,d,c,v);if(s===2)return!1;t=d.global,d.type=d.type.toUpperCase(),d.hasContent=!bI.test(d.type),t&&f.active++===0&&f.event.trigger("ajaxStart");if(!d.hasContent){d.data&&(d.url+=(bK.test(d.url)?"&":"?")+d.data),k=d.url;if(d.cache===!1){var x=f.now(),y=d.url.replace(bO,"$1_="+x);d.url=y+(y===d.url?(bK.test(d.url)?"&":"?")+"_="+x:"")}}(d.data&&d.hasContent&&d.contentType!==!1||c.contentType)&&v.setRequestHeader("Content-Type",d.contentType),d.ifModified&&(k=k||d.url,f.lastModified[k]&&v.setRequestHeader("If-Modified-Since",f.lastModified[k]),f.etag[k]&&v.setRequestHeader("If-None-Match",f.etag[k])),v.setRequestHeader("Accept",d.dataTypes[0]&&d.accepts[d.dataTypes[0]]?d.accepts[d.dataTypes[0]]+(d.dataTypes[0]!=="*"?", */*; q=0.01":""):d.accepts["*"]);for(u in d.headers)v.setRequestHeader(u,d.headers[u]);if(d.beforeSend&&(d.beforeSend.call(e,v,d)===!1||s===2)){v.abort();return!1}for(u in{success:1,error:1,complete:1})v[u](d[u]);p=bX(bS,d,c,v);if(!p)w(-1,"No Transport");else{v.readyState=1,t&&g.trigger("ajaxSend",[v,d]),d.async&&d.timeout>0&&(q=setTimeout(function(){v.abort("timeout")},d.timeout));try{s=1,p.send(l,w)}catch(z){status<2?w(-1,z):f.error(z)}}return v},param:function(a,c){var d=[],e=function(a,b){b=f.isFunction(b)?b():b,d[d.length]=encodeURIComponent(a)+"="+encodeURIComponent(b)};c===b&&(c=f.ajaxSettings.traditional);if(f.isArray(a)||a.jquery&&!f.isPlainObject(a))f.each(a,function(){e(this.name,this.value)});else for(var g in a)bY(g,a[g],c,e);return d.join("&").replace(bB,"+")}}),f.extend({active:0,lastModified:{},etag:{}});var b_=f.now(),ca=/(\=)\?(&|$)|\?\?/i;f.ajaxSetup({jsonp:"callback",jsonpCallback:function(){return f.expando+"_"+b_++}}),f.ajaxPrefilter("json jsonp",function(b,c,d){var e=b.contentType==="application/x-www-form-urlencoded"&&typeof b.data=="string";if(b.dataTypes[0]==="jsonp"||b.jsonp!==!1&&(ca.test(b.url)||e&&ca.test(b.data))){var g,h=b.jsonpCallback=f.isFunction(b.jsonpCallback)?b.jsonpCallback():b.jsonpCallback,i=a[h],j=b.url,k=b.data,l="$1"+h+"$2";b.jsonp!==!1&&(j=j.replace(ca,l),b.url===j&&(e&&(k=k.replace(ca,l)),b.data===k&&(j+=(/\?/.test(j)?"&":"?")+b.jsonp+"="+h))),b.url=j,b.data=k,a[h]=function(a){g=[a]},d.always(function(){a[h]=i,g&&f.isFunction(i)&&a[h](g[0])}),b.converters["script json"]=function(){g||f.error(h+" was not called");return g[0]},b.dataTypes[0]="json";return"script"}}),f.ajaxSetup({accepts:{script:"text/javascript, application/javascript, application/ecmascript, application/x-ecmascript"},contents:{script:/javascript|ecmascript/},converters:{"text script":function(a){f.globalEval(a);return a}}}),f.ajaxPrefilter("script",function(a){a.cache===b&&(a.cache=!1),a.crossDomain&&(a.type="GET",a.global=!1)}),f.ajaxTransport("script",function(a){if(a.crossDomain){var d,e=c.head||c.getElementsByTagName("head")[0]||c.documentElement;return{send:function(f,g){d=c.createElement("script"),d.async="async",a.scriptCharset&&(d.charset=a.scriptCharset),d.src=a.url,d.onload=d.onreadystatechange=function(a,c){if(c||!d.readyState||/loaded|complete/.test(d.readyState))d.onload=d.onreadystatechange=null,e&&d.parentNode&&e.removeChild(d),d=b,c||g(200,"success")},e.insertBefore(d,e.firstChild)},abort:function(){d&&d.onload(0,1)}}}});var cb=a.ActiveXObject?function(){for(var a in cd)cd[a](0,1)}:!1,cc=0,cd;f.ajaxSettings.xhr=a.ActiveXObject?function(){return!this.isLocal&&ce()||cf()}:ce,function(a){f.extend(f.support,{ajax:!!a,cors:!!a&&"withCredentials"in a})}(f.ajaxSettings.xhr()),f.support.ajax&&f.ajaxTransport(function(c){if(!c.crossDomain||f.support.cors){var d;return{send:function(e,g){var h=c.xhr(),i,j;c.username?h.open(c.type,c.url,c.async,c.username,c.password):h.open(c.type,c.url,c.async);if(c.xhrFields)for(j in c.xhrFields)h[j]=c.xhrFields[j];c.mimeType&&h.overrideMimeType&&h.overrideMimeType(c.mimeType),!c.crossDomain&&!e["X-Requested-With"]&&(e["X-Requested-With"]="XMLHttpRequest");try{for(j in e)h.setRequestHeader(j,e[j])}catch(k){}h.send(c.hasContent&&c.data||null),d=function(a,e){var j,k,l,m,n;try{if(d&&(e||h.readyState===4)){d=b,i&&(h.onreadystatechange=f.noop,cb&&delete cd[i]);if(e)h.readyState!==4&&h.abort();else{j=h.status,l=h.getAllResponseHeaders(),m={},n=h.responseXML,n&&n.documentElement&&(m.xml=n),m.text=h.responseText;try{k=h.statusText}catch(o){k=""}!j&&c.isLocal&&!c.crossDomain?j=m.text?200:404:j===1223&&(j=204)}}}catch(p){e||g(-1,p)}m&&g(j,k,m,l)},!c.async||h.readyState===4?d():(i=++cc,cb&&(cd||(cd={},f(a).unload(cb)),cd[i]=d),h.onreadystatechange=d)},abort:function(){d&&d(0,1)}}}});var cg={},ch,ci,cj=/^(?:toggle|show|hide)$/,ck=/^([+\-]=)?([\d+.\-]+)([a-z%]*)$/i,cl,cm=[["height","marginTop","marginBottom","paddingTop","paddingBottom"],["width","marginLeft","marginRight","paddingLeft","paddingRight"],["opacity"]],cn,co=a.webkitRequestAnimationFrame||a.mozRequestAnimationFrame||a.oRequestAnimationFrame;f.fn.extend({show:function(a,b,c){var d,e;if(a||a===0)return this.animate(cr("show",3),a,b,c);for(var g=0,h=this.length;g<h;g++)d=this[g],d.style&&(e=d.style.display,!f._data(d,"olddisplay")&&e==="none"&&(e=d.style.display=""),e===""&&f.css(d,"display")==="none"&&f._data(d,"olddisplay",cs(d.nodeName)));for(g=0;g<h;g++){d=this[g];if(d.style){e=d.style.display;if(e===""||e==="none")d.style.display=f._data(d,"olddisplay")||""}}return this},hide:function(a,b,c){if(a||a===0)return this.animate(cr("hide",3),a,b,c);for(var d=0,e=this.length;d<e;d++)if(this[d].style){var g=f.css(this[d],"display");g!=="none"&&!f._data(this[d],"olddisplay")&&f._data(this[d],"olddisplay",g)}for(d=0;d<e;d++)this[d].style&&(this[d].style.display="none");return this},_toggle:f.fn.toggle,toggle:function(a,b,c){var d=typeof a=="boolean";f.isFunction(a)&&f.isFunction(b)?this._toggle.apply(this,arguments):a==null||d?this.each(function(){var b=d?a:f(this).is(":hidden");f(this)[b?"show":"hide"]()}):this.animate(cr("toggle",3),a,b,c);return this},fadeTo:function(a,b,c,d){return this.filter(":hidden").css("opacity",0).show().end().animate({opacity:b},a,c,d)},animate:function(a,b,c,d){var e=f.speed(b,c,d);if(f.isEmptyObject(a))return this.each(e.complete,[!1]);a=f.extend({},a);return this[e.queue===!1?"each":"queue"](function(){e.queue===!1&&f._mark(this);var b=f.extend({},e),c=this.nodeType===1,d=c&&f(this).is(":hidden"),g,h,i,j,k,l,m,n,o;b.animatedProperties={};for(i in a){g=f.camelCase(i),i!==g&&(a[g]=a[i],delete a[i]),h=a[g],f.isArray(h)?(b.animatedProperties[g]=h[1],h=a[g]=h[0]):b.animatedProperties[g]=b.specialEasing&&b.specialEasing[g]||b.easing||"swing";if(h==="hide"&&d||h==="show"&&!d)return b.complete.call(this);c&&(g==="height"||g==="width")&&(b.overflow=[this.style.overflow,this.style.overflowX,this.style.overflowY],f.css(this,"display")==="inline"&&f.css(this,"float")==="none"&&(f.support.inlineBlockNeedsLayout?(j=cs(this.nodeName),j==="inline"?this.style.display="inline-block":(this.style.display="inline",this.style.zoom=1)):this.style.display="inline-block"))}b.overflow!=null&&(this.style.overflow="hidden");for(i in a)k=new f.fx(this,b,i),h=a[i],cj.test(h)?k[h==="toggle"?d?"show":"hide":h]():(l=ck.exec(h),m=k.cur(),l?(n=parseFloat(l[2]),o=l[3]||(f.cssNumber[i]?"":"px"),o!=="px"&&(f.style(this,i,(n||1)+o),m=(n||1)/k.cur()*m,f.style(this,i,m+o)),l[1]&&(n=(l[1]==="-="?-1:1)*n+m),k.custom(m,n,o)):k.custom(m,h,""));return!0})},stop:function(a,b){a&&this.queue([]),this.each(function(){var a=f.timers,c=a.length;b||f._unmark(!0,this);while(c--)a[c].elem===this&&(b&&a[c](!0),a.splice(c,1))}),b||this.dequeue();return this}}),f.each({slideDown:cr("show",1),slideUp:cr("hide",1),slideToggle:cr("toggle",1),fadeIn:{opacity:"show"},fadeOut:{opacity:"hide"},fadeToggle:{opacity:"toggle"}},function(a,b){f.fn[a]=function(a,c,d){return this.animate(b,a,c,d)}}),f.extend({speed:function(a,b,c){var d=a&&typeof a=="object"?f.extend({},a):{complete:c||!c&&b||f.isFunction(a)&&a,duration:a,easing:c&&b||b&&!f.isFunction(b)&&b};d.duration=f.fx.off?0:typeof d.duration=="number"?d.duration:d.duration in f.fx.speeds?f.fx.speeds[d.duration]:f.fx.speeds._default,d.old=d.complete,d.complete=function(a){f.isFunction(d.old)&&d.old.call(this),d.queue!==!1?f.dequeue(this):a!==!1&&f._unmark(this)};return d},easing:{linear:function(a,b,c,d){return c+d*a},swing:function(a,b,c,d){return(-Math.cos(a*Math.PI)/2+.5)*d+c}},timers:[],fx:function(a,b,c){this.options=b,this.elem=a,this.prop=c,b.orig=b.orig||{}}}),f.fx.prototype={update:function(){this.options.step&&this.options.step.call(this.elem,this.now,this),(f.fx.step[this.prop]||f.fx.step._default)(this)},cur:function(){if(this.elem[this.prop]!=null&&(!this.elem.style||this.elem.style[this.prop]==null))return this.elem[this.prop];var a,b=f.css(this.elem,this.prop);return isNaN(a=parseFloat(b))?!b||b==="auto"?0:b:a},custom:function(a,b,c){function h(a){return d.step(a)}var d=this,e=f.fx,g;this.startTime=cn||cp(),this.start=a,this.end=b,this.unit=c||this.unit||(f.cssNumber[this.prop]?"":"px"),this.now=this.start,this.pos=this.state=0,h.elem=this.elem,h()&&f.timers.push(h)&&!cl&&(co?(cl=!0,g=function(){cl&&(co(g),e.tick())},co(g)):cl=setInterval(e.tick,e.interval))},show:function(){this.options.orig[this.prop]=f.style(this.elem,this.prop),this.options.show=!0,this.custom(this.prop==="width"||this.prop==="height"?1:0,this.cur()),f(this.elem).show()},hide:function(){this.options.orig[this.prop]=f.style(this.elem,this.prop),this.options.hide=!0,this.custom(this.cur(),0)},step:function(a){var b=cn||cp(),c=!0,d=this.elem,e=this.options,g,h;if(a||b>=e.duration+this.startTime){this.now=this.end,this.pos=this.state=1,this.update(),e.animatedProperties[this.prop]=!0;for(g in e.animatedProperties)e.animatedProperties[g]!==!0&&(c=!1);if(c){e.overflow!=null&&!f.support.shrinkWrapBlocks&&f.each(["","X","Y"],function(a,b){d.style["overflow"+b]=e.overflow[a]}),e.hide&&f(d).hide();if(e.hide||e.show)for(var i in e.animatedProperties)f.style(d,i,e.orig[i]);e.complete.call(d)}return!1}e.duration==Infinity?this.now=b:(h=b-this.startTime,this.state=h/e.duration,this.pos=f.easing[e.animatedProperties[this.prop]](this.state,h,0,1,e.duration),this.now=this.start+(this.end-this.start)*this.pos),this.update();return!0}},f.extend(f.fx,{tick:function(){for(var a=f.timers,b=0;b<a.length;++b)a[b]()||a.splice(b--,1);a.length||f.fx.stop()},interval:13,stop:function(){clearInterval(cl),cl=null},speeds:{slow:600,fast:200,_default:400},step:{opacity:function(a){f.style(a.elem,"opacity",a.now)},_default:function(a){a.elem.style&&a.elem.style[a.prop]!=null?a.elem.style[a.prop]=(a.prop==="width"||a.prop==="height"?Math.max(0,a.now):a.now)+a.unit:a.elem[a.prop]=a.now}}}),f.expr&&f.expr.filters&&(f.expr.filters.animated=function(a){return f.grep(f.timers,function(b){return a===b.elem}).length});var ct=/^t(?:able|d|h)$/i,cu=/^(?:body|html)$/i;"getBoundingClientRect"in c.documentElement?f.fn.offset=function(a){var b=this[0],c;if(a)return this.each(function(b){f.offset.setOffset(this,a,b)});if(!b||!b.ownerDocument)return null;if(b===b.ownerDocument.body)return f.offset.bodyOffset(b);try{c=b.getBoundingClientRect()}catch(d){}var e=b.ownerDocument,g=e.documentElement;if(!c||!f.contains(g,b))return c?{top:c.top,left:c.left}:{top:0,left:0};var h=e.body,i=cv(e),j=g.clientTop||h.clientTop||0,k=g.clientLeft||h.clientLeft||0,l=i.pageYOffset||f.support.boxModel&&g.scrollTop||h.scrollTop,m=i.pageXOffset||f.support.boxModel&&g.scrollLeft||h.scrollLeft,n=c.top+l-j,o=c.left+m-k;return{top:n,left:o}}:f.fn.offset=function(a){var b=this[0];if(a)return this.each(function(b){f.offset.setOffset(this,a,b)});if(!b||!b.ownerDocument)return null;if(b===b.ownerDocument.body)return f.offset.bodyOffset(b);f.offset.initialize();var c,d=b.offsetParent,e=b,g=b.ownerDocument,h=g.documentElement,i=g.body,j=g.defaultView,k=j?j.getComputedStyle(b,null):b.currentStyle,l=b.offsetTop,m=b.offsetLeft;while((b=b.parentNode)&&b!==i&&b!==h){if(f.offset.supportsFixedPosition&&k.position==="fixed")break;c=j?j.getComputedStyle(b,null):b.currentStyle,l-=b.scrollTop,m-=b.scrollLeft,b===d&&(l+=b.offsetTop,m+=b.offsetLeft,f.offset.doesNotAddBorder&&(!f.offset.doesAddBorderForTableAndCells||!ct.test(b.nodeName))&&(l+=parseFloat(c.borderTopWidth)||0,m+=parseFloat(c.borderLeftWidth)||0),e=d,d=b.offsetParent),f.offset.subtractsBorderForOverflowNotVisible&&c.overflow!=="visible"&&(l+=parseFloat(c.borderTopWidth)||0,m+=parseFloat(c.borderLeftWidth)||0),k=c}if(k.position==="relative"||k.position==="static")l+=i.offsetTop,m+=i.offsetLeft;f.offset.supportsFixedPosition&&k.position==="fixed"&&(l+=Math.max(h.scrollTop,i.scrollTop),m+=Math.max(h.scrollLeft,i.scrollLeft));return{top:l,left:m}},f.offset={initialize:function(){var a=c.body,b=c.createElement("div"),d,e,g,h,i=parseFloat(f.css(a,"marginTop"))||0,j="<div style='position:absolute;top:0;left:0;margin:0;border:5px solid #000;padding:0;width:1px;height:1px;'><div></div></div><table style='position:absolute;top:0;left:0;margin:0;border:5px solid #000;padding:0;width:1px;height:1px;' cellpadding='0' cellspacing='0'><tr><td></td></tr></table>";f.extend(b.style,{position:"absolute",top:0,left:0,margin:0,border:0,width:"1px",height:"1px",visibility:"hidden"}),b.innerHTML=j,a.insertBefore(b,a.firstChild),d=b.firstChild,e=d.firstChild,h=d.nextSibling.firstChild.firstChild,this.doesNotAddBorder=e.offsetTop!==5,this.doesAddBorderForTableAndCells=h.offsetTop===5,e.style.position="fixed",e.style.top="20px",this.supportsFixedPosition=e.offsetTop===20||e.offsetTop===15,e.style.position=e.style.top="",d.style.overflow="hidden",d.style.position="relative",this.subtractsBorderForOverflowNotVisible=e.offsetTop===-5,this.doesNotIncludeMarginInBodyOffset=a.offsetTop!==i,a.removeChild(b),f.offset.initialize=f.noop},bodyOffset:function(a){var b=a.offsetTop,c=a.offsetLeft;f.offset.initialize(),f.offset.doesNotIncludeMarginInBodyOffset&&(b+=parseFloat(f.css(a,"marginTop"))||0,c+=parseFloat(f.css(a,"marginLeft"))||0);return{top:b,left:c}},setOffset:function(a,b,c){var d=f.css(a,"position");d==="static"&&(a.style.position="relative");var e=f(a),g=e.offset(),h=f.css(a,"top"),i=f.css(a,"left"),j=(d==="absolute"||d==="fixed")&&f.inArray("auto",[h,i])>-1,k={},l={},m,n;j?(l=e.position(),m=l.top,n=l.left):(m=parseFloat(h)||0,n=parseFloat(i)||0),f.isFunction(b)&&(b=b.call(a,c,g)),b.top!=null&&(k.top=b.top-g.top+m),b.left!=null&&(k.left=b.left-g.left+n),"using"in b?b.using.call(a,k):e.css(k)}},f.fn.extend({position:function(){if(!this[0])return null;var a=this[0],b=this.offsetParent(),c=this.offset(),d=cu.test(b[0].nodeName)?{top:0,left:0}:b.offset();c.top-=parseFloat(f.css(a,"marginTop"))||0,c.left-=parseFloat(f.css(a,"marginLeft"))||0,d.top+=parseFloat(f.css(b[0],"borderTopWidth"))||0,d.left+=parseFloat(f.css(b[0],"borderLeftWidth"))||0;return{top:c.top-d.top,left:c.left-d.left}},offsetParent:function(){return this.map(function(){var a=this.offsetParent||c.body;while(a&&!cu.test(a.nodeName)&&f.css(a,"position")==="static")a=a.offsetParent;return a})}}),f.each(["Left","Top"],function(a,c){var d="scroll"+c;f.fn[d]=function(c){var e,g;if(c===b){e=this[0];if(!e)return null;g=cv(e);return g?"pageXOffset"in g?g[a?"pageYOffset":"pageXOffset"]:f.support.boxModel&&g.document.documentElement[d]||g.document.body[d]:e[d]}return this.each(function(){g=cv(this),g?g.scrollTo(a?f(g).scrollLeft():c,a?c:f(g).scrollTop()):this[d]=c})}}),f.each(["Height","Width"],function(a,c){var d=c.toLowerCase();f.fn["inner"+c]=function(){var a=this[0];return a&&a.style?parseFloat(f.css(a,d,"padding")):null},f.fn["outer"+c]=function(a){var b=this[0];return b&&b.style?parseFloat(f.css(b,d,a?"margin":"border")):null},f.fn[d]=function(a){var e=this[0];if(!e)return a==null?null:this;if(f.isFunction(a))return this.each(function(b){var c=f(this);c[d](a.call(this,b,c[d]()))});if(f.isWindow(e)){var g=e.document.documentElement["client"+c];return e.document.compatMode==="CSS1Compat"&&g||e.document.body["client"+c]||g}if(e.nodeType===9)return Math.max(e.documentElement["client"+c],e.body["scroll"+c],e.documentElement["scroll"+c],e.body["offset"+c],e.documentElement["offset"+c]);if(a===b){var h=f.css(e,d),i=parseFloat(h);return f.isNaN(i)?h:i}return this.css(d,typeof a=="string"?a:a+"px")}}),a.jQuery=a.$=f})(window); \ No newline at end of file diff --git a/collects/meta/drdr/static/jquery.flot.js b/collects/meta/drdr/static/jquery.flot.js new file mode 100644 index 0000000000..aabc544e9a --- /dev/null +++ b/collects/meta/drdr/static/jquery.flot.js @@ -0,0 +1,2599 @@ +/*! Javascript plotting library for jQuery, v. 0.7. + * + * Released under the MIT license by IOLA, December 2007. + * + */ + +// first an inline dependency, jquery.colorhelpers.js, we inline it here +// for convenience + +/* Plugin for jQuery for working with colors. + * + * Version 1.1. + * + * Inspiration from jQuery color animation plugin by John Resig. + * + * Released under the MIT license by Ole Laursen, October 2009. + * + * Examples: + * + * $.color.parse("#fff").scale('rgb', 0.25).add('a', -0.5).toString() + * var c = $.color.extract($("#mydiv"), 'background-color'); + * console.log(c.r, c.g, c.b, c.a); + * $.color.make(100, 50, 25, 0.4).toString() // returns "rgba(100,50,25,0.4)" + * + * Note that .scale() and .add() return the same modified object + * instead of making a new one. + * + * V. 1.1: Fix error handling so e.g. parsing an empty string does + * produce a color rather than just crashing. + */ +(function(B){B.color={};B.color.make=function(F,E,C,D){var G={};G.r=F||0;G.g=E||0;G.b=C||0;G.a=D!=null?D:1;G.add=function(J,I){for(var H=0;H<J.length;++H){G[J.charAt(H)]+=I}return G.normalize()};G.scale=function(J,I){for(var H=0;H<J.length;++H){G[J.charAt(H)]*=I}return G.normalize()};G.toString=function(){if(G.a>=1){return"rgb("+[G.r,G.g,G.b].join(",")+")"}else{return"rgba("+[G.r,G.g,G.b,G.a].join(",")+")"}};G.normalize=function(){function H(J,K,I){return K<J?J:(K>I?I:K)}G.r=H(0,parseInt(G.r),255);G.g=H(0,parseInt(G.g),255);G.b=H(0,parseInt(G.b),255);G.a=H(0,G.a,1);return G};G.clone=function(){return B.color.make(G.r,G.b,G.g,G.a)};return G.normalize()};B.color.extract=function(D,C){var E;do{E=D.css(C).toLowerCase();if(E!=""&&E!="transparent"){break}D=D.parent()}while(!B.nodeName(D.get(0),"body"));if(E=="rgba(0, 0, 0, 0)"){E="transparent"}return B.color.parse(E)};B.color.parse=function(F){var E,C=B.color.make;if(E=/rgb\(\s*([0-9]{1,3})\s*,\s*([0-9]{1,3})\s*,\s*([0-9]{1,3})\s*\)/.exec(F)){return C(parseInt(E[1],10),parseInt(E[2],10),parseInt(E[3],10))}if(E=/rgba\(\s*([0-9]{1,3})\s*,\s*([0-9]{1,3})\s*,\s*([0-9]{1,3})\s*,\s*([0-9]+(?:\.[0-9]+)?)\s*\)/.exec(F)){return C(parseInt(E[1],10),parseInt(E[2],10),parseInt(E[3],10),parseFloat(E[4]))}if(E=/rgb\(\s*([0-9]+(?:\.[0-9]+)?)\%\s*,\s*([0-9]+(?:\.[0-9]+)?)\%\s*,\s*([0-9]+(?:\.[0-9]+)?)\%\s*\)/.exec(F)){return C(parseFloat(E[1])*2.55,parseFloat(E[2])*2.55,parseFloat(E[3])*2.55)}if(E=/rgba\(\s*([0-9]+(?:\.[0-9]+)?)\%\s*,\s*([0-9]+(?:\.[0-9]+)?)\%\s*,\s*([0-9]+(?:\.[0-9]+)?)\%\s*,\s*([0-9]+(?:\.[0-9]+)?)\s*\)/.exec(F)){return C(parseFloat(E[1])*2.55,parseFloat(E[2])*2.55,parseFloat(E[3])*2.55,parseFloat(E[4]))}if(E=/#([a-fA-F0-9]{2})([a-fA-F0-9]{2})([a-fA-F0-9]{2})/.exec(F)){return C(parseInt(E[1],16),parseInt(E[2],16),parseInt(E[3],16))}if(E=/#([a-fA-F0-9])([a-fA-F0-9])([a-fA-F0-9])/.exec(F)){return C(parseInt(E[1]+E[1],16),parseInt(E[2]+E[2],16),parseInt(E[3]+E[3],16))}var D=B.trim(F).toLowerCase();if(D=="transparent"){return C(255,255,255,0)}else{E=A[D]||[0,0,0];return C(E[0],E[1],E[2])}};var A={aqua:[0,255,255],azure:[240,255,255],beige:[245,245,220],black:[0,0,0],blue:[0,0,255],brown:[165,42,42],cyan:[0,255,255],darkblue:[0,0,139],darkcyan:[0,139,139],darkgrey:[169,169,169],darkgreen:[0,100,0],darkkhaki:[189,183,107],darkmagenta:[139,0,139],darkolivegreen:[85,107,47],darkorange:[255,140,0],darkorchid:[153,50,204],darkred:[139,0,0],darksalmon:[233,150,122],darkviolet:[148,0,211],fuchsia:[255,0,255],gold:[255,215,0],green:[0,128,0],indigo:[75,0,130],khaki:[240,230,140],lightblue:[173,216,230],lightcyan:[224,255,255],lightgreen:[144,238,144],lightgrey:[211,211,211],lightpink:[255,182,193],lightyellow:[255,255,224],lime:[0,255,0],magenta:[255,0,255],maroon:[128,0,0],navy:[0,0,128],olive:[128,128,0],orange:[255,165,0],pink:[255,192,203],purple:[128,0,128],violet:[128,0,128],red:[255,0,0],silver:[192,192,192],white:[255,255,255],yellow:[255,255,0]}})(jQuery); + +// the actual Flot code +(function($) { + function Plot(placeholder, data_, options_, plugins) { + // data is on the form: + // [ series1, series2 ... ] + // where series is either just the data as [ [x1, y1], [x2, y2], ... ] + // or { data: [ [x1, y1], [x2, y2], ... ], label: "some label", ... } + + var series = [], + options = { + // the color theme used for graphs + colors: ["#edc240", "#afd8f8", "#cb4b4b", "#4da74d", "#9440ed"], + legend: { + show: true, + noColumns: 1, // number of colums in legend table + labelFormatter: null, // fn: string -> string + labelBoxBorderColor: "#ccc", // border color for the little label boxes + container: null, // container (as jQuery object) to put legend in, null means default on top of graph + position: "ne", // position of default legend container within plot + margin: 5, // distance from grid edge to default legend container within plot + backgroundColor: null, // null means auto-detect + backgroundOpacity: 0.85 // set to 0 to avoid background + }, + xaxis: { + show: null, // null = auto-detect, true = always, false = never + position: "bottom", // or "top" + mode: null, // null or "time" + color: null, // base color, labels, ticks + tickColor: null, // possibly different color of ticks, e.g. "rgba(0,0,0,0.15)" + transform: null, // null or f: number -> number to transform axis + inverseTransform: null, // if transform is set, this should be the inverse function + min: null, // min. value to show, null means set automatically + max: null, // max. value to show, null means set automatically + autoscaleMargin: null, // margin in % to add if auto-setting min/max + ticks: null, // either [1, 3] or [[1, "a"], 3] or (fn: axis info -> ticks) or app. number of ticks for auto-ticks + tickFormatter: null, // fn: number -> string + labelWidth: null, // size of tick labels in pixels + labelHeight: null, + reserveSpace: null, // whether to reserve space even if axis isn't shown + tickLength: null, // size in pixels of ticks, or "full" for whole line + alignTicksWithAxis: null, // axis number or null for no sync + + // mode specific options + tickDecimals: null, // no. of decimals, null means auto + tickSize: null, // number or [number, "unit"] + minTickSize: null, // number or [number, "unit"] + monthNames: null, // list of names of months + timeformat: null, // format string to use + twelveHourClock: false // 12 or 24 time in time mode + }, + yaxis: { + autoscaleMargin: 0.02, + position: "left" // or "right" + }, + xaxes: [], + yaxes: [], + series: { + points: { + show: false, + radius: 3, + lineWidth: 2, // in pixels + fill: true, + fillColor: "#ffffff", + symbol: "circle" // or callback + }, + lines: { + // we don't put in show: false so we can see + // whether lines were actively disabled + lineWidth: 2, // in pixels + fill: false, + fillColor: null, + steps: false + }, + bars: { + show: false, + lineWidth: 2, // in pixels + barWidth: 1, // in units of the x axis + fill: true, + fillColor: null, + align: "left", // or "center" + horizontal: false + }, + shadowSize: 3 + }, + grid: { + show: true, + aboveData: false, + color: "#545454", // primary color used for outline and labels + backgroundColor: null, // null for transparent, else color + borderColor: null, // set if different from the grid color + tickColor: null, // color for the ticks, e.g. "rgba(0,0,0,0.15)" + labelMargin: 5, // in pixels + axisMargin: 8, // in pixels + borderWidth: 2, // in pixels + minBorderMargin: null, // in pixels, null means taken from points radius + markings: null, // array of ranges or fn: axes -> array of ranges + markingsColor: "#f4f4f4", + markingsLineWidth: 2, + // interactive stuff + clickable: false, + hoverable: false, + autoHighlight: true, // highlight in case mouse is near + mouseActiveRadius: 10 // how far the mouse can be away to activate an item + }, + hooks: {} + }, + canvas = null, // the canvas for the plot itself + overlay = null, // canvas for interactive stuff on top of plot + eventHolder = null, // jQuery object that events should be bound to + ctx = null, octx = null, + xaxes = [], yaxes = [], + plotOffset = { left: 0, right: 0, top: 0, bottom: 0}, + canvasWidth = 0, canvasHeight = 0, + plotWidth = 0, plotHeight = 0, + hooks = { + processOptions: [], + processRawData: [], + processDatapoints: [], + drawSeries: [], + draw: [], + bindEvents: [], + drawOverlay: [], + shutdown: [] + }, + plot = this; + + // public functions + plot.setData = setData; + plot.setupGrid = setupGrid; + plot.draw = draw; + plot.getPlaceholder = function() { return placeholder; }; + plot.getCanvas = function() { return canvas; }; + plot.getPlotOffset = function() { return plotOffset; }; + plot.width = function () { return plotWidth; }; + plot.height = function () { return plotHeight; }; + plot.offset = function () { + var o = eventHolder.offset(); + o.left += plotOffset.left; + o.top += plotOffset.top; + return o; + }; + plot.getData = function () { return series; }; + plot.getAxes = function () { + var res = {}, i; + $.each(xaxes.concat(yaxes), function (_, axis) { + if (axis) + res[axis.direction + (axis.n != 1 ? axis.n : "") + "axis"] = axis; + }); + return res; + }; + plot.getXAxes = function () { return xaxes; }; + plot.getYAxes = function () { return yaxes; }; + plot.c2p = canvasToAxisCoords; + plot.p2c = axisToCanvasCoords; + plot.getOptions = function () { return options; }; + plot.highlight = highlight; + plot.unhighlight = unhighlight; + plot.triggerRedrawOverlay = triggerRedrawOverlay; + plot.pointOffset = function(point) { + return { + left: parseInt(xaxes[axisNumber(point, "x") - 1].p2c(+point.x) + plotOffset.left), + top: parseInt(yaxes[axisNumber(point, "y") - 1].p2c(+point.y) + plotOffset.top) + }; + }; + plot.shutdown = shutdown; + plot.resize = function () { + getCanvasDimensions(); + resizeCanvas(canvas); + resizeCanvas(overlay); + }; + + // public attributes + plot.hooks = hooks; + + // initialize + initPlugins(plot); + parseOptions(options_); + setupCanvases(); + setData(data_); + setupGrid(); + draw(); + bindEvents(); + + + function executeHooks(hook, args) { + args = [plot].concat(args); + for (var i = 0; i < hook.length; ++i) + hook[i].apply(this, args); + } + + function initPlugins() { + for (var i = 0; i < plugins.length; ++i) { + var p = plugins[i]; + p.init(plot); + if (p.options) + $.extend(true, options, p.options); + } + } + + function parseOptions(opts) { + var i; + + $.extend(true, options, opts); + + if (options.xaxis.color == null) + options.xaxis.color = options.grid.color; + if (options.yaxis.color == null) + options.yaxis.color = options.grid.color; + + if (options.xaxis.tickColor == null) // backwards-compatibility + options.xaxis.tickColor = options.grid.tickColor; + if (options.yaxis.tickColor == null) // backwards-compatibility + options.yaxis.tickColor = options.grid.tickColor; + + if (options.grid.borderColor == null) + options.grid.borderColor = options.grid.color; + if (options.grid.tickColor == null) + options.grid.tickColor = $.color.parse(options.grid.color).scale('a', 0.22).toString(); + + // fill in defaults in axes, copy at least always the + // first as the rest of the code assumes it'll be there + for (i = 0; i < Math.max(1, options.xaxes.length); ++i) + options.xaxes[i] = $.extend(true, {}, options.xaxis, options.xaxes[i]); + for (i = 0; i < Math.max(1, options.yaxes.length); ++i) + options.yaxes[i] = $.extend(true, {}, options.yaxis, options.yaxes[i]); + + // backwards compatibility, to be removed in future + if (options.xaxis.noTicks && options.xaxis.ticks == null) + options.xaxis.ticks = options.xaxis.noTicks; + if (options.yaxis.noTicks && options.yaxis.ticks == null) + options.yaxis.ticks = options.yaxis.noTicks; + if (options.x2axis) { + options.xaxes[1] = $.extend(true, {}, options.xaxis, options.x2axis); + options.xaxes[1].position = "top"; + } + if (options.y2axis) { + options.yaxes[1] = $.extend(true, {}, options.yaxis, options.y2axis); + options.yaxes[1].position = "right"; + } + if (options.grid.coloredAreas) + options.grid.markings = options.grid.coloredAreas; + if (options.grid.coloredAreasColor) + options.grid.markingsColor = options.grid.coloredAreasColor; + if (options.lines) + $.extend(true, options.series.lines, options.lines); + if (options.points) + $.extend(true, options.series.points, options.points); + if (options.bars) + $.extend(true, options.series.bars, options.bars); + if (options.shadowSize != null) + options.series.shadowSize = options.shadowSize; + + // save options on axes for future reference + for (i = 0; i < options.xaxes.length; ++i) + getOrCreateAxis(xaxes, i + 1).options = options.xaxes[i]; + for (i = 0; i < options.yaxes.length; ++i) + getOrCreateAxis(yaxes, i + 1).options = options.yaxes[i]; + + // add hooks from options + for (var n in hooks) + if (options.hooks[n] && options.hooks[n].length) + hooks[n] = hooks[n].concat(options.hooks[n]); + + executeHooks(hooks.processOptions, [options]); + } + + function setData(d) { + series = parseData(d); + fillInSeriesOptions(); + processData(); + } + + function parseData(d) { + var res = []; + for (var i = 0; i < d.length; ++i) { + var s = $.extend(true, {}, options.series); + + if (d[i].data != null) { + s.data = d[i].data; // move the data instead of deep-copy + delete d[i].data; + + $.extend(true, s, d[i]); + + d[i].data = s.data; + } + else + s.data = d[i]; + res.push(s); + } + + return res; + } + + function axisNumber(obj, coord) { + var a = obj[coord + "axis"]; + if (typeof a == "object") // if we got a real axis, extract number + a = a.n; + if (typeof a != "number") + a = 1; // default to first axis + return a; + } + + function allAxes() { + // return flat array without annoying null entries + return $.grep(xaxes.concat(yaxes), function (a) { return a; }); + } + + function canvasToAxisCoords(pos) { + // return an object with x/y corresponding to all used axes + var res = {}, i, axis; + for (i = 0; i < xaxes.length; ++i) { + axis = xaxes[i]; + if (axis && axis.used) + res["x" + axis.n] = axis.c2p(pos.left); + } + + for (i = 0; i < yaxes.length; ++i) { + axis = yaxes[i]; + if (axis && axis.used) + res["y" + axis.n] = axis.c2p(pos.top); + } + + if (res.x1 !== undefined) + res.x = res.x1; + if (res.y1 !== undefined) + res.y = res.y1; + + return res; + } + + function axisToCanvasCoords(pos) { + // get canvas coords from the first pair of x/y found in pos + var res = {}, i, axis, key; + + for (i = 0; i < xaxes.length; ++i) { + axis = xaxes[i]; + if (axis && axis.used) { + key = "x" + axis.n; + if (pos[key] == null && axis.n == 1) + key = "x"; + + if (pos[key] != null) { + res.left = axis.p2c(pos[key]); + break; + } + } + } + + for (i = 0; i < yaxes.length; ++i) { + axis = yaxes[i]; + if (axis && axis.used) { + key = "y" + axis.n; + if (pos[key] == null && axis.n == 1) + key = "y"; + + if (pos[key] != null) { + res.top = axis.p2c(pos[key]); + break; + } + } + } + + return res; + } + + function getOrCreateAxis(axes, number) { + if (!axes[number - 1]) + axes[number - 1] = { + n: number, // save the number for future reference + direction: axes == xaxes ? "x" : "y", + options: $.extend(true, {}, axes == xaxes ? options.xaxis : options.yaxis) + }; + + return axes[number - 1]; + } + + function fillInSeriesOptions() { + var i; + + // collect what we already got of colors + var neededColors = series.length, + usedColors = [], + assignedColors = []; + for (i = 0; i < series.length; ++i) { + var sc = series[i].color; + if (sc != null) { + --neededColors; + if (typeof sc == "number") + assignedColors.push(sc); + else + usedColors.push($.color.parse(series[i].color)); + } + } + + // we might need to generate more colors if higher indices + // are assigned + for (i = 0; i < assignedColors.length; ++i) { + neededColors = Math.max(neededColors, assignedColors[i] + 1); + } + + // produce colors as needed + var colors = [], variation = 0; + i = 0; + while (colors.length < neededColors) { + var c; + if (options.colors.length == i) // check degenerate case + c = $.color.make(100, 100, 100); + else + c = $.color.parse(options.colors[i]); + + // vary color if needed + var sign = variation % 2 == 1 ? -1 : 1; + c.scale('rgb', 1 + sign * Math.ceil(variation / 2) * 0.2) + + // FIXME: if we're getting to close to something else, + // we should probably skip this one + colors.push(c); + + ++i; + if (i >= options.colors.length) { + i = 0; + ++variation; + } + } + + // fill in the options + var colori = 0, s; + for (i = 0; i < series.length; ++i) { + s = series[i]; + + // assign colors + if (s.color == null) { + s.color = colors[colori].toString(); + ++colori; + } + else if (typeof s.color == "number") + s.color = colors[s.color].toString(); + + // turn on lines automatically in case nothing is set + if (s.lines.show == null) { + var v, show = true; + for (v in s) + if (s[v] && s[v].show) { + show = false; + break; + } + if (show) + s.lines.show = true; + } + + // setup axes + s.xaxis = getOrCreateAxis(xaxes, axisNumber(s, "x")); + s.yaxis = getOrCreateAxis(yaxes, axisNumber(s, "y")); + } + } + + function processData() { + var topSentry = Number.POSITIVE_INFINITY, + bottomSentry = Number.NEGATIVE_INFINITY, + fakeInfinity = Number.MAX_VALUE, + i, j, k, m, length, + s, points, ps, x, y, axis, val, f, p; + + function updateAxis(axis, min, max) { + if (min < axis.datamin && min != -fakeInfinity) + axis.datamin = min; + if (max > axis.datamax && max != fakeInfinity) + axis.datamax = max; + } + + $.each(allAxes(), function (_, axis) { + // init axis + axis.datamin = topSentry; + axis.datamax = bottomSentry; + axis.used = false; + }); + + for (i = 0; i < series.length; ++i) { + s = series[i]; + s.datapoints = { points: [] }; + + executeHooks(hooks.processRawData, [ s, s.data, s.datapoints ]); + } + + // first pass: clean and copy data + for (i = 0; i < series.length; ++i) { + s = series[i]; + + var data = s.data, format = s.datapoints.format; + + if (!format) { + format = []; + // find out how to copy + format.push({ x: true, number: true, required: true }); + format.push({ y: true, number: true, required: true }); + + if (s.bars.show || (s.lines.show && s.lines.fill)) { + format.push({ y: true, number: true, required: false, defaultValue: 0 }); + if (s.bars.horizontal) { + delete format[format.length - 1].y; + format[format.length - 1].x = true; + } + } + + s.datapoints.format = format; + } + + if (s.datapoints.pointsize != null) + continue; // already filled in + + s.datapoints.pointsize = format.length; + + ps = s.datapoints.pointsize; + points = s.datapoints.points; + + insertSteps = s.lines.show && s.lines.steps; + s.xaxis.used = s.yaxis.used = true; + + for (j = k = 0; j < data.length; ++j, k += ps) { + p = data[j]; + + var nullify = p == null; + if (!nullify) { + for (m = 0; m < ps; ++m) { + val = p[m]; + f = format[m]; + + if (f) { + if (f.number && val != null) { + val = +val; // convert to number + if (isNaN(val)) + val = null; + else if (val == Infinity) + val = fakeInfinity; + else if (val == -Infinity) + val = -fakeInfinity; + } + + if (val == null) { + if (f.required) + nullify = true; + + if (f.defaultValue != null) + val = f.defaultValue; + } + } + + points[k + m] = val; + } + } + + if (nullify) { + for (m = 0; m < ps; ++m) { + val = points[k + m]; + if (val != null) { + f = format[m]; + // extract min/max info + if (f.x) + updateAxis(s.xaxis, val, val); + if (f.y) + updateAxis(s.yaxis, val, val); + } + points[k + m] = null; + } + } + else { + // a little bit of line specific stuff that + // perhaps shouldn't be here, but lacking + // better means... + if (insertSteps && k > 0 + && points[k - ps] != null + && points[k - ps] != points[k] + && points[k - ps + 1] != points[k + 1]) { + // copy the point to make room for a middle point + for (m = 0; m < ps; ++m) + points[k + ps + m] = points[k + m]; + + // middle point has same y + points[k + 1] = points[k - ps + 1]; + + // we've added a point, better reflect that + k += ps; + } + } + } + } + + // give the hooks a chance to run + for (i = 0; i < series.length; ++i) { + s = series[i]; + + executeHooks(hooks.processDatapoints, [ s, s.datapoints]); + } + + // second pass: find datamax/datamin for auto-scaling + for (i = 0; i < series.length; ++i) { + s = series[i]; + points = s.datapoints.points, + ps = s.datapoints.pointsize; + + var xmin = topSentry, ymin = topSentry, + xmax = bottomSentry, ymax = bottomSentry; + + for (j = 0; j < points.length; j += ps) { + if (points[j] == null) + continue; + + for (m = 0; m < ps; ++m) { + val = points[j + m]; + f = format[m]; + if (!f || val == fakeInfinity || val == -fakeInfinity) + continue; + + if (f.x) { + if (val < xmin) + xmin = val; + if (val > xmax) + xmax = val; + } + if (f.y) { + if (val < ymin) + ymin = val; + if (val > ymax) + ymax = val; + } + } + } + + if (s.bars.show) { + // make sure we got room for the bar on the dancing floor + var delta = s.bars.align == "left" ? 0 : -s.bars.barWidth/2; + if (s.bars.horizontal) { + ymin += delta; + ymax += delta + s.bars.barWidth; + } + else { + xmin += delta; + xmax += delta + s.bars.barWidth; + } + } + + updateAxis(s.xaxis, xmin, xmax); + updateAxis(s.yaxis, ymin, ymax); + } + + $.each(allAxes(), function (_, axis) { + if (axis.datamin == topSentry) + axis.datamin = null; + if (axis.datamax == bottomSentry) + axis.datamax = null; + }); + } + + function makeCanvas(skipPositioning, cls) { + var c = document.createElement('canvas'); + c.className = cls; + c.width = canvasWidth; + c.height = canvasHeight; + + if (!skipPositioning) + $(c).css({ position: 'absolute', left: 0, top: 0 }); + + $(c).appendTo(placeholder); + + if (!c.getContext) // excanvas hack + c = window.G_vmlCanvasManager.initElement(c); + + // used for resetting in case we get replotted + c.getContext("2d").save(); + + return c; + } + + function getCanvasDimensions() { + canvasWidth = placeholder.width(); + canvasHeight = placeholder.height(); + + if (canvasWidth <= 0 || canvasHeight <= 0) + throw "Invalid dimensions for plot, width = " + canvasWidth + ", height = " + canvasHeight; + } + + function resizeCanvas(c) { + // resizing should reset the state (excanvas seems to be + // buggy though) + if (c.width != canvasWidth) + c.width = canvasWidth; + + if (c.height != canvasHeight) + c.height = canvasHeight; + + // so try to get back to the initial state (even if it's + // gone now, this should be safe according to the spec) + var cctx = c.getContext("2d"); + cctx.restore(); + + // and save again + cctx.save(); + } + + function setupCanvases() { + var reused, + existingCanvas = placeholder.children("canvas.base"), + existingOverlay = placeholder.children("canvas.overlay"); + + if (existingCanvas.length == 0 || existingOverlay == 0) { + // init everything + + placeholder.html(""); // make sure placeholder is clear + + placeholder.css({ padding: 0 }); // padding messes up the positioning + + if (placeholder.css("position") == 'static') + placeholder.css("position", "relative"); // for positioning labels and overlay + + getCanvasDimensions(); + + canvas = makeCanvas(true, "base"); + overlay = makeCanvas(false, "overlay"); // overlay canvas for interactive features + + reused = false; + } + else { + // reuse existing elements + + canvas = existingCanvas.get(0); + overlay = existingOverlay.get(0); + + reused = true; + } + + ctx = canvas.getContext("2d"); + octx = overlay.getContext("2d"); + + // we include the canvas in the event holder too, because IE 7 + // sometimes has trouble with the stacking order + eventHolder = $([overlay, canvas]); + + if (reused) { + // run shutdown in the old plot object + placeholder.data("plot").shutdown(); + + // reset reused canvases + plot.resize(); + + // make sure overlay pixels are cleared (canvas is cleared when we redraw) + octx.clearRect(0, 0, canvasWidth, canvasHeight); + + // then whack any remaining obvious garbage left + eventHolder.unbind(); + placeholder.children().not([canvas, overlay]).remove(); + } + + // save in case we get replotted + placeholder.data("plot", plot); + } + + function bindEvents() { + // bind events + if (options.grid.hoverable) { + eventHolder.mousemove(onMouseMove); + eventHolder.mouseleave(onMouseLeave); + } + + if (options.grid.clickable) + eventHolder.click(onClick); + + executeHooks(hooks.bindEvents, [eventHolder]); + } + + function shutdown() { + if (redrawTimeout) + clearTimeout(redrawTimeout); + + eventHolder.unbind("mousemove", onMouseMove); + eventHolder.unbind("mouseleave", onMouseLeave); + eventHolder.unbind("click", onClick); + + executeHooks(hooks.shutdown, [eventHolder]); + } + + function setTransformationHelpers(axis) { + // set helper functions on the axis, assumes plot area + // has been computed already + + function identity(x) { return x; } + + var s, m, t = axis.options.transform || identity, + it = axis.options.inverseTransform; + + // precompute how much the axis is scaling a point + // in canvas space + if (axis.direction == "x") { + s = axis.scale = plotWidth / Math.abs(t(axis.max) - t(axis.min)); + m = Math.min(t(axis.max), t(axis.min)); + } + else { + s = axis.scale = plotHeight / Math.abs(t(axis.max) - t(axis.min)); + s = -s; + m = Math.max(t(axis.max), t(axis.min)); + } + + // data point to canvas coordinate + if (t == identity) // slight optimization + axis.p2c = function (p) { return (p - m) * s; }; + else + axis.p2c = function (p) { return (t(p) - m) * s; }; + // canvas coordinate to data point + if (!it) + axis.c2p = function (c) { return m + c / s; }; + else + axis.c2p = function (c) { return it(m + c / s); }; + } + + function measureTickLabels(axis) { + var opts = axis.options, i, ticks = axis.ticks || [], labels = [], + l, w = opts.labelWidth, h = opts.labelHeight, dummyDiv; + + function makeDummyDiv(labels, width) { + return $('<div style="position:absolute;top:-10000px;' + width + 'font-size:smaller">' + + '<div class="' + axis.direction + 'Axis ' + axis.direction + axis.n + 'Axis">' + + labels.join("") + '</div></div>') + .appendTo(placeholder); + } + + if (axis.direction == "x") { + // to avoid measuring the widths of the labels (it's slow), we + // construct fixed-size boxes and put the labels inside + // them, we don't need the exact figures and the + // fixed-size box content is easy to center + if (w == null) + w = Math.floor(canvasWidth / (ticks.length > 0 ? ticks.length : 1)); + + // measure x label heights + if (h == null) { + labels = []; + for (i = 0; i < ticks.length; ++i) { + l = ticks[i].label; + if (l) + labels.push('<div class="tickLabel" style="float:left;width:' + w + 'px">' + l + '</div>'); + } + + if (labels.length > 0) { + // stick them all in the same div and measure + // collective height + labels.push('<div style="clear:left"></div>'); + dummyDiv = makeDummyDiv(labels, "width:10000px;"); + h = dummyDiv.height(); + dummyDiv.remove(); + } + } + } + else if (w == null || h == null) { + // calculate y label dimensions + for (i = 0; i < ticks.length; ++i) { + l = ticks[i].label; + if (l) + labels.push('<div class="tickLabel">' + l + '</div>'); + } + + if (labels.length > 0) { + dummyDiv = makeDummyDiv(labels, ""); + if (w == null) + w = dummyDiv.children().width(); + if (h == null) + h = dummyDiv.find("div.tickLabel").height(); + dummyDiv.remove(); + } + } + + if (w == null) + w = 0; + if (h == null) + h = 0; + + axis.labelWidth = w; + axis.labelHeight = h; + } + + function allocateAxisBoxFirstPhase(axis) { + // find the bounding box of the axis by looking at label + // widths/heights and ticks, make room by diminishing the + // plotOffset + + var lw = axis.labelWidth, + lh = axis.labelHeight, + pos = axis.options.position, + tickLength = axis.options.tickLength, + axismargin = options.grid.axisMargin, + padding = options.grid.labelMargin, + all = axis.direction == "x" ? xaxes : yaxes, + index; + + // determine axis margin + var samePosition = $.grep(all, function (a) { + return a && a.options.position == pos && a.reserveSpace; + }); + if ($.inArray(axis, samePosition) == samePosition.length - 1) + axismargin = 0; // outermost + + // determine tick length - if we're innermost, we can use "full" + if (tickLength == null) + tickLength = "full"; + + var sameDirection = $.grep(all, function (a) { + return a && a.reserveSpace; + }); + + var innermost = $.inArray(axis, sameDirection) == 0; + if (!innermost && tickLength == "full") + tickLength = 5; + + if (!isNaN(+tickLength)) + padding += +tickLength; + + // compute box + if (axis.direction == "x") { + lh += padding; + + if (pos == "bottom") { + plotOffset.bottom += lh + axismargin; + axis.box = { top: canvasHeight - plotOffset.bottom, height: lh }; + } + else { + axis.box = { top: plotOffset.top + axismargin, height: lh }; + plotOffset.top += lh + axismargin; + } + } + else { + lw += padding; + + if (pos == "left") { + axis.box = { left: plotOffset.left + axismargin, width: lw }; + plotOffset.left += lw + axismargin; + } + else { + plotOffset.right += lw + axismargin; + axis.box = { left: canvasWidth - plotOffset.right, width: lw }; + } + } + + // save for future reference + axis.position = pos; + axis.tickLength = tickLength; + axis.box.padding = padding; + axis.innermost = innermost; + } + + function allocateAxisBoxSecondPhase(axis) { + // set remaining bounding box coordinates + if (axis.direction == "x") { + axis.box.left = plotOffset.left; + axis.box.width = plotWidth; + } + else { + axis.box.top = plotOffset.top; + axis.box.height = plotHeight; + } + } + + function setupGrid() { + var i, axes = allAxes(); + + // first calculate the plot and axis box dimensions + + $.each(axes, function (_, axis) { + axis.show = axis.options.show; + if (axis.show == null) + axis.show = axis.used; // by default an axis is visible if it's got data + + axis.reserveSpace = axis.show || axis.options.reserveSpace; + + setRange(axis); + }); + + allocatedAxes = $.grep(axes, function (axis) { return axis.reserveSpace; }); + + plotOffset.left = plotOffset.right = plotOffset.top = plotOffset.bottom = 0; + if (options.grid.show) { + $.each(allocatedAxes, function (_, axis) { + // make the ticks + setupTickGeneration(axis); + setTicks(axis); + snapRangeToTicks(axis, axis.ticks); + + // find labelWidth/Height for axis + measureTickLabels(axis); + }); + + // with all dimensions in house, we can compute the + // axis boxes, start from the outside (reverse order) + for (i = allocatedAxes.length - 1; i >= 0; --i) + allocateAxisBoxFirstPhase(allocatedAxes[i]); + + // make sure we've got enough space for things that + // might stick out + var minMargin = options.grid.minBorderMargin; + if (minMargin == null) { + minMargin = 0; + for (i = 0; i < series.length; ++i) + minMargin = Math.max(minMargin, series[i].points.radius + series[i].points.lineWidth/2); + } + + for (var a in plotOffset) { + plotOffset[a] += options.grid.borderWidth; + plotOffset[a] = Math.max(minMargin, plotOffset[a]); + } + } + + plotWidth = canvasWidth - plotOffset.left - plotOffset.right; + plotHeight = canvasHeight - plotOffset.bottom - plotOffset.top; + + // now we got the proper plotWidth/Height, we can compute the scaling + $.each(axes, function (_, axis) { + setTransformationHelpers(axis); + }); + + if (options.grid.show) { + $.each(allocatedAxes, function (_, axis) { + allocateAxisBoxSecondPhase(axis); + }); + + insertAxisLabels(); + } + + insertLegend(); + } + + function setRange(axis) { + var opts = axis.options, + min = +(opts.min != null ? opts.min : axis.datamin), + max = +(opts.max != null ? opts.max : axis.datamax), + delta = max - min; + + if (delta == 0.0) { + // degenerate case + var widen = max == 0 ? 1 : 0.01; + + if (opts.min == null) + min -= widen; + // always widen max if we couldn't widen min to ensure we + // don't fall into min == max which doesn't work + if (opts.max == null || opts.min != null) + max += widen; + } + else { + // consider autoscaling + var margin = opts.autoscaleMargin; + if (margin != null) { + if (opts.min == null) { + min -= delta * margin; + // make sure we don't go below zero if all values + // are positive + if (min < 0 && axis.datamin != null && axis.datamin >= 0) + min = 0; + } + if (opts.max == null) { + max += delta * margin; + if (max > 0 && axis.datamax != null && axis.datamax <= 0) + max = 0; + } + } + } + axis.min = min; + axis.max = max; + } + + function setupTickGeneration(axis) { + var opts = axis.options; + + // estimate number of ticks + var noTicks; + if (typeof opts.ticks == "number" && opts.ticks > 0) + noTicks = opts.ticks; + else + // heuristic based on the model a*sqrt(x) fitted to + // some data points that seemed reasonable + noTicks = 0.3 * Math.sqrt(axis.direction == "x" ? canvasWidth : canvasHeight); + + var delta = (axis.max - axis.min) / noTicks, + size, generator, unit, formatter, i, magn, norm; + + if (opts.mode == "time") { + // pretty handling of time + + // map of app. size of time units in milliseconds + var timeUnitSize = { + "second": 1000, + "minute": 60 * 1000, + "hour": 60 * 60 * 1000, + "day": 24 * 60 * 60 * 1000, + "month": 30 * 24 * 60 * 60 * 1000, + "year": 365.2425 * 24 * 60 * 60 * 1000 + }; + + + // the allowed tick sizes, after 1 year we use + // an integer algorithm + var spec = [ + [1, "second"], [2, "second"], [5, "second"], [10, "second"], + [30, "second"], + [1, "minute"], [2, "minute"], [5, "minute"], [10, "minute"], + [30, "minute"], + [1, "hour"], [2, "hour"], [4, "hour"], + [8, "hour"], [12, "hour"], + [1, "day"], [2, "day"], [3, "day"], + [0.25, "month"], [0.5, "month"], [1, "month"], + [2, "month"], [3, "month"], [6, "month"], + [1, "year"] + ]; + + var minSize = 0; + if (opts.minTickSize != null) { + if (typeof opts.tickSize == "number") + minSize = opts.tickSize; + else + minSize = opts.minTickSize[0] * timeUnitSize[opts.minTickSize[1]]; + } + + for (var i = 0; i < spec.length - 1; ++i) + if (delta < (spec[i][0] * timeUnitSize[spec[i][1]] + + spec[i + 1][0] * timeUnitSize[spec[i + 1][1]]) / 2 + && spec[i][0] * timeUnitSize[spec[i][1]] >= minSize) + break; + size = spec[i][0]; + unit = spec[i][1]; + + // special-case the possibility of several years + if (unit == "year") { + magn = Math.pow(10, Math.floor(Math.log(delta / timeUnitSize.year) / Math.LN10)); + norm = (delta / timeUnitSize.year) / magn; + if (norm < 1.5) + size = 1; + else if (norm < 3) + size = 2; + else if (norm < 7.5) + size = 5; + else + size = 10; + + size *= magn; + } + + axis.tickSize = opts.tickSize || [size, unit]; + + generator = function(axis) { + var ticks = [], + tickSize = axis.tickSize[0], unit = axis.tickSize[1], + d = new Date(axis.min); + + var step = tickSize * timeUnitSize[unit]; + + if (unit == "second") + d.setUTCSeconds(floorInBase(d.getUTCSeconds(), tickSize)); + if (unit == "minute") + d.setUTCMinutes(floorInBase(d.getUTCMinutes(), tickSize)); + if (unit == "hour") + d.setUTCHours(floorInBase(d.getUTCHours(), tickSize)); + if (unit == "month") + d.setUTCMonth(floorInBase(d.getUTCMonth(), tickSize)); + if (unit == "year") + d.setUTCFullYear(floorInBase(d.getUTCFullYear(), tickSize)); + + // reset smaller components + d.setUTCMilliseconds(0); + if (step >= timeUnitSize.minute) + d.setUTCSeconds(0); + if (step >= timeUnitSize.hour) + d.setUTCMinutes(0); + if (step >= timeUnitSize.day) + d.setUTCHours(0); + if (step >= timeUnitSize.day * 4) + d.setUTCDate(1); + if (step >= timeUnitSize.year) + d.setUTCMonth(0); + + + var carry = 0, v = Number.NaN, prev; + do { + prev = v; + v = d.getTime(); + ticks.push(v); + if (unit == "month") { + if (tickSize < 1) { + // a bit complicated - we'll divide the month + // up but we need to take care of fractions + // so we don't end up in the middle of a day + d.setUTCDate(1); + var start = d.getTime(); + d.setUTCMonth(d.getUTCMonth() + 1); + var end = d.getTime(); + d.setTime(v + carry * timeUnitSize.hour + (end - start) * tickSize); + carry = d.getUTCHours(); + d.setUTCHours(0); + } + else + d.setUTCMonth(d.getUTCMonth() + tickSize); + } + else if (unit == "year") { + d.setUTCFullYear(d.getUTCFullYear() + tickSize); + } + else + d.setTime(v + step); + } while (v < axis.max && v != prev); + + return ticks; + }; + + formatter = function (v, axis) { + var d = new Date(v); + + // first check global format + if (opts.timeformat != null) + return $.plot.formatDate(d, opts.timeformat, opts.monthNames); + + var t = axis.tickSize[0] * timeUnitSize[axis.tickSize[1]]; + var span = axis.max - axis.min; + var suffix = (opts.twelveHourClock) ? " %p" : ""; + + if (t < timeUnitSize.minute) + fmt = "%h:%M:%S" + suffix; + else if (t < timeUnitSize.day) { + if (span < 2 * timeUnitSize.day) + fmt = "%h:%M" + suffix; + else + fmt = "%b %d %h:%M" + suffix; + } + else if (t < timeUnitSize.month) + fmt = "%b %d"; + else if (t < timeUnitSize.year) { + if (span < timeUnitSize.year) + fmt = "%b"; + else + fmt = "%b %y"; + } + else + fmt = "%y"; + + return $.plot.formatDate(d, fmt, opts.monthNames); + }; + } + else { + // pretty rounding of base-10 numbers + var maxDec = opts.tickDecimals; + var dec = -Math.floor(Math.log(delta) / Math.LN10); + if (maxDec != null && dec > maxDec) + dec = maxDec; + + magn = Math.pow(10, -dec); + norm = delta / magn; // norm is between 1.0 and 10.0 + + if (norm < 1.5) + size = 1; + else if (norm < 3) { + size = 2; + // special case for 2.5, requires an extra decimal + if (norm > 2.25 && (maxDec == null || dec + 1 <= maxDec)) { + size = 2.5; + ++dec; + } + } + else if (norm < 7.5) + size = 5; + else + size = 10; + + size *= magn; + + if (opts.minTickSize != null && size < opts.minTickSize) + size = opts.minTickSize; + + axis.tickDecimals = Math.max(0, maxDec != null ? maxDec : dec); + axis.tickSize = opts.tickSize || size; + + generator = function (axis) { + var ticks = []; + + // spew out all possible ticks + var start = floorInBase(axis.min, axis.tickSize), + i = 0, v = Number.NaN, prev; + do { + prev = v; + v = start + i * axis.tickSize; + ticks.push(v); + ++i; + } while (v < axis.max && v != prev); + return ticks; + }; + + formatter = function (v, axis) { + return v.toFixed(axis.tickDecimals); + }; + } + + if (opts.alignTicksWithAxis != null) { + var otherAxis = (axis.direction == "x" ? xaxes : yaxes)[opts.alignTicksWithAxis - 1]; + if (otherAxis && otherAxis.used && otherAxis != axis) { + // consider snapping min/max to outermost nice ticks + var niceTicks = generator(axis); + if (niceTicks.length > 0) { + if (opts.min == null) + axis.min = Math.min(axis.min, niceTicks[0]); + if (opts.max == null && niceTicks.length > 1) + axis.max = Math.max(axis.max, niceTicks[niceTicks.length - 1]); + } + + generator = function (axis) { + // copy ticks, scaled to this axis + var ticks = [], v, i; + for (i = 0; i < otherAxis.ticks.length; ++i) { + v = (otherAxis.ticks[i].v - otherAxis.min) / (otherAxis.max - otherAxis.min); + v = axis.min + v * (axis.max - axis.min); + ticks.push(v); + } + return ticks; + }; + + // we might need an extra decimal since forced + // ticks don't necessarily fit naturally + if (axis.mode != "time" && opts.tickDecimals == null) { + var extraDec = Math.max(0, -Math.floor(Math.log(delta) / Math.LN10) + 1), + ts = generator(axis); + + // only proceed if the tick interval rounded + // with an extra decimal doesn't give us a + // zero at end + if (!(ts.length > 1 && /\..*0$/.test((ts[1] - ts[0]).toFixed(extraDec)))) + axis.tickDecimals = extraDec; + } + } + } + + axis.tickGenerator = generator; + if ($.isFunction(opts.tickFormatter)) + axis.tickFormatter = function (v, axis) { return "" + opts.tickFormatter(v, axis); }; + else + axis.tickFormatter = formatter; + } + + function setTicks(axis) { + var oticks = axis.options.ticks, ticks = []; + if (oticks == null || (typeof oticks == "number" && oticks > 0)) + ticks = axis.tickGenerator(axis); + else if (oticks) { + if ($.isFunction(oticks)) + // generate the ticks + ticks = oticks({ min: axis.min, max: axis.max }); + else + ticks = oticks; + } + + // clean up/labelify the supplied ticks, copy them over + var i, v; + axis.ticks = []; + for (i = 0; i < ticks.length; ++i) { + var label = null; + var t = ticks[i]; + if (typeof t == "object") { + v = +t[0]; + if (t.length > 1) + label = t[1]; + } + else + v = +t; + if (label == null) + label = axis.tickFormatter(v, axis); + if (!isNaN(v)) + axis.ticks.push({ v: v, label: label }); + } + } + + function snapRangeToTicks(axis, ticks) { + if (axis.options.autoscaleMargin && ticks.length > 0) { + // snap to ticks + if (axis.options.min == null) + axis.min = Math.min(axis.min, ticks[0].v); + if (axis.options.max == null && ticks.length > 1) + axis.max = Math.max(axis.max, ticks[ticks.length - 1].v); + } + } + + function draw() { + ctx.clearRect(0, 0, canvasWidth, canvasHeight); + + var grid = options.grid; + + // draw background, if any + if (grid.show && grid.backgroundColor) + drawBackground(); + + if (grid.show && !grid.aboveData) + drawGrid(); + + for (var i = 0; i < series.length; ++i) { + executeHooks(hooks.drawSeries, [ctx, series[i]]); + drawSeries(series[i]); + } + + executeHooks(hooks.draw, [ctx]); + + if (grid.show && grid.aboveData) + drawGrid(); + } + + function extractRange(ranges, coord) { + var axis, from, to, key, axes = allAxes(); + + for (i = 0; i < axes.length; ++i) { + axis = axes[i]; + if (axis.direction == coord) { + key = coord + axis.n + "axis"; + if (!ranges[key] && axis.n == 1) + key = coord + "axis"; // support x1axis as xaxis + if (ranges[key]) { + from = ranges[key].from; + to = ranges[key].to; + break; + } + } + } + + // backwards-compat stuff - to be removed in future + if (!ranges[key]) { + axis = coord == "x" ? xaxes[0] : yaxes[0]; + from = ranges[coord + "1"]; + to = ranges[coord + "2"]; + } + + // auto-reverse as an added bonus + if (from != null && to != null && from > to) { + var tmp = from; + from = to; + to = tmp; + } + + return { from: from, to: to, axis: axis }; + } + + function drawBackground() { + ctx.save(); + ctx.translate(plotOffset.left, plotOffset.top); + + ctx.fillStyle = getColorOrGradient(options.grid.backgroundColor, plotHeight, 0, "rgba(255, 255, 255, 0)"); + ctx.fillRect(0, 0, plotWidth, plotHeight); + ctx.restore(); + } + + function drawGrid() { + var i; + + ctx.save(); + ctx.translate(plotOffset.left, plotOffset.top); + + // draw markings + var markings = options.grid.markings; + if (markings) { + if ($.isFunction(markings)) { + var axes = plot.getAxes(); + // xmin etc. is backwards compatibility, to be + // removed in the future + axes.xmin = axes.xaxis.min; + axes.xmax = axes.xaxis.max; + axes.ymin = axes.yaxis.min; + axes.ymax = axes.yaxis.max; + + markings = markings(axes); + } + + for (i = 0; i < markings.length; ++i) { + var m = markings[i], + xrange = extractRange(m, "x"), + yrange = extractRange(m, "y"); + + // fill in missing + if (xrange.from == null) + xrange.from = xrange.axis.min; + if (xrange.to == null) + xrange.to = xrange.axis.max; + if (yrange.from == null) + yrange.from = yrange.axis.min; + if (yrange.to == null) + yrange.to = yrange.axis.max; + + // clip + if (xrange.to < xrange.axis.min || xrange.from > xrange.axis.max || + yrange.to < yrange.axis.min || yrange.from > yrange.axis.max) + continue; + + xrange.from = Math.max(xrange.from, xrange.axis.min); + xrange.to = Math.min(xrange.to, xrange.axis.max); + yrange.from = Math.max(yrange.from, yrange.axis.min); + yrange.to = Math.min(yrange.to, yrange.axis.max); + + if (xrange.from == xrange.to && yrange.from == yrange.to) + continue; + + // then draw + xrange.from = xrange.axis.p2c(xrange.from); + xrange.to = xrange.axis.p2c(xrange.to); + yrange.from = yrange.axis.p2c(yrange.from); + yrange.to = yrange.axis.p2c(yrange.to); + + if (xrange.from == xrange.to || yrange.from == yrange.to) { + // draw line + ctx.beginPath(); + ctx.strokeStyle = m.color || options.grid.markingsColor; + ctx.lineWidth = m.lineWidth || options.grid.markingsLineWidth; + ctx.moveTo(xrange.from, yrange.from); + ctx.lineTo(xrange.to, yrange.to); + ctx.stroke(); + } + else { + // fill area + ctx.fillStyle = m.color || options.grid.markingsColor; + ctx.fillRect(xrange.from, yrange.to, + xrange.to - xrange.from, + yrange.from - yrange.to); + } + } + } + + // draw the ticks + var axes = allAxes(), bw = options.grid.borderWidth; + + for (var j = 0; j < axes.length; ++j) { + var axis = axes[j], box = axis.box, + t = axis.tickLength, x, y, xoff, yoff; + if (!axis.show || axis.ticks.length == 0) + continue + + ctx.strokeStyle = axis.options.tickColor || $.color.parse(axis.options.color).scale('a', 0.22).toString(); + ctx.lineWidth = 1; + + // find the edges + if (axis.direction == "x") { + x = 0; + if (t == "full") + y = (axis.position == "top" ? 0 : plotHeight); + else + y = box.top - plotOffset.top + (axis.position == "top" ? box.height : 0); + } + else { + y = 0; + if (t == "full") + x = (axis.position == "left" ? 0 : plotWidth); + else + x = box.left - plotOffset.left + (axis.position == "left" ? box.width : 0); + } + + // draw tick bar + if (!axis.innermost) { + ctx.beginPath(); + xoff = yoff = 0; + if (axis.direction == "x") + xoff = plotWidth; + else + yoff = plotHeight; + + if (ctx.lineWidth == 1) { + x = Math.floor(x) + 0.5; + y = Math.floor(y) + 0.5; + } + + ctx.moveTo(x, y); + ctx.lineTo(x + xoff, y + yoff); + ctx.stroke(); + } + + // draw ticks + ctx.beginPath(); + for (i = 0; i < axis.ticks.length; ++i) { + var v = axis.ticks[i].v; + + xoff = yoff = 0; + + if (v < axis.min || v > axis.max + // skip those lying on the axes if we got a border + || (t == "full" && bw > 0 + && (v == axis.min || v == axis.max))) + continue; + + if (axis.direction == "x") { + x = axis.p2c(v); + yoff = t == "full" ? -plotHeight : t; + + if (axis.position == "top") + yoff = -yoff; + } + else { + y = axis.p2c(v); + xoff = t == "full" ? -plotWidth : t; + + if (axis.position == "left") + xoff = -xoff; + } + + if (ctx.lineWidth == 1) { + if (axis.direction == "x") + x = Math.floor(x) + 0.5; + else + y = Math.floor(y) + 0.5; + } + + ctx.moveTo(x, y); + ctx.lineTo(x + xoff, y + yoff); + } + + ctx.stroke(); + } + + + // draw border + if (bw) { + ctx.lineWidth = bw; + ctx.strokeStyle = options.grid.borderColor; + ctx.strokeRect(-bw/2, -bw/2, plotWidth + bw, plotHeight + bw); + } + + ctx.restore(); + } + + function insertAxisLabels() { + placeholder.find(".tickLabels").remove(); + + var html = ['<div class="tickLabels" style="font-size:smaller">']; + + var axes = allAxes(); + for (var j = 0; j < axes.length; ++j) { + var axis = axes[j], box = axis.box; + if (!axis.show) + continue; + //debug: html.push('<div style="position:absolute;opacity:0.10;background-color:red;left:' + box.left + 'px;top:' + box.top + 'px;width:' + box.width + 'px;height:' + box.height + 'px"></div>') + html.push('<div class="' + axis.direction + 'Axis ' + axis.direction + axis.n + 'Axis" style="color:' + axis.options.color + '">'); + for (var i = 0; i < axis.ticks.length; ++i) { + var tick = axis.ticks[i]; + if (!tick.label || tick.v < axis.min || tick.v > axis.max) + continue; + + var pos = {}, align; + + if (axis.direction == "x") { + align = "center"; + pos.left = Math.round(plotOffset.left + axis.p2c(tick.v) - axis.labelWidth/2); + if (axis.position == "bottom") + pos.top = box.top + box.padding; + else + pos.bottom = canvasHeight - (box.top + box.height - box.padding); + } + else { + pos.top = Math.round(plotOffset.top + axis.p2c(tick.v) - axis.labelHeight/2); + if (axis.position == "left") { + pos.right = canvasWidth - (box.left + box.width - box.padding) + align = "right"; + } + else { + pos.left = box.left + box.padding; + align = "left"; + } + } + + pos.width = axis.labelWidth; + + var style = ["position:absolute", "text-align:" + align ]; + for (var a in pos) + style.push(a + ":" + pos[a] + "px") + + html.push('<div class="tickLabel" style="' + style.join(';') + '">' + tick.label + '</div>'); + } + html.push('</div>'); + } + + html.push('</div>'); + + placeholder.append(html.join("")); + } + + function drawSeries(series) { + if (series.lines.show) + drawSeriesLines(series); + if (series.bars.show) + drawSeriesBars(series); + if (series.points.show) + drawSeriesPoints(series); + } + + function drawSeriesLines(series) { + function plotLine(datapoints, xoffset, yoffset, axisx, axisy) { + var points = datapoints.points, + ps = datapoints.pointsize, + prevx = null, prevy = null; + + ctx.beginPath(); + for (var i = ps; i < points.length; i += ps) { + var x1 = points[i - ps], y1 = points[i - ps + 1], + x2 = points[i], y2 = points[i + 1]; + + if (x1 == null || x2 == null) + continue; + + // clip with ymin + if (y1 <= y2 && y1 < axisy.min) { + if (y2 < axisy.min) + continue; // line segment is outside + // compute new intersection point + x1 = (axisy.min - y1) / (y2 - y1) * (x2 - x1) + x1; + y1 = axisy.min; + } + else if (y2 <= y1 && y2 < axisy.min) { + if (y1 < axisy.min) + continue; + x2 = (axisy.min - y1) / (y2 - y1) * (x2 - x1) + x1; + y2 = axisy.min; + } + + // clip with ymax + if (y1 >= y2 && y1 > axisy.max) { + if (y2 > axisy.max) + continue; + x1 = (axisy.max - y1) / (y2 - y1) * (x2 - x1) + x1; + y1 = axisy.max; + } + else if (y2 >= y1 && y2 > axisy.max) { + if (y1 > axisy.max) + continue; + x2 = (axisy.max - y1) / (y2 - y1) * (x2 - x1) + x1; + y2 = axisy.max; + } + + // clip with xmin + if (x1 <= x2 && x1 < axisx.min) { + if (x2 < axisx.min) + continue; + y1 = (axisx.min - x1) / (x2 - x1) * (y2 - y1) + y1; + x1 = axisx.min; + } + else if (x2 <= x1 && x2 < axisx.min) { + if (x1 < axisx.min) + continue; + y2 = (axisx.min - x1) / (x2 - x1) * (y2 - y1) + y1; + x2 = axisx.min; + } + + // clip with xmax + if (x1 >= x2 && x1 > axisx.max) { + if (x2 > axisx.max) + continue; + y1 = (axisx.max - x1) / (x2 - x1) * (y2 - y1) + y1; + x1 = axisx.max; + } + else if (x2 >= x1 && x2 > axisx.max) { + if (x1 > axisx.max) + continue; + y2 = (axisx.max - x1) / (x2 - x1) * (y2 - y1) + y1; + x2 = axisx.max; + } + + if (x1 != prevx || y1 != prevy) + ctx.moveTo(axisx.p2c(x1) + xoffset, axisy.p2c(y1) + yoffset); + + prevx = x2; + prevy = y2; + ctx.lineTo(axisx.p2c(x2) + xoffset, axisy.p2c(y2) + yoffset); + } + ctx.stroke(); + } + + function plotLineArea(datapoints, axisx, axisy) { + var points = datapoints.points, + ps = datapoints.pointsize, + bottom = Math.min(Math.max(0, axisy.min), axisy.max), + i = 0, top, areaOpen = false, + ypos = 1, segmentStart = 0, segmentEnd = 0; + + // we process each segment in two turns, first forward + // direction to sketch out top, then once we hit the + // end we go backwards to sketch the bottom + while (true) { + if (ps > 0 && i > points.length + ps) + break; + + i += ps; // ps is negative if going backwards + + var x1 = points[i - ps], + y1 = points[i - ps + ypos], + x2 = points[i], y2 = points[i + ypos]; + + if (areaOpen) { + if (ps > 0 && x1 != null && x2 == null) { + // at turning point + segmentEnd = i; + ps = -ps; + ypos = 2; + continue; + } + + if (ps < 0 && i == segmentStart + ps) { + // done with the reverse sweep + ctx.fill(); + areaOpen = false; + ps = -ps; + ypos = 1; + i = segmentStart = segmentEnd + ps; + continue; + } + } + + if (x1 == null || x2 == null) + continue; + + // clip x values + + // clip with xmin + if (x1 <= x2 && x1 < axisx.min) { + if (x2 < axisx.min) + continue; + y1 = (axisx.min - x1) / (x2 - x1) * (y2 - y1) + y1; + x1 = axisx.min; + } + else if (x2 <= x1 && x2 < axisx.min) { + if (x1 < axisx.min) + continue; + y2 = (axisx.min - x1) / (x2 - x1) * (y2 - y1) + y1; + x2 = axisx.min; + } + + // clip with xmax + if (x1 >= x2 && x1 > axisx.max) { + if (x2 > axisx.max) + continue; + y1 = (axisx.max - x1) / (x2 - x1) * (y2 - y1) + y1; + x1 = axisx.max; + } + else if (x2 >= x1 && x2 > axisx.max) { + if (x1 > axisx.max) + continue; + y2 = (axisx.max - x1) / (x2 - x1) * (y2 - y1) + y1; + x2 = axisx.max; + } + + if (!areaOpen) { + // open area + ctx.beginPath(); + ctx.moveTo(axisx.p2c(x1), axisy.p2c(bottom)); + areaOpen = true; + } + + // now first check the case where both is outside + if (y1 >= axisy.max && y2 >= axisy.max) { + ctx.lineTo(axisx.p2c(x1), axisy.p2c(axisy.max)); + ctx.lineTo(axisx.p2c(x2), axisy.p2c(axisy.max)); + continue; + } + else if (y1 <= axisy.min && y2 <= axisy.min) { + ctx.lineTo(axisx.p2c(x1), axisy.p2c(axisy.min)); + ctx.lineTo(axisx.p2c(x2), axisy.p2c(axisy.min)); + continue; + } + + // else it's a bit more complicated, there might + // be a flat maxed out rectangle first, then a + // triangular cutout or reverse; to find these + // keep track of the current x values + var x1old = x1, x2old = x2; + + // clip the y values, without shortcutting, we + // go through all cases in turn + + // clip with ymin + if (y1 <= y2 && y1 < axisy.min && y2 >= axisy.min) { + x1 = (axisy.min - y1) / (y2 - y1) * (x2 - x1) + x1; + y1 = axisy.min; + } + else if (y2 <= y1 && y2 < axisy.min && y1 >= axisy.min) { + x2 = (axisy.min - y1) / (y2 - y1) * (x2 - x1) + x1; + y2 = axisy.min; + } + + // clip with ymax + if (y1 >= y2 && y1 > axisy.max && y2 <= axisy.max) { + x1 = (axisy.max - y1) / (y2 - y1) * (x2 - x1) + x1; + y1 = axisy.max; + } + else if (y2 >= y1 && y2 > axisy.max && y1 <= axisy.max) { + x2 = (axisy.max - y1) / (y2 - y1) * (x2 - x1) + x1; + y2 = axisy.max; + } + + // if the x value was changed we got a rectangle + // to fill + if (x1 != x1old) { + ctx.lineTo(axisx.p2c(x1old), axisy.p2c(y1)); + // it goes to (x1, y1), but we fill that below + } + + // fill triangular section, this sometimes result + // in redundant points if (x1, y1) hasn't changed + // from previous line to, but we just ignore that + ctx.lineTo(axisx.p2c(x1), axisy.p2c(y1)); + ctx.lineTo(axisx.p2c(x2), axisy.p2c(y2)); + + // fill the other rectangle if it's there + if (x2 != x2old) { + ctx.lineTo(axisx.p2c(x2), axisy.p2c(y2)); + ctx.lineTo(axisx.p2c(x2old), axisy.p2c(y2)); + } + } + } + + ctx.save(); + ctx.translate(plotOffset.left, plotOffset.top); + ctx.lineJoin = "round"; + + var lw = series.lines.lineWidth, + sw = series.shadowSize; + // FIXME: consider another form of shadow when filling is turned on + if (lw > 0 && sw > 0) { + // draw shadow as a thick and thin line with transparency + ctx.lineWidth = sw; + ctx.strokeStyle = "rgba(0,0,0,0.1)"; + // position shadow at angle from the mid of line + var angle = Math.PI/18; + plotLine(series.datapoints, Math.sin(angle) * (lw/2 + sw/2), Math.cos(angle) * (lw/2 + sw/2), series.xaxis, series.yaxis); + ctx.lineWidth = sw/2; + plotLine(series.datapoints, Math.sin(angle) * (lw/2 + sw/4), Math.cos(angle) * (lw/2 + sw/4), series.xaxis, series.yaxis); + } + + ctx.lineWidth = lw; + ctx.strokeStyle = series.color; + var fillStyle = getFillStyle(series.lines, series.color, 0, plotHeight); + if (fillStyle) { + ctx.fillStyle = fillStyle; + plotLineArea(series.datapoints, series.xaxis, series.yaxis); + } + + if (lw > 0) + plotLine(series.datapoints, 0, 0, series.xaxis, series.yaxis); + ctx.restore(); + } + + function drawSeriesPoints(series) { + function plotPoints(datapoints, radius, fillStyle, offset, shadow, axisx, axisy, symbol) { + var points = datapoints.points, ps = datapoints.pointsize; + + for (var i = 0; i < points.length; i += ps) { + var x = points[i], y = points[i + 1]; + if (x == null || x < axisx.min || x > axisx.max || y < axisy.min || y > axisy.max) + continue; + + ctx.beginPath(); + x = axisx.p2c(x); + y = axisy.p2c(y) + offset; + if (symbol == "circle") + ctx.arc(x, y, radius, 0, shadow ? Math.PI : Math.PI * 2, false); + else + symbol(ctx, x, y, radius, shadow); + ctx.closePath(); + + if (fillStyle) { + ctx.fillStyle = fillStyle; + ctx.fill(); + } + ctx.stroke(); + } + } + + ctx.save(); + ctx.translate(plotOffset.left, plotOffset.top); + + var lw = series.points.lineWidth, + sw = series.shadowSize, + radius = series.points.radius, + symbol = series.points.symbol; + if (lw > 0 && sw > 0) { + // draw shadow in two steps + var w = sw / 2; + ctx.lineWidth = w; + ctx.strokeStyle = "rgba(0,0,0,0.1)"; + plotPoints(series.datapoints, radius, null, w + w/2, true, + series.xaxis, series.yaxis, symbol); + + ctx.strokeStyle = "rgba(0,0,0,0.2)"; + plotPoints(series.datapoints, radius, null, w/2, true, + series.xaxis, series.yaxis, symbol); + } + + ctx.lineWidth = lw; + ctx.strokeStyle = series.color; + plotPoints(series.datapoints, radius, + getFillStyle(series.points, series.color), 0, false, + series.xaxis, series.yaxis, symbol); + ctx.restore(); + } + + function drawBar(x, y, b, barLeft, barRight, offset, fillStyleCallback, axisx, axisy, c, horizontal, lineWidth) { + var left, right, bottom, top, + drawLeft, drawRight, drawTop, drawBottom, + tmp; + + // in horizontal mode, we start the bar from the left + // instead of from the bottom so it appears to be + // horizontal rather than vertical + if (horizontal) { + drawBottom = drawRight = drawTop = true; + drawLeft = false; + left = b; + right = x; + top = y + barLeft; + bottom = y + barRight; + + // account for negative bars + if (right < left) { + tmp = right; + right = left; + left = tmp; + drawLeft = true; + drawRight = false; + } + } + else { + drawLeft = drawRight = drawTop = true; + drawBottom = false; + left = x + barLeft; + right = x + barRight; + bottom = b; + top = y; + + // account for negative bars + if (top < bottom) { + tmp = top; + top = bottom; + bottom = tmp; + drawBottom = true; + drawTop = false; + } + } + + // clip + if (right < axisx.min || left > axisx.max || + top < axisy.min || bottom > axisy.max) + return; + + if (left < axisx.min) { + left = axisx.min; + drawLeft = false; + } + + if (right > axisx.max) { + right = axisx.max; + drawRight = false; + } + + if (bottom < axisy.min) { + bottom = axisy.min; + drawBottom = false; + } + + if (top > axisy.max) { + top = axisy.max; + drawTop = false; + } + + left = axisx.p2c(left); + bottom = axisy.p2c(bottom); + right = axisx.p2c(right); + top = axisy.p2c(top); + + // fill the bar + if (fillStyleCallback) { + c.beginPath(); + c.moveTo(left, bottom); + c.lineTo(left, top); + c.lineTo(right, top); + c.lineTo(right, bottom); + c.fillStyle = fillStyleCallback(bottom, top); + c.fill(); + } + + // draw outline + if (lineWidth > 0 && (drawLeft || drawRight || drawTop || drawBottom)) { + c.beginPath(); + + // FIXME: inline moveTo is buggy with excanvas + c.moveTo(left, bottom + offset); + if (drawLeft) + c.lineTo(left, top + offset); + else + c.moveTo(left, top + offset); + if (drawTop) + c.lineTo(right, top + offset); + else + c.moveTo(right, top + offset); + if (drawRight) + c.lineTo(right, bottom + offset); + else + c.moveTo(right, bottom + offset); + if (drawBottom) + c.lineTo(left, bottom + offset); + else + c.moveTo(left, bottom + offset); + c.stroke(); + } + } + + function drawSeriesBars(series) { + function plotBars(datapoints, barLeft, barRight, offset, fillStyleCallback, axisx, axisy) { + var points = datapoints.points, ps = datapoints.pointsize; + + for (var i = 0; i < points.length; i += ps) { + if (points[i] == null) + continue; + drawBar(points[i], points[i + 1], points[i + 2], barLeft, barRight, offset, fillStyleCallback, axisx, axisy, ctx, series.bars.horizontal, series.bars.lineWidth); + } + } + + ctx.save(); + ctx.translate(plotOffset.left, plotOffset.top); + + // FIXME: figure out a way to add shadows (for instance along the right edge) + ctx.lineWidth = series.bars.lineWidth; + ctx.strokeStyle = series.color; + var barLeft = series.bars.align == "left" ? 0 : -series.bars.barWidth/2; + var fillStyleCallback = series.bars.fill ? function (bottom, top) { return getFillStyle(series.bars, series.color, bottom, top); } : null; + plotBars(series.datapoints, barLeft, barLeft + series.bars.barWidth, 0, fillStyleCallback, series.xaxis, series.yaxis); + ctx.restore(); + } + + function getFillStyle(filloptions, seriesColor, bottom, top) { + var fill = filloptions.fill; + if (!fill) + return null; + + if (filloptions.fillColor) + return getColorOrGradient(filloptions.fillColor, bottom, top, seriesColor); + + var c = $.color.parse(seriesColor); + c.a = typeof fill == "number" ? fill : 0.4; + c.normalize(); + return c.toString(); + } + + function insertLegend() { + placeholder.find(".legend").remove(); + + if (!options.legend.show) + return; + + var fragments = [], rowStarted = false, + lf = options.legend.labelFormatter, s, label; + for (var i = 0; i < series.length; ++i) { + s = series[i]; + label = s.label; + if (!label) + continue; + + if (i % options.legend.noColumns == 0) { + if (rowStarted) + fragments.push('</tr>'); + fragments.push('<tr>'); + rowStarted = true; + } + + if (lf) + label = lf(label, s); + + fragments.push( + '<td class="legendColorBox"><div style="border:1px solid ' + options.legend.labelBoxBorderColor + ';padding:1px"><div style="width:4px;height:0;border:5px solid ' + s.color + ';overflow:hidden"></div></div></td>' + + '<td class="legendLabel">' + label + '</td>'); + } + if (rowStarted) + fragments.push('</tr>'); + + if (fragments.length == 0) + return; + + var table = '<table style="font-size:smaller;color:' + options.grid.color + '">' + fragments.join("") + '</table>'; + if (options.legend.container != null) + $(options.legend.container).html(table); + else { + var pos = "", + p = options.legend.position, + m = options.legend.margin; + if (m[0] == null) + m = [m, m]; + if (p.charAt(0) == "n") + pos += 'top:' + (m[1] + plotOffset.top) + 'px;'; + else if (p.charAt(0) == "s") + pos += 'bottom:' + (m[1] + plotOffset.bottom) + 'px;'; + if (p.charAt(1) == "e") + pos += 'right:' + (m[0] + plotOffset.right) + 'px;'; + else if (p.charAt(1) == "w") + pos += 'left:' + (m[0] + plotOffset.left) + 'px;'; + var legend = $('<div class="legend">' + table.replace('style="', 'style="position:absolute;' + pos +';') + '</div>').appendTo(placeholder); + if (options.legend.backgroundOpacity != 0.0) { + // put in the transparent background + // separately to avoid blended labels and + // label boxes + var c = options.legend.backgroundColor; + if (c == null) { + c = options.grid.backgroundColor; + if (c && typeof c == "string") + c = $.color.parse(c); + else + c = $.color.extract(legend, 'background-color'); + c.a = 1; + c = c.toString(); + } + var div = legend.children(); + $('<div style="position:absolute;width:' + div.width() + 'px;height:' + div.height() + 'px;' + pos +'background-color:' + c + ';"> </div>').prependTo(legend).css('opacity', options.legend.backgroundOpacity); + } + } + } + + + // interactive features + + var highlights = [], + redrawTimeout = null; + + // returns the data item the mouse is over, or null if none is found + function findNearbyItem(mouseX, mouseY, seriesFilter) { + var maxDistance = options.grid.mouseActiveRadius, + smallestDistance = maxDistance * maxDistance + 1, + item = null, foundPoint = false, i, j; + + for (i = series.length - 1; i >= 0; --i) { + if (!seriesFilter(series[i])) + continue; + + var s = series[i], + axisx = s.xaxis, + axisy = s.yaxis, + points = s.datapoints.points, + ps = s.datapoints.pointsize, + mx = axisx.c2p(mouseX), // precompute some stuff to make the loop faster + my = axisy.c2p(mouseY), + maxx = maxDistance / axisx.scale, + maxy = maxDistance / axisy.scale; + + // with inverse transforms, we can't use the maxx/maxy + // optimization, sadly + if (axisx.options.inverseTransform) + maxx = Number.MAX_VALUE; + if (axisy.options.inverseTransform) + maxy = Number.MAX_VALUE; + + if (s.lines.show || s.points.show) { + for (j = 0; j < points.length; j += ps) { + var x = points[j], y = points[j + 1]; + if (x == null) + continue; + + // For points and lines, the cursor must be within a + // certain distance to the data point + if (x - mx > maxx || x - mx < -maxx || + y - my > maxy || y - my < -maxy) + continue; + + // We have to calculate distances in pixels, not in + // data units, because the scales of the axes may be different + var dx = Math.abs(axisx.p2c(x) - mouseX), + dy = Math.abs(axisy.p2c(y) - mouseY), + dist = dx * dx + dy * dy; // we save the sqrt + + // use <= to ensure last point takes precedence + // (last generally means on top of) + if (dist < smallestDistance) { + smallestDistance = dist; + item = [i, j / ps]; + } + } + } + + if (s.bars.show && !item) { // no other point can be nearby + var barLeft = s.bars.align == "left" ? 0 : -s.bars.barWidth/2, + barRight = barLeft + s.bars.barWidth; + + for (j = 0; j < points.length; j += ps) { + var x = points[j], y = points[j + 1], b = points[j + 2]; + if (x == null) + continue; + + // for a bar graph, the cursor must be inside the bar + if (series[i].bars.horizontal ? + (mx <= Math.max(b, x) && mx >= Math.min(b, x) && + my >= y + barLeft && my <= y + barRight) : + (mx >= x + barLeft && mx <= x + barRight && + my >= Math.min(b, y) && my <= Math.max(b, y))) + item = [i, j / ps]; + } + } + } + + if (item) { + i = item[0]; + j = item[1]; + ps = series[i].datapoints.pointsize; + + return { datapoint: series[i].datapoints.points.slice(j * ps, (j + 1) * ps), + dataIndex: j, + series: series[i], + seriesIndex: i }; + } + + return null; + } + + function onMouseMove(e) { + if (options.grid.hoverable) + triggerClickHoverEvent("plothover", e, + function (s) { return s["hoverable"] != false; }); + } + + function onMouseLeave(e) { + if (options.grid.hoverable) + triggerClickHoverEvent("plothover", e, + function (s) { return false; }); + } + + function onClick(e) { + triggerClickHoverEvent("plotclick", e, + function (s) { return s["clickable"] != false; }); + } + + // trigger click or hover event (they send the same parameters + // so we share their code) + function triggerClickHoverEvent(eventname, event, seriesFilter) { + var offset = eventHolder.offset(), + canvasX = event.pageX - offset.left - plotOffset.left, + canvasY = event.pageY - offset.top - plotOffset.top, + pos = canvasToAxisCoords({ left: canvasX, top: canvasY }); + + pos.pageX = event.pageX; + pos.pageY = event.pageY; + + var item = findNearbyItem(canvasX, canvasY, seriesFilter); + + if (item) { + // fill in mouse pos for any listeners out there + item.pageX = parseInt(item.series.xaxis.p2c(item.datapoint[0]) + offset.left + plotOffset.left); + item.pageY = parseInt(item.series.yaxis.p2c(item.datapoint[1]) + offset.top + plotOffset.top); + } + + if (options.grid.autoHighlight) { + // clear auto-highlights + for (var i = 0; i < highlights.length; ++i) { + var h = highlights[i]; + if (h.auto == eventname && + !(item && h.series == item.series && + h.point[0] == item.datapoint[0] && + h.point[1] == item.datapoint[1])) + unhighlight(h.series, h.point); + } + + if (item) + highlight(item.series, item.datapoint, eventname); + } + + placeholder.trigger(eventname, [ pos, item ]); + } + + function triggerRedrawOverlay() { + if (!redrawTimeout) + redrawTimeout = setTimeout(drawOverlay, 30); + } + + function drawOverlay() { + redrawTimeout = null; + + // draw highlights + octx.save(); + octx.clearRect(0, 0, canvasWidth, canvasHeight); + octx.translate(plotOffset.left, plotOffset.top); + + var i, hi; + for (i = 0; i < highlights.length; ++i) { + hi = highlights[i]; + + if (hi.series.bars.show) + drawBarHighlight(hi.series, hi.point); + else + drawPointHighlight(hi.series, hi.point); + } + octx.restore(); + + executeHooks(hooks.drawOverlay, [octx]); + } + + function highlight(s, point, auto) { + if (typeof s == "number") + s = series[s]; + + if (typeof point == "number") { + var ps = s.datapoints.pointsize; + point = s.datapoints.points.slice(ps * point, ps * (point + 1)); + } + + var i = indexOfHighlight(s, point); + if (i == -1) { + highlights.push({ series: s, point: point, auto: auto }); + + triggerRedrawOverlay(); + } + else if (!auto) + highlights[i].auto = false; + } + + function unhighlight(s, point) { + if (s == null && point == null) { + highlights = []; + triggerRedrawOverlay(); + } + + if (typeof s == "number") + s = series[s]; + + if (typeof point == "number") + point = s.data[point]; + + var i = indexOfHighlight(s, point); + if (i != -1) { + highlights.splice(i, 1); + + triggerRedrawOverlay(); + } + } + + function indexOfHighlight(s, p) { + for (var i = 0; i < highlights.length; ++i) { + var h = highlights[i]; + if (h.series == s && h.point[0] == p[0] + && h.point[1] == p[1]) + return i; + } + return -1; + } + + function drawPointHighlight(series, point) { + var x = point[0], y = point[1], + axisx = series.xaxis, axisy = series.yaxis; + + if (x < axisx.min || x > axisx.max || y < axisy.min || y > axisy.max) + return; + + var pointRadius = series.points.radius + series.points.lineWidth / 2; + octx.lineWidth = pointRadius; + octx.strokeStyle = $.color.parse(series.color).scale('a', 0.5).toString(); + var radius = 1.5 * pointRadius, + x = axisx.p2c(x), + y = axisy.p2c(y); + + octx.beginPath(); + if (series.points.symbol == "circle") + octx.arc(x, y, radius, 0, 2 * Math.PI, false); + else + series.points.symbol(octx, x, y, radius, false); + octx.closePath(); + octx.stroke(); + } + + function drawBarHighlight(series, point) { + octx.lineWidth = series.bars.lineWidth; + octx.strokeStyle = $.color.parse(series.color).scale('a', 0.5).toString(); + var fillStyle = $.color.parse(series.color).scale('a', 0.5).toString(); + var barLeft = series.bars.align == "left" ? 0 : -series.bars.barWidth/2; + drawBar(point[0], point[1], point[2] || 0, barLeft, barLeft + series.bars.barWidth, + 0, function () { return fillStyle; }, series.xaxis, series.yaxis, octx, series.bars.horizontal, series.bars.lineWidth); + } + + function getColorOrGradient(spec, bottom, top, defaultColor) { + if (typeof spec == "string") + return spec; + else { + // assume this is a gradient spec; IE currently only + // supports a simple vertical gradient properly, so that's + // what we support too + var gradient = ctx.createLinearGradient(0, top, 0, bottom); + + for (var i = 0, l = spec.colors.length; i < l; ++i) { + var c = spec.colors[i]; + if (typeof c != "string") { + var co = $.color.parse(defaultColor); + if (c.brightness != null) + co = co.scale('rgb', c.brightness) + if (c.opacity != null) + co.a *= c.opacity; + c = co.toString(); + } + gradient.addColorStop(i / (l - 1), c); + } + + return gradient; + } + } + } + + $.plot = function(placeholder, data, options) { + //var t0 = new Date(); + var plot = new Plot($(placeholder), data, options, $.plot.plugins); + //(window.console ? console.log : alert)("time used (msecs): " + ((new Date()).getTime() - t0.getTime())); + return plot; + }; + + $.plot.version = "0.7"; + + $.plot.plugins = []; + + // returns a string with the date d formatted according to fmt + $.plot.formatDate = function(d, fmt, monthNames) { + var leftPad = function(n) { + n = "" + n; + return n.length == 1 ? "0" + n : n; + }; + + var r = []; + var escape = false, padNext = false; + var hours = d.getUTCHours(); + var isAM = hours < 12; + if (monthNames == null) + monthNames = ["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"]; + + if (fmt.search(/%p|%P/) != -1) { + if (hours > 12) { + hours = hours - 12; + } else if (hours == 0) { + hours = 12; + } + } + for (var i = 0; i < fmt.length; ++i) { + var c = fmt.charAt(i); + + if (escape) { + switch (c) { + case 'h': c = "" + hours; break; + case 'H': c = leftPad(hours); break; + case 'M': c = leftPad(d.getUTCMinutes()); break; + case 'S': c = leftPad(d.getUTCSeconds()); break; + case 'd': c = "" + d.getUTCDate(); break; + case 'm': c = "" + (d.getUTCMonth() + 1); break; + case 'y': c = "" + d.getUTCFullYear(); break; + case 'b': c = "" + monthNames[d.getUTCMonth()]; break; + case 'p': c = (isAM) ? ("" + "am") : ("" + "pm"); break; + case 'P': c = (isAM) ? ("" + "AM") : ("" + "PM"); break; + case '0': c = ""; padNext = true; break; + } + if (c && padNext) { + c = leftPad(c); + padNext = false; + } + r.push(c); + if (!padNext) + escape = false; + } + else { + if (c == "%") + escape = true; + else + r.push(c); + } + } + return r.join(""); + }; + + // round to nearby lower multiple of base + function floorInBase(n, base) { + return base * Math.floor(n / base); + } + +})(jQuery); diff --git a/collects/meta/drdr/static/jquery.flot.selection.js b/collects/meta/drdr/static/jquery.flot.selection.js new file mode 100644 index 0000000000..7f7b32694b --- /dev/null +++ b/collects/meta/drdr/static/jquery.flot.selection.js @@ -0,0 +1,344 @@ +/* +Flot plugin for selecting regions. + +The plugin defines the following options: + + selection: { + mode: null or "x" or "y" or "xy", + color: color + } + +Selection support is enabled by setting the mode to one of "x", "y" or +"xy". In "x" mode, the user will only be able to specify the x range, +similarly for "y" mode. For "xy", the selection becomes a rectangle +where both ranges can be specified. "color" is color of the selection +(if you need to change the color later on, you can get to it with +plot.getOptions().selection.color). + +When selection support is enabled, a "plotselected" event will be +emitted on the DOM element you passed into the plot function. The +event handler gets a parameter with the ranges selected on the axes, +like this: + + placeholder.bind("plotselected", function(event, ranges) { + alert("You selected " + ranges.xaxis.from + " to " + ranges.xaxis.to) + // similar for yaxis - with multiple axes, the extra ones are in + // x2axis, x3axis, ... + }); + +The "plotselected" event is only fired when the user has finished +making the selection. A "plotselecting" event is fired during the +process with the same parameters as the "plotselected" event, in case +you want to know what's happening while it's happening, + +A "plotunselected" event with no arguments is emitted when the user +clicks the mouse to remove the selection. + +The plugin allso adds the following methods to the plot object: + +- setSelection(ranges, preventEvent) + + Set the selection rectangle. The passed in ranges is on the same + form as returned in the "plotselected" event. If the selection mode + is "x", you should put in either an xaxis range, if the mode is "y" + you need to put in an yaxis range and both xaxis and yaxis if the + selection mode is "xy", like this: + + setSelection({ xaxis: { from: 0, to: 10 }, yaxis: { from: 40, to: 60 } }); + + setSelection will trigger the "plotselected" event when called. If + you don't want that to happen, e.g. if you're inside a + "plotselected" handler, pass true as the second parameter. If you + are using multiple axes, you can specify the ranges on any of those, + e.g. as x2axis/x3axis/... instead of xaxis, the plugin picks the + first one it sees. + +- clearSelection(preventEvent) + + Clear the selection rectangle. Pass in true to avoid getting a + "plotunselected" event. + +- getSelection() + + Returns the current selection in the same format as the + "plotselected" event. If there's currently no selection, the + function returns null. + +*/ + +(function ($) { + function init(plot) { + var selection = { + first: { x: -1, y: -1}, second: { x: -1, y: -1}, + show: false, + active: false + }; + + // FIXME: The drag handling implemented here should be + // abstracted out, there's some similar code from a library in + // the navigation plugin, this should be massaged a bit to fit + // the Flot cases here better and reused. Doing this would + // make this plugin much slimmer. + var savedhandlers = {}; + + var mouseUpHandler = null; + + function onMouseMove(e) { + if (selection.active) { + updateSelection(e); + + plot.getPlaceholder().trigger("plotselecting", [ getSelection() ]); + } + } + + function onMouseDown(e) { + if (e.which != 1) // only accept left-click + return; + + // cancel out any text selections + document.body.focus(); + + // prevent text selection and drag in old-school browsers + if (document.onselectstart !== undefined && savedhandlers.onselectstart == null) { + savedhandlers.onselectstart = document.onselectstart; + document.onselectstart = function () { return false; }; + } + if (document.ondrag !== undefined && savedhandlers.ondrag == null) { + savedhandlers.ondrag = document.ondrag; + document.ondrag = function () { return false; }; + } + + setSelectionPos(selection.first, e); + + selection.active = true; + + // this is a bit silly, but we have to use a closure to be + // able to whack the same handler again + mouseUpHandler = function (e) { onMouseUp(e); }; + + $(document).one("mouseup", mouseUpHandler); + } + + function onMouseUp(e) { + mouseUpHandler = null; + + // revert drag stuff for old-school browsers + if (document.onselectstart !== undefined) + document.onselectstart = savedhandlers.onselectstart; + if (document.ondrag !== undefined) + document.ondrag = savedhandlers.ondrag; + + // no more dragging + selection.active = false; + updateSelection(e); + + if (selectionIsSane()) + triggerSelectedEvent(); + else { + // this counts as a clear + plot.getPlaceholder().trigger("plotunselected", [ ]); + plot.getPlaceholder().trigger("plotselecting", [ null ]); + } + + return false; + } + + function getSelection() { + if (!selectionIsSane()) + return null; + + var r = {}, c1 = selection.first, c2 = selection.second; + $.each(plot.getAxes(), function (name, axis) { + if (axis.used) { + var p1 = axis.c2p(c1[axis.direction]), p2 = axis.c2p(c2[axis.direction]); + r[name] = { from: Math.min(p1, p2), to: Math.max(p1, p2) }; + } + }); + return r; + } + + function triggerSelectedEvent() { + var r = getSelection(); + + plot.getPlaceholder().trigger("plotselected", [ r ]); + + // backwards-compat stuff, to be removed in future + if (r.xaxis && r.yaxis) + plot.getPlaceholder().trigger("selected", [ { x1: r.xaxis.from, y1: r.yaxis.from, x2: r.xaxis.to, y2: r.yaxis.to } ]); + } + + function clamp(min, value, max) { + return value < min ? min: (value > max ? max: value); + } + + function setSelectionPos(pos, e) { + var o = plot.getOptions(); + var offset = plot.getPlaceholder().offset(); + var plotOffset = plot.getPlotOffset(); + pos.x = clamp(0, e.pageX - offset.left - plotOffset.left, plot.width()); + pos.y = clamp(0, e.pageY - offset.top - plotOffset.top, plot.height()); + + if (o.selection.mode == "y") + pos.x = pos == selection.first ? 0 : plot.width(); + + if (o.selection.mode == "x") + pos.y = pos == selection.first ? 0 : plot.height(); + } + + function updateSelection(pos) { + if (pos.pageX == null) + return; + + setSelectionPos(selection.second, pos); + if (selectionIsSane()) { + selection.show = true; + plot.triggerRedrawOverlay(); + } + else + clearSelection(true); + } + + function clearSelection(preventEvent) { + if (selection.show) { + selection.show = false; + plot.triggerRedrawOverlay(); + if (!preventEvent) + plot.getPlaceholder().trigger("plotunselected", [ ]); + } + } + + // function taken from markings support in Flot + function extractRange(ranges, coord) { + var axis, from, to, key, axes = plot.getAxes(); + + for (var k in axes) { + axis = axes[k]; + if (axis.direction == coord) { + key = coord + axis.n + "axis"; + if (!ranges[key] && axis.n == 1) + key = coord + "axis"; // support x1axis as xaxis + if (ranges[key]) { + from = ranges[key].from; + to = ranges[key].to; + break; + } + } + } + + // backwards-compat stuff - to be removed in future + if (!ranges[key]) { + axis = coord == "x" ? plot.getXAxes()[0] : plot.getYAxes()[0]; + from = ranges[coord + "1"]; + to = ranges[coord + "2"]; + } + + // auto-reverse as an added bonus + if (from != null && to != null && from > to) { + var tmp = from; + from = to; + to = tmp; + } + + return { from: from, to: to, axis: axis }; + } + + function setSelection(ranges, preventEvent) { + var axis, range, o = plot.getOptions(); + + if (o.selection.mode == "y") { + selection.first.x = 0; + selection.second.x = plot.width(); + } + else { + range = extractRange(ranges, "x"); + + selection.first.x = range.axis.p2c(range.from); + selection.second.x = range.axis.p2c(range.to); + } + + if (o.selection.mode == "x") { + selection.first.y = 0; + selection.second.y = plot.height(); + } + else { + range = extractRange(ranges, "y"); + + selection.first.y = range.axis.p2c(range.from); + selection.second.y = range.axis.p2c(range.to); + } + + selection.show = true; + plot.triggerRedrawOverlay(); + if (!preventEvent && selectionIsSane()) + triggerSelectedEvent(); + } + + function selectionIsSane() { + var minSize = 5; + return Math.abs(selection.second.x - selection.first.x) >= minSize && + Math.abs(selection.second.y - selection.first.y) >= minSize; + } + + plot.clearSelection = clearSelection; + plot.setSelection = setSelection; + plot.getSelection = getSelection; + + plot.hooks.bindEvents.push(function(plot, eventHolder) { + var o = plot.getOptions(); + if (o.selection.mode != null) { + eventHolder.mousemove(onMouseMove); + eventHolder.mousedown(onMouseDown); + } + }); + + + plot.hooks.drawOverlay.push(function (plot, ctx) { + // draw selection + if (selection.show && selectionIsSane()) { + var plotOffset = plot.getPlotOffset(); + var o = plot.getOptions(); + + ctx.save(); + ctx.translate(plotOffset.left, plotOffset.top); + + var c = $.color.parse(o.selection.color); + + ctx.strokeStyle = c.scale('a', 0.8).toString(); + ctx.lineWidth = 1; + ctx.lineJoin = "round"; + ctx.fillStyle = c.scale('a', 0.4).toString(); + + var x = Math.min(selection.first.x, selection.second.x), + y = Math.min(selection.first.y, selection.second.y), + w = Math.abs(selection.second.x - selection.first.x), + h = Math.abs(selection.second.y - selection.first.y); + + ctx.fillRect(x, y, w, h); + ctx.strokeRect(x, y, w, h); + + ctx.restore(); + } + }); + + plot.hooks.shutdown.push(function (plot, eventHolder) { + eventHolder.unbind("mousemove", onMouseMove); + eventHolder.unbind("mousedown", onMouseDown); + + if (mouseUpHandler) + $(document).unbind("mouseup", mouseUpHandler); + }); + + } + + $.plot.plugins.push({ + init: init, + options: { + selection: { + mode: null, // one of null, "x", "y" or "xy" + color: "#e8cfac" + } + }, + name: 'selection', + version: '1.1' + }); +})(jQuery); From e3cff12b06111da23d1c13de9a5f0a66d5369abc Mon Sep 17 00:00:00 2001 From: Jay McCarthy <jay@racket-lang.org> Date: Tue, 6 Sep 2011 16:07:06 -0600 Subject: [PATCH 199/235] removing old graphing system --- collects/meta/drdr/graph.rkt | 26 - collects/meta/drdr/graphs/README | 22 - collects/meta/drdr/graphs/build-graph.rkt | 690 ---------------------- collects/meta/drdr/graphs/constants.rkt | 7 - collects/meta/drdr/graphs/mk-img.rkt | 62 -- collects/meta/drdr/render.rkt | 34 +- collects/meta/drdr/static/chart.js | 12 +- collects/meta/drdr/time.rkt | 35 +- 8 files changed, 30 insertions(+), 858 deletions(-) delete mode 100644 collects/meta/drdr/graph.rkt delete mode 100644 collects/meta/drdr/graphs/README delete mode 100644 collects/meta/drdr/graphs/build-graph.rkt delete mode 100644 collects/meta/drdr/graphs/constants.rkt delete mode 100644 collects/meta/drdr/graphs/mk-img.rkt diff --git a/collects/meta/drdr/graph.rkt b/collects/meta/drdr/graph.rkt deleted file mode 100644 index 333ee37fa2..0000000000 --- a/collects/meta/drdr/graph.rkt +++ /dev/null @@ -1,26 +0,0 @@ -#lang racket -(require racket/system - "config.rkt" - "path-utils.rkt" - "dirstruct.rkt") - -(define rebaser - (rebase-path (plt-data-directory) "/data")) - -(define (main filename) - (define prefix - (path-timing-png-prefix filename)) - (system*/exit-code - (path->string - (build-path (plt-directory) "plt" "bin" "gracket-text")) - "-t" - (path->string (build-path (drdr-directory) "graphs" "build-graph.rkt")) - "--" - "-l" (string-append "http://drdr.racket-lang.org/~a/" (path->string* filename)) ; XXX - "--image-loc" "/graph-images/" - (path->string (path-timing-log filename)) - (path->string prefix) - (path->string (rebaser prefix)) - (path->string (path-timing-html filename)))) - -(provide main) diff --git a/collects/meta/drdr/graphs/README b/collects/meta/drdr/graphs/README deleted file mode 100644 index 4ff5b4648f..0000000000 --- a/collects/meta/drdr/graphs/README +++ /dev/null @@ -1,22 +0,0 @@ -- build the global .png files with a recent svn build: - - gracket-text mk-img.rkt - - This will dump some png files in the current directory. Put them in - some global place on the server - -- to build a script for a particular page, do this: - - gracket-text build-graph.rkt -l http://drdr.racket-lang.org/~a/collects/path/to/file.scm \ - --image-loc /static/data/graph-images/ \ - file_scm.timing \ - file_scm_png_file_prefix \ - output.html - - The -l flag is optional, without it clicking on the images won't go - anywhere; with it, clicking will go to the corresponding revision. - The --image-loc flag gives a url path to the directory containing - the images from the mk-img.rkt setp. The other three args are the - timing data file, a prefix for the png files that generated for the - graphs, and the output html (which is a <div> ... </div>). - diff --git a/collects/meta/drdr/graphs/build-graph.rkt b/collects/meta/drdr/graphs/build-graph.rkt deleted file mode 100644 index 8b44ec7d63..0000000000 --- a/collects/meta/drdr/graphs/build-graph.rkt +++ /dev/null @@ -1,690 +0,0 @@ -#lang racket/gui -(require xml) - -(require "constants.rkt") - -;; example data: -;; http://drdr.racket-lang.org/data/collects/tests/mzscheme/benchmarks/common/earley_ss.timing - -;;; ======================================== - -;; a raw-line is -;; (list number number (listof (list number number number))) - -;; a graph is -;; (make-graph revision-number revision-number (listof line)) -(define-struct graph (start end lines) #:transparent) - -;; a line is -;; (make-line number number (listof point) string symbol) -;; style = (or/c 'overall 'cpu 'real 'gc) -(define-struct line (min max points color style) #:transparent) - -;; value : number between [0,1] indicating the percentage -;; of the time of the slowest run -;; revision : revision number -(define-struct point (value revision) #:transparent) - - -;; revision : nat -;; x-pixel : nat -(define-struct coordinate (revision x-pixel) #:transparent) - -(define graph-gap 4) -(define max-revisions-per-graph (make-parameter 400)) - -(define max-graphs-per-image (floor (/ graphs-width (+ graph-gap 4)))) -(define max-samples-per-image (floor (/ graphs-width 3))) - -(define link-format-string #f) - -(define image-loc "./") - -(define full? #f) - -(define-values (input-file image-filename-prefix image-url-prefix html-file) - (command-line -#| - #:argv - #("-l" - "http://drdr.racket-lang.org/~a/collects/tests/mzscheme/benchmarks/mz/expand-class.scm" - "expand-class_scm.timing" "out" "out.html" ) -|# - #:once-each - [("-f" "--full") - "indicates that a complete html file should be produced; otherwise, a single div is all you get" - (set! full? #t)] - [("-l" "--link") - link-format - "specifies where revisions link to; expected to be a url with a ~a in the middle" - (set! link-format-string link-format)] - [("--image-loc") - url-path - "specify the path to the image files for html generation (not just to the dir; to the file itself)" - (unless (regexp-match #rx"/$" url-path) - (error 'build-graph.rkt "expected the image-loc to end with a /, got ~a" url-path)) - (set! image-loc url-path)] - #:args (input-file image-filename-prefix image-url-prefix html-file) - (values input-file image-filename-prefix image-url-prefix html-file))) - -(define dot-image-file (string-append image-loc "dot.png")) -(define before-image-file (string-append image-loc "before.png")) -(define after-image-file (string-append image-loc "after.png")) - - - - -; -; -; -; -; ;; -; ; -; ;;;;; ;;;;; ;;;; ;;;; ;; ;;;;; ;;;;; -; ;;;;; ;; ;; ;;; ;; ;; ;; ;;;;; ;;;;; -; ;; ;; ;;;; ;; ;;;; ;; ;; ;;;;;; ;; -; ;; ;; ;;;;;; ;; ;;;; ;; ;; ;;;;;; ;; -; ;;;;;;;;; ;;; ;; ;;; ;; ;; ;; ;;; ;;;;; -; ;;;;; ;;;;;; ;; ;;;; ;; ;; ;;; ;;;;; -; ;; ;; ;; -; ;; ;;;;; -; -; - -;; orig-data : hash[revision-number -o> sexp] -;; the original lines from the files, indexed by revision number -(define orig-data (make-hash)) - -(define (revision->duration revision) - (let ([info (hash-ref orig-data revision)]) - (floor (inexact->exact (list-ref info 1))))) - -(define (revision->timings-array revision) - (let ([info (hash-ref orig-data revision)]) - (apply - string-append - (append (list "[") - (add-between (map (λ (line) - (format "'cpu time: ~a real time: ~a gc time: ~a'" - (list-ref line 0) - (list-ref line 1) - (list-ref line 2))) - (list-ref info 2)) - ",") - (list "]"))))) - -;; this build ex2.rkt out of ex.rkt -;; adjust : raw-line -> raw-line -(define adjust - (let ([seen-time #f]) - (lambda (l) - (match l - [`(,rev ,time ,times) - (cond - [(empty? times) - l] - [(not seen-time) - (set! seen-time 1) - l] - [(< seen-time 30) - (set! seen-time (+ seen-time 1)) - l] - [else - (list (list-ref l 0) - (list-ref l 1) - (list (car (list-ref l 2)) - (map (λ (x) (* x 10)) (car (list-ref l 2)))))])])))) - -;; fetch-data : string -> (listof raw-line)[uniq revision-numbers] -(define (fetch-data file) - (call-with-input-file file - (λ (port) - (let loop () - (let ([l (read port)]) - (cond - [(eof-object? l) '()] - [(hash-ref orig-data (car l) #f) - ;; skip duplicate revisions - (loop)] - [else - (hash-set! orig-data (car l) l) - (cons l (loop))])))))) - -;; build-graphss : (listof raw-line) -> (listof (listof graph)) -(define (build-graphss data) - (let ([large-graphs - (filter - (λ (x) (<= 2 (length (line-points (car (graph-lines x)))))) - (build-large-graphs data))]) - (let loop ([graphs (reverse large-graphs)]) - (let-values ([(first rest) (split-out-graph graphs)]) - (cond - [(null? rest) - (list first)] - [else - (cons first (loop rest))]))))) - -;; split-out-graphs : (listof graph) -> (values (listof graph) (listof graph)) -;; first result is a set of graphs to go into a single image -;; limits the number of graphs and the number of total samples -;; expects the graphs to be in order from the right to the left -;; returns the first result in the opposite order and the second result in the same order. -(define (split-out-graph graphs) - (let loop ([graphs graphs] - [sample-count 0] - [graph-count 0] - [current '()]) - (cond - [(null? graphs) - (values current graphs)] - [(< max-graphs-per-image graph-count) - (values current graphs)] - [else - (let* ([graph (car graphs)] - [this-graph-samples (graph-sample-count graph)]) - (cond - [(<= (+ sample-count this-graph-samples) max-samples-per-image) - ;; if this graph fits, take it. - (loop (cdr graphs) - (+ sample-count this-graph-samples) - (+ graph-count 1) - (cons graph current))] - [(<= sample-count (/ max-samples-per-image 2)) - ;; if the graph doesn't fit, and we have less than 1/2 of the samples that fill - ;; the page, break this graph into two graphs, taking the first part of the split - (let-values ([(before after) (split-graph - graph - (- max-samples-per-image sample-count))]) - (values (cons before current) - (cons after (cdr graphs))))] - [else - ;; otherwise, just stop with what we have now - (values current - graphs)]))]))) - -;; split-graph : graph number -> (values graph graph) -;; break graph into two pieces where the first piece has 'max-samples' samples -;; split-point <= number of samples in graph -(define (split-graph graph split-point) - (let* ([this-graph-samples (graph-sample-count graph)] - [orig-lines (graph-lines graph)] - [lines-before (pull-out orig-lines (λ (x) (take x split-point)))] - [lines-after (pull-out orig-lines (λ (x) (drop x split-point)))] - [lines-before-last-revision - (apply max (map point-revision (line-points (car lines-before))))] - [lines-after-first-revision - (apply min (map point-revision (line-points (car lines-after))))]) - (values (make-graph (graph-start graph) - lines-before-last-revision - lines-before) - (make-graph lines-after-first-revision - (graph-end graph) - lines-after)))) - -;; pull-out : (listof line) (-> (listof point) (listof point)) -> (listof line) -;; makes lines like 'lines', but using puller to select the relevant points -(define/contract (pull-out lines puller) - (-> (listof line?) (-> (listof point?) (listof point?)) (listof line?)) - (map (λ (line) - (let* ([new-points (puller (line-points line))] - [max-v (apply max (map point-value new-points))] - [min-v (apply min (map point-value new-points))]) - (make-line min-v - max-v - new-points - (line-color line) - (line-style line)))) - lines)) - -(define (graph-sample-count graph) - (length (line-points (car (graph-lines graph))))) - -;; build-large-graphs : (listof raw-line) -> (listof graph) -(define (build-large-graphs data) - (let loop ([data data] - [working-graph '()]) - (cond - [(null? data) - (if (null? working-graph) - '() - (list (finalize-graph (reverse working-graph))))] - [else - (let ([this (car data)]) - (cond - [(matching-line? this working-graph) - (loop (cdr data) - (cons this working-graph))] - [else - (cons (finalize-graph (reverse working-graph)) - (loop data '()))]))]))) - -;; matching-line? : raw-line (listof raw-line) -> boolean -;; #t if the line fits into this graph -(define (matching-line? line working-graph) - (or (null? working-graph) - (match line - [`(,rev ,time ,line-seqs) - (match (car working-graph) - [`(,rev ,time ,working-line-seq) - (= (length line-seqs) - (length working-line-seq))])]))) - -;; split-up : (listof X) -> (listof (listof X)) -;; splits up the working graph into at chunks of size at most -;; max-revisions-per-graph. -(define (split-up working-graph) - (reverse - (let loop ([working-graph (reverse working-graph)] - [i 0] - [pending '()]) - (cond - [(null? working-graph) - (if (null? pending) - '() - (list pending))] - [else - (if (< i (max-revisions-per-graph)) - (loop (cdr working-graph) - (+ i 1) - (cons (car working-graph) pending)) - (cons pending - (loop working-graph 0 '())))])))) - -;; poor man testing .... -(parameterize ([max-revisions-per-graph 3]) - (unless (and (equal? (split-up '()) '()) - (equal? (split-up '(1)) '((1))) - (equal? (split-up '(1 2)) '((1 2))) - (equal? (split-up '(1 2 3)) '((1 2 3))) - (equal? (split-up '(1 2 3 4)) '((1) (2 3 4))) - (equal? (split-up '(1 2 3 4 5)) '((1 2) (3 4 5))) - (equal? (split-up '(1 2 3 4 5 6)) '((1 2 3) (4 5 6))) - (equal? (split-up '(1 2 3 4 5 6 7)) '((1) (2 3 4) (5 6 7)))) - (error 'tests-failed))) - -;; finalize-graph : (non-empty-listof raw-line) -> graph -(define (finalize-graph working-graph) - (restart-colors) - (let ([revisions (map first working-graph)]) - (make-graph - (car (car working-graph)) - (car (last working-graph)) - (cons - (build-line 'overall - (map second working-graph) - revisions - "black") - (apply - append - (let ([cpu-real-gcss (map third working-graph)]) - (for/list ([ele (car cpu-real-gcss)] - [i (in-naturals)]) - (let ([color (next-color)]) - (list (build-line 'cpu - (map (λ (x) (first (list-ref x i))) - cpu-real-gcss) - revisions - color) - (build-line 'real - (map (λ (x) (second (list-ref x i))) - cpu-real-gcss) - revisions - color) - (build-line 'gc - (map (λ (x) (third (list-ref x i))) - cpu-real-gcss) - revisions - color)))))))))) - -(define (build-line which points revisions color) - (let ([min-v (apply max points)] - [max-v (apply max points)]) - (make-line min-v - max-v - (map make-point points revisions) - color which))) - -(define-values (next-color restart-colors) - (let ([colors '("darkred" - "mediumvioletred" - "brown" - "midnightblue")] - [i 0]) - (values (λ () - (begin0 - (list-ref colors i) - (set! i (modulo (+ i 1) (length colors))))) - (λ () - (set! i 0))))) - - -; -; -; -; -; ;; ;; -; ;; ; -; ;;;;; ;;;; ;;;;; ;; ;; ;; ;; ;;;;; ;;;;; -; ;;;;; ;;; ;; ;; ; ;; ;; ;; ;;;;; ;;;;; -; ;;; ;; ;; ;;;; ;;;;;;;; ;; ;; ;;;;;; ;; -; ;;; ;; ;; ;;;;;; ;;;;;;;; ;; ;; ;;;;;; ;; -; ;;;;; ;; ;;; ;;; ;; ;;; ;; ;; ;;; ;;;;; -; ;;;;; ;; ;;;;;; ;; ;; ;; ;; ;;; ;;;;; -; ;; ;; -; ;;;;; -; -; - - -;; record-points : (parameter (or/c #f (-> number[x-coordinate] number[revision] -> void))) -(define record-points (make-parameter #f)) - -(define (graphs->coordinates graphs) - (let ([dc (make-object bitmap-dc% (make-object bitmap% 1 1))] - [points (make-hash)]) - (define (rp x-coord revision) - (let ([pixel (inexact->exact (floor x-coord))] - [prev (hash-ref points revision #f)]) - (cond - [prev - (unless (equal? prev pixel) - (error - 'graphs->coordinates - "revision ~s maps to two different pixel values! ~s and ~s" - revision - prev - pixel))] - [else - (hash-set! points revision pixel)]))) - (parameterize ([record-points rp]) - (draw-graphs dc graphs)) - (sort (hash-map points (λ (revision pixel) (make-coordinate revision pixel))) - < - #:key coordinate-revision))) - -(define (draw-graphs dc graphs) - (let ([tot-points (apply + (map graph-point-count graphs))] - [tot-space (- graphs-width (* graph-gap (- (length graphs) 1)))]) - (let loop ([sx 0] - [graphs graphs]) - (unless (null? graphs) - (let* ([graph (car graphs)] - [points (graph-point-count graph)] - [this-w (* (/ points tot-points) tot-space)] - [next-sx (+ sx this-w graph-gap)]) - (draw-graph dc graph sx this-w) - (unless (null? (cdr graphs)) - (send dc set-pen "black" 1 'transparent) - (send dc set-brush "gray" 'solid) - (send dc set-alpha 1) - (send dc draw-rectangle - (- next-sx graph-gap) - 0 - graph-gap - graph-height)) - (loop next-sx - (cdr graphs))))))) - -(define (graph-point-count graph) - (length (line-points (car (graph-lines graph))))) - -(define (draw-graph dc graph sx w) - (draw-legend dc sx w) - (for ([line (in-list (graph-lines graph))]) - (let* ([num-points (length (line-points line))] - [i->x (λ (i) (+ sx (* (/ i (- num-points 1)) w)))] - [point->y (λ (point) - (let ([lm (line-max line)]) - (if (zero? lm) ;; everything must be zero in this case - graph-height - (* (- 1 (/ (point-value point) lm)) - graph-height))))]) - (send dc set-pen (line->pen line)) - (send dc set-alpha (line->alpha line)) - - (for ([start (in-list (line-points line))] - [end (in-list (cdr (line-points line)))] - [i (in-naturals)]) - (let* ([x-start (i->x i)] - [x-end (i->x (+ i 1))] - [y-start (point->y start)] - [y-end (point->y end)]) - (let ([rp (record-points)]) - (when rp - (when (= i 0) (rp x-start (point-revision start))) - (rp x-end (point-revision end)))) - (send dc draw-line - x-start y-start - x-end y-end)))))) - -(define (draw-legend dc sx w) - (send dc set-pen "gray" 3 'solid) - (send dc set-alpha 1) - (let ([hline (λ (p [dy 0]) - (send dc draw-line - sx - (+ dy (* p graph-height)) - (+ sx w) - (+ dy (* p graph-height))))]) - (hline 0 1) - (hline 1/4) - (hline 1/2) - (hline 3/4) - (hline 1 -2))) - -(define (line->alpha line) - (case (line-style line) - [(overall) 1] - [(cpu) 1/2] - [(gc) 1/4] - [(real) 1])) - -(define (line->pen line) - (send the-pen-list find-or-create-pen - (line-color line) - 1 - 'solid)) - -(define (draw fgs dc) - (send dc set-smoothing 'aligned) - (draw-graphs dc fgs)) - - -; -; -; -; ;; ; ;; -; ;; ;; ;; -; ;; ;; ;; -; ;;;;;; ;;;; ;;;;;;;;; ;; -; ;; ;; ;; ;; ;;; ;;; ;; -; ;; ;; ;; ;; ;;; ;;; ;; -; ;; ;; ;; ;; ;;; ;;; ;; -; ;; ;; ;; ;; ;;; ;;; ;; -; ;; ;;; ;;;;;; ;;; ;;; ;; -; -; -; - -(define (write-html graphss) - (let ([xml (xexpr->xml (graphs->complete-xexpr graphss))]) - (call-with-output-file html-file - (λ (port) (display-xml/content xml port)) - #:exists 'truncate))) - -(define (graphs->complete-xexpr graphss) - (let ([xexpr (graphs->xexpr graphss)]) - (if full? - `(html (head) - (body ,xexpr)) - xexpr))) - - -(define (graphs->xexpr graphss) - (let ([last-one (- (length graphss) 1)]) - `(div - (script ((type "text/javascript")) - ,(format "var current_pane=~a;\n" last-one) - "function move_bar(rev,x,w,duration,timing_strings) {\n" - " var suffix = ' msec'\n" - " if (duration > 1000) {\n" - " duration = duration/1000;" - " suffix = ' sec'" - " }\n" - " document.getElementById(\"rev_and_duration\").innerHTML='revision '+rev+' duration '+duration+suffix;\n" - ,(make-cdata - 'here - 'there - " document.getElementById(\"timings\").innerHTML=timing_strings.join('<br />');\n") - " var barimg = document.getElementById(\"barimg\");\n" - " barimg.width=w;\n" - " barimg.height=200;\n" - " document.getElementById(\"bar\").style.left=x;\n" - ,@(if link-format-string - (list (format - " document.getElementById(\"bara\").href='~a'+'?pane='+(current_pane+1)\n" - (format link-format-string "'+rev+'"))) - '()) - " return true;\n" - "}\n" - "function do_before(){\n" - " current_pane = current_pane-1;\n" - ,(format " if (current_pane == -1) { current_pane=~a; }\n" last-one) - " update_pane();\n" - "}\n" - "function do_after(){\n" - " current_pane = current_pane+1;\n" - ,(format " if (current_pane == ~a) { current_pane=0; }\n" (+ 1 last-one)) - " update_pane();\n" - "}\n" - "function update_pane(){\n" - " var img = document.getElementById(\"img\");\n" - " img.useMap='#revmap'+current_pane;\n" - ,(format " img.src='~a'+current_pane+'.png';\n" image-url-prefix) - " var p = current_pane+1;\n" - ,(format " document.getElementById(\"paneid\").innerHTML=('Pane '+p+' of ~a');\n" - (+ last-one 1)) - "}\n" - "// this function from http://www.netlobo.com/url_query_string_javascript.html\n" - "function gup (name) {\n" - " name = name.replace(/[\\[]/,\"\\\\\\[\").replace(/[\\]]/,\"\\\\\\]\");\n" - ,(make-cdata 'here 'there " var regexS = \"[\\\\?&]\"+name+\"=([^&#]*)\";\n") - " var regex = new RegExp( regexS );\n" - " var results = regex.exec( window.location.href );\n" - " if( results == null )\n" - " return \"\";\n" - " else\n" - " return results[1];\n" - "}\n" - "function startup() {\n" - " current_pane = parseInt(gup('pane'));\n" - " if (isNaN(current_pane))\n" - ,(format " current_pane = ~a;\n" last-one) - " else\n" - ,(format " current_pane = Math.min(Math.max(current_pane,1),~a)-1\n" (+ last-one 1)) - " update_pane();" - "}\n" - ) - (table - ((cellpadding "0") - (cellspacing "0")) - (tr - (td (a ((href "#") (onclick "javascript:do_before(); return false;")) - (img ((border "0") - (src ,before-image-file))))) - (td - (div ((style "position: relative;")) - (img ((src ,dot-image-file) - (border "0") - (id "img") - (height ,(format "~a" graph-height)) - (width ,(format "~a" graphs-width)))) - (div ((id "bar") - (style "position: absolute; top: 0px; left: 20px")) - (a ((id "bara")) - (img ((style "border:none") - (id "barimg") - (width "0") - (height ,(format "~a" graph-height)) - (src ,dot-image-file))))))) - (td (a ((href "#") (onclick "javascript:do_after(); return false;")) - (img ((border "0") - (src ,after-image-file))))))) - (div (span ((id "paneid")) "") - (span ((id "rev_and_duration")) "")) - (tt (span ((id "timings")) "")) - - ,@(for/list ((graphs (in-list (reverse graphss))) - (i (in-naturals))) - `(map ((name ,(format "revmap~a" i))) - ,@(graphs->areas graphs i))) - - (script ((type "text/javascript")) - "startup()")))) - -(define (graphs->areas graphs i) - (let ([coordinates (graphs->coordinates graphs)]) - (for/list ([c-1 (cons #f coordinates)] - [c coordinates] - [c+1 (append (cdr coordinates) (list #f))]) - (let ([left (if c-1 - (floor (average (coordinate-x-pixel c-1) - (coordinate-x-pixel c))) - (coordinate-x-pixel c))] - [right (if c+1 - (floor (average (coordinate-x-pixel c) - (coordinate-x-pixel c+1))) - (coordinate-x-pixel c))]) - `(area ((shape "rect") - (coords ,(format "~a,~a,~a,~a" left 0 right graph-height)) - (onmouseover ,(format "move_bar('~a','~apx',~a,'~a',~a)" - (coordinate-revision c) - left - (- right left) - (revision->duration (coordinate-revision c)) - (revision->timings-array - (coordinate-revision c)))))))))) - -(define (timing-strings c) (format "~s" c)) - -(define (average . l) (/ (apply + l) (length l))) - - -;; note: there is javascript code doing this same computation. -(define (i->image-file i) (format "~a~a.png" image-filename-prefix i)) - - -; -; -; -; -; ;; -; ; -; ;;;;; ;; ;;;;; ;; ;;;;; -; ;;;;;;;;; ;; ;; ;; ;;;;; -; ;; ;; ;; ;;;; ;; ;; ;;; -; ;; ;; ;; ;;;;;; ;; ;; ;;; -; ;; ;; ;; ;;; ;;; ;; ;; ;;; -; ;; ;; ;; ;;;;;; ;; ;; ;;; -; -; -; -; - -(define (save fgs i) - (let* ([bm (make-object bitmap% graphs-width graph-height)] - [bdc (make-object bitmap-dc% bm)]) - (send bdc clear) - (draw fgs bdc) - (send bdc set-bitmap #f) - (send bm save-file (i->image-file i) 'png) - (void))) - -(let () - (define the-data (fetch-data input-file)) - (define the-graphss (build-graphss the-data)) - - (write-html the-graphss) - (for ((the-graphs (in-list the-graphss)) - (i (in-naturals))) - (save the-graphs i))) diff --git a/collects/meta/drdr/graphs/constants.rkt b/collects/meta/drdr/graphs/constants.rkt deleted file mode 100644 index ecb4d4aa5e..0000000000 --- a/collects/meta/drdr/graphs/constants.rkt +++ /dev/null @@ -1,7 +0,0 @@ -#lang racket/base -(provide (all-defined-out)) -(define total-width 800) -(define before-and-after-image-width 18) -(define graph-height 200) -(define graphs-width (- 800 (* 2 before-and-after-image-width))) - diff --git a/collects/meta/drdr/graphs/mk-img.rkt b/collects/meta/drdr/graphs/mk-img.rkt deleted file mode 100644 index d5b212a807..0000000000 --- a/collects/meta/drdr/graphs/mk-img.rkt +++ /dev/null @@ -1,62 +0,0 @@ -#lang racket/gui - -(require 2htdp/image - "constants.rkt") - -;; make dot.png -(let* ([bm (make-object bitmap% 1 1)] - [mask (make-object bitmap% 1 1)] - [bdc (make-object bitmap-dc% bm)]) - (send bm set-loaded-mask mask) - (send bdc set-brush (make-object color% 50 100 20) 'solid) - (send bdc set-pen "black" 1 'transparent) - (send bdc draw-rectangle 0 0 1 1) - (send bdc set-bitmap mask) - (send bdc set-brush (make-object color% 100 100 100) 'solid) - (send bdc draw-rectangle 0 0 1 1) - (send bdc set-bitmap #f) - (send bm save-file "dot.png" 'png) - (void)) - -(define (save-bitmap mask-image color filename) - (let* ([w (image-width mask-image)] - [h (image-height mask-image)] - [bm (make-object bitmap% w h)] - [mask (make-object bitmap% w h)] - [bdc (make-object bitmap-dc% bm)]) - - (unless (= w before-and-after-image-width) - (error 'mk-img.rkt "expected ~a image's width to be ~a, got ~a" - filename - before-and-after-image-width - w)) - - (send bm set-loaded-mask mask) - (send bdc set-brush color 'solid) - (send bdc set-pen "black" 1 'transparent) - (send bdc draw-rectangle 0 0 w h) - (send bdc set-bitmap mask) - (send bdc clear) - (send mask-image draw bdc 0 0 0 0 w h 0 0 'show-caret) - (send bdc set-bitmap #f) - (send bm save-file filename 'png) - (void))) - - -(define (space-out img x-place) - (overlay/align - x-place - 'center - img - (rectangle (+ (image-width img) 4) - graph-height - 'solid - 'white))) - -(save-bitmap (space-out (rotate 90 (triangle 16 'solid 'black)) 'left) - "forestgreen" - "before.png") - -(save-bitmap (space-out (rotate -90 (triangle 16 'solid 'black)) 'right) - "forestgreen" - "after.png") diff --git a/collects/meta/drdr/render.rkt b/collects/meta/drdr/render.rkt index 15dbd4a813..d306832264 100644 --- a/collects/meta/drdr/render.rkt +++ b/collects/meta/drdr/render.rkt @@ -340,9 +340,9 @@ (define output (map render-event output-log)) (response/xexpr `(html (head (title ,title) - (script ([language "javascript"] [type "text/javascript"] [src "jquery-1.6.2.min.js"])) - (script ([language "javascript"] [type "text/javascript"] [src "jquery.flot.js"])) - (script ([language "javascript"] [type "text/javascript"] [src "jquery.flot.selection.js"])) + (script ([language "javascript"] [type "text/javascript"] [src "/jquery-1.6.2.min.js"]) "") + (script ([language "javascript"] [type "text/javascript"] [src "/jquery.flot.js"]) "") + (script ([language "javascript"] [type "text/javascript"] [src "/jquery.flot.selection.js"]) "") (link ([rel "stylesheet"] [type "text/css"] [href "/render.css"]))) (body (div ([class "log, content"]) @@ -373,31 +373,17 @@ '() `((div ([class "output"]) " " ,@output))) - (div ([id "_chart"] [style "width:800px;height:300px;"])) - (script ([language "javascript"] [type "text/javascript"] [src "chart.js"])) + + (p) + + (div ([id "_chart"] [style "width:800px;height:300px;"]) "") + (script ([language "javascript"] [type "text/javascript"] [src "/chart.js"]) "") (script ([language "javascript"] [type "text/javascript"]) - ,(format "get_data('/json/timing/~a');" the-base-path)) + ,(format "get_data('/json/timing~a');" the-base-path)) (button ([onclick "reset_chart()"]) "Reset") (button ([id "setlegend"] [onclick "set_legend(!cur_options.legend.show)"]) "Hide Legend") - - ,(with-handlers ([exn:fail? - ; XXX Remove this eventually - (lambda (x) - ; XXX use dirstruct functions - (define png-path - (format "/data~a" (path-add-suffix (path-add-suffix the-base-path #".timing") #".png"))) - `(div ([class "timing"]) - (a ([href ,png-path]) - (img ([src ,png-path])))))]) - (make-cdata - #f #f - (local [(define content - (file->string - (path-timing-html (substring (path->string* the-base-path) 1))))] - #;(regexp-replace* #rx"&(?![a-z]+;)" content "\\&\\1") - (regexp-replace* #rx">" content ">")) - )) + ,(footer)))))])])) (define (number->string/zero v) diff --git a/collects/meta/drdr/static/chart.js b/collects/meta/drdr/static/chart.js index ff3ad5f48b..f194e0bce1 100644 --- a/collects/meta/drdr/static/chart.js +++ b/collects/meta/drdr/static/chart.js @@ -13,7 +13,7 @@ function moving_avg(arr, i, _acc, _m) { var data = null; var sub_times = []; var overall_times = []; -var overall_avg = []; +//var overall_avg = []; var chart_data = []; var options = { selection: { mode: "xy" }, legend: { backgroundOpacity: 0, position: "sw", show: true }, @@ -63,7 +63,7 @@ placeholder.bind("plothover", function (event, pos, item) { function load_data(d) { chart_data = []; overall_times = []; - overall_avg = []; + //overall_avg = []; sub_times = []; pdata = [] reset_chart(); @@ -77,9 +77,9 @@ function load_data(d) { // build the timing data arrays for (var i = 0; i < pdata.length; i++) { overall_times.push([pdata[i][0], pdata[i][1]]); - overall_avg.push([pdata[i][0], - moving_avg(pdata, i, - function(j) { return pdata[j][1]; })]); + // overall_avg.push([pdata[i][0], + // moving_avg(pdata, i, + // function(j) { return pdata[j][1]; })]); max_overall = Math.max(max_overall, pdata[i][1]); if (pdata[i][2].length != 0) { for (var j = 0; j < pdata[i][2].length; j++) { @@ -98,7 +98,7 @@ function load_data(d) { // put the data into the chart format chart_data.push({data: overall_times, label: "Overall Time"}); - chart_data.push({data: overall_avg, label: "Overall Moving Avg"}); + //chart_data.push({data: overall_avg, label: "Overall Moving Avg"}); for(var i = 0; i < sub_times.length; i++) { chart_data.push({data: sub_times[i], label: "Timer "+ (i+1), points: { show: true }, yaxis: ya}); } diff --git a/collects/meta/drdr/time.rkt b/collects/meta/drdr/time.rkt index 2a404f2f71..41f993b4e6 100644 --- a/collects/meta/drdr/time.rkt +++ b/collects/meta/drdr/time.rkt @@ -1,7 +1,6 @@ #lang racket (require (planet jaymccarthy/job-queue) racket/system - (prefix-in graph-one: "graph.rkt") "config.rkt" "notify.rkt" "dirstruct.rkt" @@ -12,14 +11,11 @@ (define start-revision #f) (define history? #f) -(define just-graphs? #f) (command-line #:program "time" #:once-each ["-H" "Run on all revisions" (set! history? #t)] - ["-G" "Just graphs" - (set! just-graphs? #t)] ["-r" rev "Start with a particular revision" (set! start-revision (string->number rev))]) @@ -34,23 +30,20 @@ (submit-job! test-workers (lambda () - (unless just-graphs? - (notify! "Dropping timing for ~a" filename) - (apply - system*/exit-code - (path->string - (build-path (plt-directory) "plt" "bin" "racket")) - "-t" - (path->string (build-path (drdr-directory) "time-file.rkt")) - "--" - (append - (if history? - (list "-H") - (list "-r" (number->string start-revision))) - (list - (path->string filename))))) - (notify! "Generating graph for ~a" filename) - (graph-one:main filename) + (notify! "Dropping timing for ~a" filename) + (apply + system*/exit-code + (path->string + (build-path (plt-directory) "plt" "bin" "racket")) + "-t" + (path->string (build-path (drdr-directory) "time-file.rkt")) + "--" + (append + (if history? + (list "-H") + (list "-r" (number->string start-revision))) + (list + (path->string filename)))) (notify! "Done with ~a" filename) (semaphore-post count-sema)))) From ffc5387ac35ce25cc0af9510840c400d19063149 Mon Sep 17 00:00:00 2001 From: Jon Rafkind <rafkind@racket-lang.org> Date: Tue, 6 Sep 2011 13:22:52 -0600 Subject: [PATCH 200/235] [honu] configure honu runtime to use the honu syntax reader. this allows honu to be used at the repl --- collects/honu/core/language.rkt | 8 ++++++++ collects/honu/core/main.rkt | 1 + collects/honu/core/private/honu-typed-scheme.rkt | 4 +++- collects/honu/core/private/honu2.rkt | 7 +++++++ collects/honu/core/runtime.rkt | 7 +++++++ collects/honu/main.rkt | 2 +- collects/honu/private/lang/reader.rkt | 12 ++++++++++++ collects/honu/private/main.rkt | 4 ++++ 8 files changed, 43 insertions(+), 2 deletions(-) create mode 100644 collects/honu/core/runtime.rkt create mode 100644 collects/honu/private/lang/reader.rkt create mode 100644 collects/honu/private/main.rkt diff --git a/collects/honu/core/language.rkt b/collects/honu/core/language.rkt index 9ad2e7b29c..7bcc4e4a34 100644 --- a/collects/honu/core/language.rkt +++ b/collects/honu/core/language.rkt @@ -4,8 +4,16 @@ (provide honu-info) (define (honu-info key default default-filter) + (printf "get info for ~a\n" key) (case key [(color-lexer) (dynamic-require 'honu/core/read 'color-lexer)] [else (default-filter key default)])) + +(provide honu-language-info) +(define (honu-language-info data) + (lambda (key default) + (case key + [(configure-runtime) '(#(honu/core/runtime configure #f))] + [else default]))) diff --git a/collects/honu/core/main.rkt b/collects/honu/core/main.rkt index 625f4a7a92..da33167812 100644 --- a/collects/honu/core/main.rkt +++ b/collects/honu/core/main.rkt @@ -11,6 +11,7 @@ print printf true false (for-syntax (rename-out [honu-expression expression])) (rename-out [#%dynamic-honu-module-begin #%module-begin] + [honu-top-interaction #%top-interaction] [honu-function function] [honu-macro macro] [honu-syntax syntax] diff --git a/collects/honu/core/private/honu-typed-scheme.rkt b/collects/honu/core/private/honu-typed-scheme.rkt index 8e4b1fcb98..cd55a79591 100644 --- a/collects/honu/core/private/honu-typed-scheme.rkt +++ b/collects/honu/core/private/honu-typed-scheme.rkt @@ -460,7 +460,9 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt (debug "expanded ~a\n" (syntax->datum parsed)) (with-syntax ([parsed parsed] [(unparsed ...) unparsed]) - #'(begin parsed (honu-unparsed-begin unparsed ...)))])) + (if (null? (syntax->datum #'(unparsed ...))) + #'parsed + #'(begin parsed (honu-unparsed-begin unparsed ...))))])) (define-syntax (#%dynamic-honu-module-begin stx) (syntax-case stx () diff --git a/collects/honu/core/private/honu2.rkt b/collects/honu/core/private/honu2.rkt index c7e4d0f7d9..6f4a86d1fe 100644 --- a/collects/honu/core/private/honu2.rkt +++ b/collects/honu/core/private/honu2.rkt @@ -3,6 +3,7 @@ (require "macro2.rkt" "operator.rkt" "struct.rkt" + "honu-typed-scheme.rkt" (only-in "literals.rkt" honu-then semicolon) @@ -159,3 +160,9 @@ (define-binary-operator honu-map 0.09 'left map) (define-unary-operator honu-not 0.7 'left not) + +(provide honu-top-interaction) +(define-syntax (honu-top-interaction stx) + (syntax-case stx () + [(_ rest ...) + #'(printf "~a\n" (honu-unparsed-begin rest ...))])) diff --git a/collects/honu/core/runtime.rkt b/collects/honu/core/runtime.rkt new file mode 100644 index 0000000000..439689306e --- /dev/null +++ b/collects/honu/core/runtime.rkt @@ -0,0 +1,7 @@ +#lang racket/base + +(require "read.rkt") + +(provide configure) +(define (configure . args) + (current-read-interaction honu-read-syntax)) diff --git a/collects/honu/main.rkt b/collects/honu/main.rkt index c12adfe05c..d0575841c7 100644 --- a/collects/honu/main.rkt +++ b/collects/honu/main.rkt @@ -1,4 +1,4 @@ -#lang racket/base +#lang honu/private (require (prefix-in racket: (combine-in racket/base racket/list))) diff --git a/collects/honu/private/lang/reader.rkt b/collects/honu/private/lang/reader.rkt new file mode 100644 index 0000000000..53b832e2c5 --- /dev/null +++ b/collects/honu/private/lang/reader.rkt @@ -0,0 +1,12 @@ +#lang s-exp syntax/module-reader + +honu/private/main + +;;#:read honu-read +;;#:read-syntax honu-read-syntax +;;#:whole-body-readers? #t +#:language-info #(honu/core/language honu-language-info #f) +; #:language-info #(honu/core/runtime configure 'dont-care) + +(require honu/core/read + honu/core/language) diff --git a/collects/honu/private/main.rkt b/collects/honu/private/main.rkt new file mode 100644 index 0000000000..8694e2e130 --- /dev/null +++ b/collects/honu/private/main.rkt @@ -0,0 +1,4 @@ +#lang racket/base + +(require racket/base) +(provide (all-from-out racket/base)) From d53332c1f72309c9fe82739ca76e0c317b2d935d Mon Sep 17 00:00:00 2001 From: Jon Rafkind <rafkind@racket-lang.org> Date: Tue, 6 Sep 2011 15:44:14 -0600 Subject: [PATCH 201/235] [honu] remove debugging output --- collects/honu/core/language.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/honu/core/language.rkt b/collects/honu/core/language.rkt index 7bcc4e4a34..a5c303e543 100644 --- a/collects/honu/core/language.rkt +++ b/collects/honu/core/language.rkt @@ -4,7 +4,7 @@ (provide honu-info) (define (honu-info key default default-filter) - (printf "get info for ~a\n" key) + ; (printf "get info for ~a\n" key) (case key [(color-lexer) (dynamic-require 'honu/core/read 'color-lexer)] From 6bf5d43c37eb66e6d8cb863dd4b7fba22cafe7b4 Mon Sep 17 00:00:00 2001 From: Jon Rafkind <rafkind@racket-lang.org> Date: Tue, 6 Sep 2011 16:54:56 -0600 Subject: [PATCH 202/235] [honu] expand honu's #%top-interaction to racket's #%top-interaction --- collects/honu/core/private/honu-typed-scheme.rkt | 4 +++- collects/honu/core/private/honu2.rkt | 2 +- collects/honu/lang/reader.rkt | 1 + 3 files changed, 5 insertions(+), 2 deletions(-) diff --git a/collects/honu/core/private/honu-typed-scheme.rkt b/collects/honu/core/private/honu-typed-scheme.rkt index cd55a79591..118244f34b 100644 --- a/collects/honu/core/private/honu-typed-scheme.rkt +++ b/collects/honu/core/private/honu-typed-scheme.rkt @@ -457,7 +457,9 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt [(_) #'(void)] [(_ forms ...) (define-values (parsed unparsed) (honu-expand #'(forms ...))) - (debug "expanded ~a\n" (syntax->datum parsed)) + (debug "expanded ~a unexpanded ~a\n" + (syntax->datum parsed) + (syntax->datum unparsed)) (with-syntax ([parsed parsed] [(unparsed ...) unparsed]) (if (null? (syntax->datum #'(unparsed ...))) diff --git a/collects/honu/core/private/honu2.rkt b/collects/honu/core/private/honu2.rkt index 6f4a86d1fe..3a80e69957 100644 --- a/collects/honu/core/private/honu2.rkt +++ b/collects/honu/core/private/honu2.rkt @@ -165,4 +165,4 @@ (define-syntax (honu-top-interaction stx) (syntax-case stx () [(_ rest ...) - #'(printf "~a\n" (honu-unparsed-begin rest ...))])) + #'(#%top-interaction . (honu-unparsed-begin rest ...))])) diff --git a/collects/honu/lang/reader.rkt b/collects/honu/lang/reader.rkt index e813f69486..ed19d2233a 100644 --- a/collects/honu/lang/reader.rkt +++ b/collects/honu/lang/reader.rkt @@ -6,6 +6,7 @@ honu #:read-syntax honu-read-syntax #:whole-body-readers? #t #:info honu-info +#:language-info #(honu/core/language honu-language-info #f) (require "../core/read.rkt" "../core/language.rkt") From 6b2c251b2419d4047c7d27337e74f47e94444772 Mon Sep 17 00:00:00 2001 From: Jon Rafkind <rafkind@racket-lang.org> Date: Tue, 6 Sep 2011 17:32:28 -0600 Subject: [PATCH 203/235] [honu] remove old test file --- collects/tests/honu/test.rkt | 74 ------------------------------------ 1 file changed, 74 deletions(-) delete mode 100644 collects/tests/honu/test.rkt diff --git a/collects/tests/honu/test.rkt b/collects/tests/honu/test.rkt deleted file mode 100644 index 0b53bd27ce..0000000000 --- a/collects/tests/honu/test.rkt +++ /dev/null @@ -1,74 +0,0 @@ -#lang racket/base - -#| -(require - (prefix-in macro_ honu/core/private/macro2) - (rename-in honu/core/private/honu2 - [honu-function honu_function] - [honu-+ honu_plus] - [honu-* honu_times] - [honu-/ honu_division] - [honu-- honu_minus]) - (rename-in honu/core/private/literals - [honu-= =] - [semicolon |;|]) - (rename-in (only-in honu/core/private/honu-typed-scheme honu-var) - [honu-var var]) - (for-syntax racket/base - honu/core/private/macro2 - syntax/stx - racket/port - syntax/parse - (prefix-in parse: honu/core/private/parse2)) - racket/port) - -(define-syntax (fake-module-begin stx) - (syntax-case stx () - [(_ stuff) - (let () - (define output (parse:parse-all (stx-cdr #'stuff))) - (printf "Output: ~a\n" (syntax->datum output)) - output)])) - -#; -(fake-module-begin #hx(macro_macro foo (){ x:number }{ - withSyntax [z 5]{ - syntax(print(x); print(z);); - } - } - foo 5)) - - #; -(fake-module-begin #hx(2)) - -(fake-module-begin #hx(1;2)) - -(fake-module-begin #hx(var x = 2; - print(x))) - -#| - -(let () - (fake-module-begin #hx(honu_function test(x){ - print(x) - })) - (test 5)) - -(let () - (fake-module-begin #hx(honu_function test(x){ - print(x); - print(x) - } - test(2)))) - - -(let () - (fake-module-begin #hx(1 honu_plus 1))) - -(let () - (fake-module-begin #hx(1 honu_plus 1 honu_minus 4))) - -(let () - (fake-module-begin #hx(1 honu_plus 1 honu_minus 4 honu_times 8))) -|# -|# From 6f04fe343320e284d51bfed0c26fec501ce6e187 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen <matthias@ccs.neu.edu> Date: Tue, 6 Sep 2011 19:25:42 -0400 Subject: [PATCH 204/235] fixing scribble docs for check-* --- collects/test-engine/test-engine.scrbl | 36 ++++++++++++-------------- 1 file changed, 16 insertions(+), 20 deletions(-) diff --git a/collects/test-engine/test-engine.scrbl b/collects/test-engine/test-engine.scrbl index 4295ec3f1f..1add2643d0 100644 --- a/collects/test-engine/test-engine.scrbl +++ b/collects/test-engine/test-engine.scrbl @@ -24,31 +24,28 @@ and reported by the test function. Note that the check forms only register checks to be performed. The checks are actually run by the @racket[test] function. -@defproc[(check-expect (test any/c) (expected any/c)) void?]{ +@defform[(check-expect (test any/c) (expected any/c))]{ +Checks whether the value of the @racket[test] expression is structurally +equal to the value produced by the @racket[expected] expression. -Accepts two value-producing expressions and structurally compares the -resulting values. +It is an error for @racket[test] or @racket[expected] to produce a function +value or an inexact number.} -It is an error to produce a function value or an inexact number.} +@defform[(check-within (test any/c) (expected any/c) (delta number?))]{ +Checks whether the value of the @racket[test] expression is structurally +equal to the value produced by the @racket[expected] expression; every +number in the first expression must be within delta of the corresponding +number in the second expression. +It is an error for @racket[test] or @racket[expected] to produce a function +value.} -@defproc[(check-within (test any/c) (expected any/c) (delta number?)) void?]{ - -Like @racket[check-expect], but with an extra expression that produces -a number delta. Every number in the first expression must be within -delta of the cooresponding number in the second expression. - -It is an error to produce a function value.} - - -@defproc*[([(check-error (test any/c) (msg string?)) void?] - [(check-error (test any/c)) void?])]{ - -Checks that evaluating the first expression signals an error, where -the error message matches the string, if it is present.} +@defform*[ [(check-error (test any/c)) + (check-error (test any/c) (msg string?))] ]{ +Checks that evaluating @racket[test] signals an error, where +the error message matches the string (if any).} @defform[(check-member-of (test any/c) (expected any/c) ...)]{ - Checks whether the value of the @racket[test] expression is structurally equal to any of the values produced by the @racket[expected] expressions. @@ -56,7 +53,6 @@ It is an error for @racket[test] or any of the @racket[expected] expression to produce a function value.} @defform[(check-range (test number/c) (min number/c) (max number/c))]{ - Checks whether value of @racket[test] is between the values of the @racket[min] and @racket[max] expressions [inclusive].} From 710404fd47dc6f64cfc110fa26d15d18e2a0b281 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen <matthias@ccs.neu.edu> Date: Tue, 6 Sep 2011 19:34:12 -0400 Subject: [PATCH 205/235] fixing scribble docs for check-*, step 2 --- collects/test-engine/test-engine.scrbl | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/test-engine/test-engine.scrbl b/collects/test-engine/test-engine.scrbl index 1add2643d0..ca7dacfd71 100644 --- a/collects/test-engine/test-engine.scrbl +++ b/collects/test-engine/test-engine.scrbl @@ -34,8 +34,8 @@ value or an inexact number.} @defform[(check-within (test any/c) (expected any/c) (delta number?))]{ Checks whether the value of the @racket[test] expression is structurally equal to the value produced by the @racket[expected] expression; every -number in the first expression must be within delta of the corresponding -number in the second expression. +number in the first expression must be within @racket[delta] of the +corresponding number in the second expression. It is an error for @racket[test] or @racket[expected] to produce a function value.} @@ -50,7 +50,7 @@ Checks whether the value of the @racket[test] expression is structurally equal to any of the values produced by the @racket[expected] expressions. It is an error for @racket[test] or any of the @racket[expected] expression -to produce a function value.} +to produce a function value or an inexact number.} @defform[(check-range (test number/c) (min number/c) (max number/c))]{ Checks whether value of @racket[test] is between the values of the From 4577903c603a16fa67a0c04908f8a1b366628520 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt <samth@racket-lang.org> Date: Wed, 7 Sep 2011 07:52:53 -0400 Subject: [PATCH 206/235] Up timeout again. --- collects/meta/props | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/meta/props b/collects/meta/props index d0f441deab..f55e363f13 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1608,7 +1608,7 @@ path/s is either such a string or a list of them. "collects/tests/racket/benchmarks/mz/expand-class.rktl" drdr:command-line (racket "-f" *) "collects/tests/racket/benchmarks/mz/parsing.rktl" drdr:command-line (gracket "-f" *) "collects/tests/racket/benchmarks/mz/redsem.rktl" drdr:command-line (racket "-f" * "--" "--skip-struct-test") -"collects/tests/racket/benchmarks/mz/ssax.rktl" drdr:command-line (racket "-f" *) drdr:timeout 300 +"collects/tests/racket/benchmarks/mz/ssax.rktl" drdr:command-line (racket "-f" *) drdr:timeout 600 "collects/tests/racket/benchmarks/places" drdr:command-line #f "collects/tests/racket/benchmarks/rx/auto.rkt" drdr:command-line (racket "-t" * "--" "racket" "simple") drdr:timeout 600 "collects/tests/racket/benchmarks/shootout/ackermann.rkt" drdr:command-line (racket "-t" * "--" "10") From 7285200177cc47f679b3355b289ce24b940c4d5f Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt <samth@racket-lang.org> Date: Wed, 7 Sep 2011 09:15:41 -0400 Subject: [PATCH 207/235] Add links to tooltips, fix second y axis on zoom. --- collects/meta/drdr/render.rkt | 2 +- collects/meta/drdr/static/chart.js | 83 ++++++++++++++++++------------ 2 files changed, 50 insertions(+), 35 deletions(-) diff --git a/collects/meta/drdr/render.rkt b/collects/meta/drdr/render.rkt index d306832264..6a899a052a 100644 --- a/collects/meta/drdr/render.rkt +++ b/collects/meta/drdr/render.rkt @@ -379,7 +379,7 @@ (div ([id "_chart"] [style "width:800px;height:300px;"]) "") (script ([language "javascript"] [type "text/javascript"] [src "/chart.js"]) "") (script ([language "javascript"] [type "text/javascript"]) - ,(format "get_data('/json/timing~a');" the-base-path)) + ,(format "get_data('~a');" the-base-path)) (button ([onclick "reset_chart()"]) "Reset") (button ([id "setlegend"] [onclick "set_legend(!cur_options.legend.show)"]) "Hide Legend") diff --git a/collects/meta/drdr/static/chart.js b/collects/meta/drdr/static/chart.js index f194e0bce1..3acacfe80b 100644 --- a/collects/meta/drdr/static/chart.js +++ b/collects/meta/drdr/static/chart.js @@ -1,25 +1,13 @@ -function moving_avg(arr, i, _acc, _m) { - var acc = _acc || function(j) { return arr[j]; }; - var m = _m || 5; - var top = Math.min(i + m, arr.length); - var bot = Math.max(0, i - m); - var n = top - bot; - var sum = 0; - for (var i = bot; i < top; i++) - sum += acc(i); - return sum/n; -} - +var path = "" var data = null; var sub_times = []; var overall_times = []; -//var overall_avg = []; var chart_data = []; var options = { selection: { mode: "xy" }, legend: { backgroundOpacity: 0, position: "sw", show: true }, xaxes: [{label: 'push'}], yaxes: [{}, {position: "right"}], - grid: { hoverable : true } + grid: { clickable: true, hoverable : true } }; var placeholder = $("#_chart"); var cur_options = options; @@ -38,32 +26,59 @@ function showTooltip(x, y, contents) { }).appendTo("body").fadeIn(200); } +function makeTooltip(item,path) { + var x = item.datapoint[0]; + var y = item.datapoint[1].toFixed(2); + showTooltip(item.pageX, item.pageY, + item.series.label + ' at <a href="http://drdr.racket-lang.org/' + + x + path + '">push ' + x + "</a>: " + + y + " ms"); +} placeholder.bind("plotselected", handle_selection); -placeholder.bind("plothover", function (event, pos, item) { +// is the tooltip shown b/c of a click? +var tooltip_clicked = false; + +function remove_tooltip() { + tooltip_clicked = false; + $("#tooltip").remove(); +} + +function hover(event,pos,item) { + if (tooltip_clicked) return; if (item) { + // don't re-show the same tool-tip that's already shown if (previousPoint != item.dataIndex) { previousPoint = item.dataIndex; - - $("#tooltip").remove(); - var x = item.datapoint[0], - y = item.datapoint[1].toFixed(2); - - showTooltip(item.pageX, item.pageY, - item.series.label + " at push " + x + ": " - + y + " ms"); + remove_tooltip(); + makeTooltip(item,path); } } else { - $("#tooltip").remove(); + remove_tooltip(); previousPoint = null; } -}); +} + +function click(e,pos,item) { + if (tooltip_clicked) { + remove_tooltip(); + return; + } + if (!item) return; + tooltip_clicked = true; + // if we've already got the tooltip, just keep it around + if (previousPoint != item.dataIndex) { + $("#tooltip").remove(); + makeTooltip(item,path); + } +} +placeholder.bind("plothover", hover); +placeholder.bind("plotclick", click); function load_data(d) { chart_data = []; overall_times = []; - //overall_avg = []; sub_times = []; pdata = [] reset_chart(); @@ -77,9 +92,6 @@ function load_data(d) { // build the timing data arrays for (var i = 0; i < pdata.length; i++) { overall_times.push([pdata[i][0], pdata[i][1]]); - // overall_avg.push([pdata[i][0], - // moving_avg(pdata, i, - // function(j) { return pdata[j][1]; })]); max_overall = Math.max(max_overall, pdata[i][1]); if (pdata[i][2].length != 0) { for (var j = 0; j < pdata[i][2].length; j++) { @@ -98,15 +110,18 @@ function load_data(d) { // put the data into the chart format chart_data.push({data: overall_times, label: "Overall Time"}); - //chart_data.push({data: overall_avg, label: "Overall Moving Avg"}); for(var i = 0; i < sub_times.length; i++) { chart_data.push({data: sub_times[i], label: "Timer "+ (i+1), points: { show: true }, yaxis: ya}); } } -function get_data(url) { - //console.log("URL:", url); - $.ajax({url: url, +function get_data(_path) { + if (_path[0] != '/') + _path = '/' + _path; + path = _path; + console.log("_path",_path); + console.log("path",path); + $.ajax({url: 'http://drdr.racket-lang.org/json/timing'+path, beforeSend: function(xhr) { xhr.overrideMimeType( 'text/plain; charset=x-user-defined' ); }, @@ -118,7 +133,7 @@ function show() { $.plot(placeholder, chart_data, cur_options); } function handle_selection(event, ranges) { cur_options = $.extend(true, {}, cur_options, { - yaxis: { min: ranges.yaxis.from, max: ranges.yaxis.to }, + yaxes: [ { min: ranges.yaxis.from, max: ranges.yaxis.to },cur_options.yaxes[1]], xaxis: { min: ranges.xaxis.from, max: ranges.xaxis.to }}); show(); } From 53ce20d3f9edc9d405a33a8fb2e031b67dad7a09 Mon Sep 17 00:00:00 2001 From: Eric Dobson <eric.n.dobson@gmail.com> Date: Sun, 4 Sep 2011 21:49:10 -0700 Subject: [PATCH 208/235] Resolve names in overlap in TR. Closes PR11392. --- collects/tests/typed-racket/succeed/pr11392.rkt | 12 ++++++++++++ collects/typed-racket/types/remove-intersect.rkt | 4 ++++ 2 files changed, 16 insertions(+) create mode 100644 collects/tests/typed-racket/succeed/pr11392.rkt diff --git a/collects/tests/typed-racket/succeed/pr11392.rkt b/collects/tests/typed-racket/succeed/pr11392.rkt new file mode 100644 index 0000000000..78a832abe8 --- /dev/null +++ b/collects/tests/typed-racket/succeed/pr11392.rkt @@ -0,0 +1,12 @@ +#lang typed/racket +(struct: foo ((n : Number))) +(struct: bar ((n : Number))) + + +(define-type foobar (U foo bar)) +(define-predicate foobar? foobar) + +(: baz ((List) -> "two")) + +(define (baz x) + (if (foobar? x) 2 "two")) diff --git a/collects/typed-racket/types/remove-intersect.rkt b/collects/typed-racket/types/remove-intersect.rkt index 5101253e52..bbf00415e4 100644 --- a/collects/typed-racket/types/remove-intersect.rkt +++ b/collects/typed-racket/types/remove-intersect.rkt @@ -26,6 +26,10 @@ [(list (Name: n) (Name: n*)) (or (free-identifier=? n n*) (overlap (resolve-once t1) (resolve-once t2)))] + [(list _ (Name: _)) + (overlap t1 (resolve-once t2))] + [(list (Name: _) _) + (overlap (resolve-once t1) t2)] [(list (? Mu?) _) (overlap (unfold t1) t2)] [(list _ (? Mu?)) (overlap t1 (unfold t2))] From 32becc2e0a9a2c4d14b0c48fef602187e83e1d28 Mon Sep 17 00:00:00 2001 From: Eric Dobson <eric.n.dobson@gmail.com> Date: Mon, 5 Sep 2011 00:34:55 -0700 Subject: [PATCH 209/235] Change overlap for structs in TR. Closes PR11390. --- .../tests/typed-racket/succeed/pr11390.rkt | 22 +++++++++++++++++++ .../typed-racket/types/remove-intersect.rkt | 13 +++-------- 2 files changed, 25 insertions(+), 10 deletions(-) create mode 100644 collects/tests/typed-racket/succeed/pr11390.rkt diff --git a/collects/tests/typed-racket/succeed/pr11390.rkt b/collects/tests/typed-racket/succeed/pr11390.rkt new file mode 100644 index 0000000000..20397bf6bf --- /dev/null +++ b/collects/tests/typed-racket/succeed/pr11390.rkt @@ -0,0 +1,22 @@ +#lang typed/racket + +;Doesn't TypeCheck +(struct: foo ()) +(struct: foo-num foo ((v : Number))) +(struct: foo-str foo ((v : String))) + +#| +;TypeChecks +(struct: foo-num ((v : Number))) +(struct: foo-str ((v : String))) +|# + + +(: extract-foo (case-lambda + (foo-num -> Number) + (foo-str -> String))) + +(define (extract-foo foo) + (cond + ((foo-num? foo) (foo-num-v foo)) + ((foo-str? foo) (foo-str-v foo)))) diff --git a/collects/typed-racket/types/remove-intersect.rkt b/collects/typed-racket/types/remove-intersect.rkt index bbf00415e4..a0564e5fa1 100644 --- a/collects/typed-racket/types/remove-intersect.rkt +++ b/collects/typed-racket/types/remove-intersect.rkt @@ -80,16 +80,9 @@ [(list (Struct: n #f flds _ _ _ _ _) (StructTop: (Struct: n* #f flds* _ _ _ _ _))) #f] - [(list (and t1 (Struct: n p flds _ _ _ _ _)) - (and t2 (Struct: n* p* flds* _ _ _ _ _))) - (let ([p1 (if (Name? p) (resolve-name p) p)] - [p2 (if (Name? p*) (resolve-name p*) p*)]) - (or (and p2 (overlap t1 p2)) - (and p1 (overlap t2 p1)) - (and (= (length flds) (length flds*)) - (for/and ([f flds] [f* flds*]) - (match* (f f*) - [((fld: t _ _) (fld: t* _ _)) (overlap t t*)])))))] + [(list (and t1 (Struct: _ _ _ _ _ _ _ _)) + (and t2 (Struct: _ _ _ _ _ _ _ _))) + (or (subtype t1 t2) (subtype t2 t1))] [(list (== (-val eof)) (Function: _)) #f] From c62f09ac5b5d4788d06401010eb7cfd02a91c623 Mon Sep 17 00:00:00 2001 From: Eric Dobson <eric.n.dobson@gmail.com> Date: Mon, 5 Sep 2011 16:58:47 -0700 Subject: [PATCH 210/235] Fixed subtyping for StructTop. Closes PR11099. --- collects/tests/typed-racket/succeed/pr11099.rkt | 11 +++++++++++ collects/typed-racket/types/printer.rkt | 2 +- collects/typed-racket/types/subtype.rkt | 3 ++- 3 files changed, 14 insertions(+), 2 deletions(-) create mode 100644 collects/tests/typed-racket/succeed/pr11099.rkt diff --git a/collects/tests/typed-racket/succeed/pr11099.rkt b/collects/tests/typed-racket/succeed/pr11099.rkt new file mode 100644 index 0000000000..3f172bbc40 --- /dev/null +++ b/collects/tests/typed-racket/succeed/pr11099.rkt @@ -0,0 +1,11 @@ +#lang typed/racket + +(struct: (X) b ([bar : (Vectorof X)])) + +(define: b-val : (b Integer) + (b (ann (vector 1) (Vectorof Integer)))) + + +(if (b? b-val) + (b-bar b-val) + #f) diff --git a/collects/typed-racket/types/printer.rkt b/collects/typed-racket/types/printer.rkt index d05033c60b..0f2bd311fb 100644 --- a/collects/typed-racket/types/printer.rkt +++ b/collects/typed-racket/types/printer.rkt @@ -196,7 +196,7 @@ [(Name: stx) (fp "~a" (syntax-e stx))] [(app has-name? (? values name)) (fp "~a" name)] - [(StructTop: st) (fp "~a" st)] + [(StructTop: st) (fp "(struct-top: ~a)" st)] [(BoxTop:) (fp "Box")] [(ChannelTop:) (fp "Channel")] [(ThreadCellTop:) (fp "ThreadCell")] diff --git a/collects/typed-racket/types/subtype.rkt b/collects/typed-racket/types/subtype.rkt index 32e762d73a..4e0c646685 100644 --- a/collects/typed-racket/types/subtype.rkt +++ b/collects/typed-racket/types/subtype.rkt @@ -383,7 +383,8 @@ [proc* (fail! proc proc*)] [else A0])]) (subtype/flds* A flds flds*))] - [((Struct: _ _ _ _ _ _ _ _) (StructTop: (== s type-equal?))) + [((Struct: nm _ _ _ _ _ _ _) (StructTop: (Struct: nm* _ _ _ _ _ _ _))) (=> nevermind) + (unless (free-identifier=? nm nm*) (nevermind)) A0] ;ephemerons are covariant [((Ephemeron: s) (Ephemeron: t)) From b3b9c3fe22f87a2489f33fab9c0ded6f3e19736e Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt <samth@racket-lang.org> Date: Wed, 7 Sep 2011 10:40:51 -0400 Subject: [PATCH 211/235] Add logging to debug this timeout. --- collects/meta/props | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/meta/props b/collects/meta/props index f55e363f13..06d8b2ad72 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1608,7 +1608,7 @@ path/s is either such a string or a list of them. "collects/tests/racket/benchmarks/mz/expand-class.rktl" drdr:command-line (racket "-f" *) "collects/tests/racket/benchmarks/mz/parsing.rktl" drdr:command-line (gracket "-f" *) "collects/tests/racket/benchmarks/mz/redsem.rktl" drdr:command-line (racket "-f" * "--" "--skip-struct-test") -"collects/tests/racket/benchmarks/mz/ssax.rktl" drdr:command-line (racket "-f" *) drdr:timeout 600 +"collects/tests/racket/benchmarks/mz/ssax.rktl" drdr:command-line (racket "-W" "info" "-f" *) drdr:timeout 600 "collects/tests/racket/benchmarks/places" drdr:command-line #f "collects/tests/racket/benchmarks/rx/auto.rkt" drdr:command-line (racket "-t" * "--" "racket" "simple") drdr:timeout 600 "collects/tests/racket/benchmarks/shootout/ackermann.rkt" drdr:command-line (racket "-t" * "--" "10") From cd073ad549b67f3fe501456b0144f0cb17fd5bd7 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt <samth@racket-lang.org> Date: Wed, 7 Sep 2011 16:08:00 -0400 Subject: [PATCH 212/235] Switch to racket/base to fix bizarre bug. --- collects/tests/typed-racket/nightly-run.rkt | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/collects/tests/typed-racket/nightly-run.rkt b/collects/tests/typed-racket/nightly-run.rkt index d4798e5a07..04691b9cd2 100644 --- a/collects/tests/typed-racket/nightly-run.rkt +++ b/collects/tests/typed-racket/nightly-run.rkt @@ -1,8 +1,6 @@ -#lang scheme/base +#lang racket/base -(require scheme/runtime-path) +(require racket/runtime-path) (define-runtime-path run "run.rkt") -(if (eq? 'cgc (system-type 'gc)) - (printf "Running under CGC => skipping tests\n") - (parameterize ([current-command-line-arguments '#("--nightly")]) - (dynamic-require run #f))) +(parameterize ([current-command-line-arguments '#("--nightly")]) + (dynamic-require run #f)) From 26f6c588fcfa45a1a12c275e5824aede8ba23e3e Mon Sep 17 00:00:00 2001 From: Robby Findler <robby@racket-lang.org> Date: Wed, 7 Sep 2011 17:28:29 -0500 Subject: [PATCH 213/235] added a preference to restore the old run, new tab, and replace keybindings --- collects/drracket/private/main.rkt | 6 +++++- collects/drracket/private/unit.rkt | 9 +++++++-- .../private/english-string-constants.rkt | 3 ++- doc/release-notes/drracket/HISTORY.txt | 5 ++++- 4 files changed, 18 insertions(+), 5 deletions(-) diff --git a/collects/drracket/private/main.rkt b/collects/drracket/private/main.rkt index 6270a460a4..ec0dacb7a2 100644 --- a/collects/drracket/private/main.rkt +++ b/collects/drracket/private/main.rkt @@ -116,7 +116,7 @@ ll)))) (drr:set-default 'drracket:module-language-first-line-special? #t boolean?) - +(drr:set-default 'drracket:use-old-style-keybindings #f boolean?) (drr:set-default 'drracket:defns-popup-sort-by-name? #f boolean?) (drr:set-default 'drracket:show-line-numbers? #f boolean?) @@ -329,6 +329,10 @@ (make-check-box 'drracket:module-language-first-line-special? (string-constant ml-always-show-#lang-line) + editor-panel) + + (make-check-box 'drracket:use-old-style-keybindings + (string-constant old-style-keybindings) editor-panel))) (preferences:add-to-editor-checkbox-panel diff --git a/collects/drracket/private/unit.rkt b/collects/drracket/private/unit.rkt index 8c83dbc0f5..6b3bdee01a 100644 --- a/collects/drracket/private/unit.rkt +++ b/collects/drracket/private/unit.rkt @@ -3338,7 +3338,7 @@ module browser threading seems wrong. (set! file-menu:create-new-tab-item (new menu:can-restore-menu-item% (label (string-constant new-tab)) - (shortcut #\t) + (shortcut (if (preferences:get 'drracket:use-old-style-keybindings) #\= #\t)) (parent file-menu) (callback (λ (x y) @@ -3417,8 +3417,13 @@ module browser threading seems wrong. (preferences:get 'framework:print-output-mode))))) (super file-menu:between-print-and-close file-menu)) + (inherit edit-menu:get-replace-item) (define/override (edit-menu:between-find-and-preferences edit-menu) (super edit-menu:between-find-and-preferences edit-menu) + (when (preferences:get 'drracket:use-old-style-keybindings) + (define item (edit-menu:get-replace-item)) + (send item set-shortcut #\r) + (send item set-shortcut-prefix (get-default-shortcut-prefix))) (new menu:can-restore-menu-item% [label (string-constant complete-word)] [shortcut #\/] @@ -3621,7 +3626,7 @@ module browser threading seems wrong. (string-constant execute-menu-item-label) language-specific-menu (λ (_1 _2) (execute-callback)) - #\r + (if (preferences:get 'drracket:use-old-style-keybindings) #\t #\r) (string-constant execute-menu-item-help-string))) (make-object menu:can-restore-menu-item% (string-constant ask-quit-menu-item-label) diff --git a/collects/string-constants/private/english-string-constants.rkt b/collects/string-constants/private/english-string-constants.rkt index 6441bc4086..d4de794ca1 100644 --- a/collects/string-constants/private/english-string-constants.rkt +++ b/collects/string-constants/private/english-string-constants.rkt @@ -478,6 +478,7 @@ please adhere to these guidelines: (show-interactions-on-execute "Automatically open interactions window when running a program") (switch-to-module-language-automatically "Automatically switch to the module language when opening a module") (interactions-beside-definitions "Put the interactions window beside the definitions window") ;; in preferences, below the checkbox one line above this one + (old-style-keybindings "Old-style keybindings (Run: <menukey>-t; New-tab: <menukey>-=; Replace: <menukey>-r)") (show-line-numbers "Show line numbers") (show-line-numbers/menu "Show Line &Numbers") ;; just like the above, but capitalized for appearance in a menu item (hide-line-numbers/menu "Hide Line &Numbers") @@ -1373,7 +1374,7 @@ please adhere to these guidelines: ;; title of this section of the dialog (possibly the word ;; `Collection' should not be translated) (ml-cp-collection-paths "Collection Paths") - + ;; button labels (ml-cp-add "Add") (ml-cp-add-default "Add Default") diff --git a/doc/release-notes/drracket/HISTORY.txt b/doc/release-notes/drracket/HISTORY.txt index 73c95d1c6d..31c6656f26 100644 --- a/doc/release-notes/drracket/HISTORY.txt +++ b/doc/release-notes/drracket/HISTORY.txt @@ -2,11 +2,14 @@ Version 5.2 ------------------------------ - . changed a few menu keybidings: + . changed a three menu keybidings: "New Tab" is now <menukey>-t "Run" is now <menukey>-r "Replace" is now <menukey>-shift-f + The preferences dialog (general tab) has a checkbox to + restore the old behavior. + . added online expansion and check syntax . 2htdp/image: From 9e94c8b56c15077497a7277c125d57e6521f5314 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt <samth@racket-lang.org> Date: Wed, 7 Sep 2011 18:33:32 -0400 Subject: [PATCH 214/235] Enable turning timings on and off. --- collects/meta/drdr/static/chart.js | 45 +++++++++++++++++++++++++++--- 1 file changed, 41 insertions(+), 4 deletions(-) diff --git a/collects/meta/drdr/static/chart.js b/collects/meta/drdr/static/chart.js index 3acacfe80b..07a130c62e 100644 --- a/collects/meta/drdr/static/chart.js +++ b/collects/meta/drdr/static/chart.js @@ -3,12 +3,33 @@ var data = null; var sub_times = []; var overall_times = []; var chart_data = []; +var show_hide = {} var options = { selection: { mode: "xy" }, - legend: { backgroundOpacity: 0, position: "sw", show: true }, + legend: { backgroundOpacity: 0, + position: "sw", + show: true, + noColumns : 1, + labelFormatter : + function(label, series) { + if (show_hide[label] === undefined) + show_hide[label] = true; + var css = ''; + if (!show_hide[label]) { + css = 'style="font-style: italic"'; + } + var v = '<div '+css+' onclick="legend_click(\''+label+'\')">' + label + '</div>'; + return v;}}, xaxes: [{label: 'push'}], yaxes: [{}, {position: "right"}], grid: { clickable: true, hoverable : true } }; + +function legend_click(l) { + console.log(show_hide[l]); + show_hide[l] = !show_hide[l]; + show(); +} + var placeholder = $("#_chart"); var cur_options = options; var previousPoint = null; @@ -106,13 +127,15 @@ function load_data(d) { // and the internal timings? var ya = 1; - if (max_overall > (5 * max_sub)) { ya = 2; } + if ((max_overall > (5 * max_sub)) || ((max_overall * 5) < max_sub)) + ya = 2; // put the data into the chart format chart_data.push({data: overall_times, label: "Overall Time"}); for(var i = 0; i < sub_times.length; i++) { chart_data.push({data: sub_times[i], label: "Timer "+ (i+1), points: { show: true }, yaxis: ya}); } + options.legend.noColumns = Math.max(1,Math.round(chart_data.length / 10)); } function get_data(_path) { @@ -129,7 +152,21 @@ function get_data(_path) { } -function show() { $.plot(placeholder, chart_data, cur_options); } +function show() { + for(var i = 0; i < chart_data.length; i++) { + if (show_hide[chart_data[i].label] === false) { + if (!chart_data[i].saved) + chart_data[i].saved = chart_data[i].data + chart_data[i].data = []; + } + else if (chart_data[i].data.length === 0 && chart_data[i].saved !== null) { + chart_data[i].data = chart_data[i].saved; + chart_data[i].saved = null; + } + } + //console.log(chart_data); + $.plot(placeholder, chart_data, cur_options); +} function handle_selection(event, ranges) { cur_options = $.extend(true, {}, cur_options, { @@ -147,4 +184,4 @@ function set_legend(new_val) { $("#setlegend").text("Show Legend") } -function reset_chart() { cur_options = options; show(); } +function reset_chart() { cur_options = options; show_hide = {}; show(); } From 3ade0eaca9fd2ea3fca7f1a80150939d0ca6402e Mon Sep 17 00:00:00 2001 From: Robby Findler <robby@racket-lang.org> Date: Wed, 7 Sep 2011 22:15:50 -0500 Subject: [PATCH 215/235] let the planet resolver bestow on itself more powerful filesystem inspection capabilities --- collects/drracket/private/unit.rkt | 15 ++++-- collects/planet/private/planet-shared.rkt | 60 ++++++++++++++--------- collects/planet/private/resolver.rkt | 20 ++++---- 3 files changed, 59 insertions(+), 36 deletions(-) diff --git a/collects/drracket/private/unit.rkt b/collects/drracket/private/unit.rkt index 6b3bdee01a..8d8afe6504 100644 --- a/collects/drracket/private/unit.rkt +++ b/collects/drracket/private/unit.rkt @@ -1265,6 +1265,8 @@ module browser threading seems wrong. (define/public-final (toggle-log) (set! log-visible? (not log-visible?)) (send frame show/hide-log log-visible?)) + (define/public-final (hide-log) + (when log-visible? (toggle-log))) (define/public-final (update-log) (send frame show/hide-log log-visible?)) (define/public-final (update-logger-window command) @@ -1431,19 +1433,25 @@ module browser threading seems wrong. (remq logger-panel l)])))] [else (when show? ;; if we want to hide and it isn't built yet, do nothing + (define logger-gui-tab-panel-parent (new horizontal-panel% [parent logger-panel] [stretchable-height #f])) (set! logger-gui-tab-panel (new tab-panel% [choices (list (string-constant logging-all) "fatal" "error" "warning" "info" "debug")] - [parent logger-panel] + [parent logger-gui-tab-panel-parent] + [stretchable-height #f] + [style '(no-border)] [callback (λ (tp evt) (preferences:set 'drracket:logger-gui-tab-panel-level (send logger-gui-tab-panel get-selection)) (update-logger-window #f))])) + (new button% [label (string-constant hide-log)] + [callback (λ (x y) (send current-tab hide-log))] + [parent logger-gui-tab-panel-parent]) (send logger-gui-tab-panel set-selection (preferences:get 'drracket:logger-gui-tab-panel-level)) (new-logger-text) (set! logger-gui-canvas - (new editor-canvas% [parent logger-gui-tab-panel] [editor logger-gui-text])) + (new editor-canvas% [parent logger-panel] [editor logger-gui-text])) (send logger-menu-item set-label (string-constant hide-log)) (update-logger-window #f) (send logger-parent-panel change-children (lambda (l) (append l (list logger-panel)))))]) @@ -3122,8 +3130,7 @@ module browser threading seems wrong. [label (string-constant show-log)] [parent show-menu] [callback - (λ (x y) (send current-tab toggle-log))])) - ) + (λ (x y) (send current-tab toggle-log))]))) ; diff --git a/collects/planet/private/planet-shared.rkt b/collects/planet/private/planet-shared.rkt index b68161b3eb..ec274c508a 100644 --- a/collects/planet/private/planet-shared.rkt +++ b/collects/planet/private/planet-shared.rkt @@ -78,7 +78,18 @@ Various common pieces of code that both the client and server need to access check/take-installation-lock dir->successful-installation-file dir->unpacked-file - dir->metadata-files) + dir->metadata-files + + powerful-security-guard + with-powerful-security-guard) + + (define powerful-security-guard (make-parameter #f)) + (define-syntax-rule + (with-powerful-security-guard e1 e2 ...) + (with-powerful-security-guard/proc (λ () e1 e2 ...))) + (define (with-powerful-security-guard/proc t) + (parameterize ([current-security-guard (or (powerful-security-guard) (current-security-guard))]) + (t))) ; ========================================================================================== ; CACHE LOGIC @@ -222,25 +233,27 @@ Various common pieces of code that both the client and server need to access ;; get-hard-link-table/internal : -> assoc-table (define (get-hard-link-table/internal) (verify-well-formed-hard-link-parameter!) - (if (file-exists? (HARD-LINK-FILE)) - (map (lambda (item) (update/create-element 6 (λ (_) 'development-link) (update-element 4 bytes->path item))) - (with-input-from-file (HARD-LINK-FILE) read-all)) - '())) + (with-powerful-security-guard + (if (file-exists? (HARD-LINK-FILE)) + (map (lambda (item) (update/create-element 6 (λ (_) 'development-link) (update-element 4 bytes->path item))) + (with-input-from-file (HARD-LINK-FILE) read-all)) + '()))) (define (with-hard-link-lock t) - (let-values ([(base name dir) (split-path (HARD-LINK-FILE))]) - (try-make-directory* base)) - (call-with-file-lock/timeout - (HARD-LINK-FILE) - 'exclusive - t - (λ () - (error 'planet/planet-shared.rkt "unable to obtain lock on ~s" (HARD-LINK-FILE))))) + (with-powerful-security-guard + (let-values ([(base name dir) (split-path (HARD-LINK-FILE))]) + (try-make-directory* base)) + (call-with-file-lock/timeout + (HARD-LINK-FILE) + 'exclusive + t + (λ () + (error 'planet/planet-shared.rkt "unable to obtain lock on ~s" (HARD-LINK-FILE)))))) (define (get-hard-link-table) ;; we can only call with-hard-link-lock when the directory containing ;; (HARD-LINK-FILE) exists - (if (file-exists? (HARD-LINK-FILE)) + (if (with-powerful-security-guard (file-exists? (HARD-LINK-FILE))) (with-hard-link-lock (λ () (get-hard-link-table/internal))) @@ -267,14 +280,15 @@ Various common pieces of code that both the client and server need to access ;; assumes that the lock on the HARD-LINK table file has been acquired (define (save-hard-link-table table) (verify-well-formed-hard-link-parameter!) - (with-output-to-file (HARD-LINK-FILE) #:exists 'truncate - (lambda () - (display "") - (for-each - (lambda (row) - (write (update-element 4 path->bytes row)) - (newline)) - table)))) + (with-powerful-security-guard + (with-output-to-file (HARD-LINK-FILE) #:exists 'truncate + (lambda () + (display "") + (for-each + (lambda (row) + (write (update-element 4 path->bytes row)) + (newline)) + table))))) ;; add-hard-link! string (listof string) num num path -> void ;; adds the given hard link, clearing any previous ones already in place @@ -770,7 +784,7 @@ Various common pieces of code that both the client and server need to access ;; make sure the lock file exists (with-handlers ((exn:fail:filesystem:exists? void)) (call-with-output-file lf void)) - (define p (open-output-file lf #:exists 'truncate)) + (define p (with-powerful-security-guard (open-output-file lf #:exists 'truncate))) (cond [(port-try-file-lock? p 'exclusive) ;; we got the lock; keep the file open diff --git a/collects/planet/private/resolver.rkt b/collects/planet/private/resolver.rkt index 5ff32905a0..772bd9a028 100644 --- a/collects/planet/private/resolver.rkt +++ b/collects/planet/private/resolver.rkt @@ -341,7 +341,8 @@ See the scribble documentation on the planet/resolver module. [current-eval (call-with-parameterization orig-paramz current-eval)] [current-module-declare-name #f] [use-compiled-file-paths (call-with-parameterization orig-paramz use-compiled-file-paths)] - [current-library-collection-paths (call-with-parameterization orig-paramz current-library-collection-paths)]) + [current-library-collection-paths (call-with-parameterization orig-paramz current-library-collection-paths)] + [powerful-security-guard (call-with-parameterization orig-paramz current-security-guard)]) (let-values ([(path pkg) (get-planet-module-path/pkg/internal spec rmp stx load?)]) (when load? (add-pkg-to-diamond-registry! pkg stx)) (do-require path (pkg-path pkg) rmp stx load?)))) @@ -485,14 +486,15 @@ See the scribble documentation on the planet/resolver module. (try-make-directory* dir) (unless (equal? (normalize-path (uninstalled-pkg-path uninst-p)) (normalize-path full-pkg-path)) - (call-with-file-lock/timeout - full-pkg-path - 'exclusive - (λ () - (when (file-exists? full-pkg-path) (delete-file full-pkg-path)) - (copy-file (uninstalled-pkg-path uninst-p) full-pkg-path)) - (λ () - (log-error (format "planet/resolver.rkt: unable to save the planet package ~a" full-pkg-path))))) + (parameterize ([current-security-guard (or (powerful-security-guard) (current-security-guard))]) + (call-with-file-lock/timeout + full-pkg-path + 'exclusive + (λ () + (when (file-exists? full-pkg-path) (delete-file full-pkg-path)) + (copy-file (uninstalled-pkg-path uninst-p) full-pkg-path)) + (λ () + (log-error (format "planet/resolver.rkt: unable to save the planet package ~a" full-pkg-path)))))) full-pkg-path)) ;; ============================================================================= From b08f2704eadb9569a14a98ac6e560ae2b022afdc Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt <samth@racket-lang.org> Date: Thu, 8 Sep 2011 08:30:42 -0400 Subject: [PATCH 216/235] Up ssax timeout even more. --- collects/meta/props | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/meta/props b/collects/meta/props index 06d8b2ad72..992b4f6f08 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1608,7 +1608,7 @@ path/s is either such a string or a list of them. "collects/tests/racket/benchmarks/mz/expand-class.rktl" drdr:command-line (racket "-f" *) "collects/tests/racket/benchmarks/mz/parsing.rktl" drdr:command-line (gracket "-f" *) "collects/tests/racket/benchmarks/mz/redsem.rktl" drdr:command-line (racket "-f" * "--" "--skip-struct-test") -"collects/tests/racket/benchmarks/mz/ssax.rktl" drdr:command-line (racket "-W" "info" "-f" *) drdr:timeout 600 +"collects/tests/racket/benchmarks/mz/ssax.rktl" drdr:command-line (racket "-W" "info" "-f" *) drdr:timeout 900 "collects/tests/racket/benchmarks/places" drdr:command-line #f "collects/tests/racket/benchmarks/rx/auto.rkt" drdr:command-line (racket "-t" * "--" "racket" "simple") drdr:timeout 600 "collects/tests/racket/benchmarks/shootout/ackermann.rkt" drdr:command-line (racket "-t" * "--" "10") From 2b4f6047765f72d4d1ab2036ec006404b43092e1 Mon Sep 17 00:00:00 2001 From: Casey Klein <clklein@racket-lang.org> Date: Thu, 8 Sep 2011 04:45:28 -0500 Subject: [PATCH 217/235] Replaces use of `define-syntax-set' --- .../redex/private/reduction-semantics.rkt | 878 +++++++++--------- 1 file changed, 437 insertions(+), 441 deletions(-) diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt index f59b444e8f..bee4ab9034 100644 --- a/collects/redex/private/reduction-semantics.rkt +++ b/collects/redex/private/reduction-semantics.rkt @@ -1347,454 +1347,450 @@ ; ; -(define-syntax-set (define-metafunction define-metafunction/extension - define-relation - define-judgment-form) - - (define (define-metafunction/proc stx) - (syntax-case stx () - [(_ . rest) - (internal-define-metafunction stx #f #'rest #f)])) - - (define (define-relation/proc stx) - (syntax-case stx () - [(_ . rest) - ;; need to rule out the contracts for this one - (internal-define-metafunction stx #f #'rest #t)])) - - (define (define-metafunction/extension/proc stx) - (syntax-case stx () - [(_ prev . rest) - (identifier? #'prev) - (internal-define-metafunction stx #'prev #'rest #f)])) - - (define (internal-define-metafunction orig-stx prev-metafunction stx relation?) - (not-expression-context orig-stx) - (syntax-case stx () - [(lang . rest) - (let ([syn-error-name (if relation? - 'define-relation - (if prev-metafunction - 'define-metafunction/extension - 'define-metafunction))]) - (define lang-nts - ;; keep this near the beginning, so it signals the first error (PR 10062) - (definition-nts #'lang orig-stx syn-error-name)) - (when (null? (syntax-e #'rest)) - (raise-syntax-error syn-error-name "no clauses" orig-stx)) - (when prev-metafunction - (syntax-local-value - prev-metafunction - (λ () - (raise-syntax-error syn-error-name "expected a previously defined metafunction" orig-stx prev-metafunction)))) - (let*-values ([(contract-name dom-ctcs codom-contracts pats) - (split-out-contract orig-stx syn-error-name #'rest relation?)] - [(name _) (defined-name (list contract-name) pats orig-stx)]) - (with-syntax ([(((original-names lhs-clauses ...) raw-rhses ...) ...) pats] - [(lhs-for-lw ...) (lhs-lws pats)]) - (with-syntax ([((rhs stuff ...) ...) (if relation? - #'((,(and (term raw-rhses) ...)) ...) - #'((raw-rhses ...) ...))]) - (with-syntax ([(lhs ...) #'((lhs-clauses ...) ...)] - [name name]) - (when (and prev-metafunction (eq? (syntax-e #'name) (syntax-e prev-metafunction))) - (raise-syntax-error syn-error-name "the extended and extending metafunctions cannot share a name" orig-stx prev-metafunction)) - (parse-extras #'((stuff ...) ...)) - (let-values ([(lhs-namess lhs-namess/ellipsess) - (lhss-bound-names (syntax->list (syntax (lhs ...))) lang-nts syn-error-name)]) - (with-syntax ([(rhs/wheres ...) - (map (λ (sc/b rhs names names/ellipses) - (bind-withs - syn-error-name '() - #'effective-lang lang-nts - sc/b 'flatten - #`(list (term #,rhs)) - names names/ellipses)) - (syntax->list #'((stuff ...) ...)) - (syntax->list #'(rhs ...)) - lhs-namess lhs-namess/ellipsess)] - [(rg-rhs/wheres ...) - (map (λ (sc/b rhs names names/ellipses) - (bind-withs - syn-error-name '() - #'effective-lang lang-nts - sc/b 'predicate - #`#t - names names/ellipses)) - (syntax->list #'((stuff ...) ...)) - (syntax->list #'(rhs ...)) - lhs-namess lhs-namess/ellipsess)]) - (with-syntax ([(side-conditions-rewritten ...) - (map (λ (x) (rewrite-side-conditions/check-errs - lang-nts - syn-error-name - #t - x)) - (syntax->list (syntax (lhs ...))))] - [(rg-side-conditions-rewritten ...) - (map (λ (x) (rewrite-side-conditions/check-errs - lang-nts - syn-error-name - #t - x)) - (syntax->list (syntax ((side-condition lhs rg-rhs/wheres) ...))))] - [(clause-src ...) - (map (λ (lhs) - (format "~a:~a:~a" - (syntax-source lhs) - (syntax-line lhs) - (syntax-column lhs))) - pats)] - [dom-side-conditions-rewritten - (and dom-ctcs +(define-syntax (define-metafunction stx) + (syntax-case stx () + [(_ . rest) + (internal-define-metafunction stx #f #'rest #f)])) + +(define-syntax (define-relation stx) + (syntax-case stx () + [(_ . rest) + ;; need to rule out the contracts for this one + (internal-define-metafunction stx #f #'rest #t)])) + +(define-syntax (define-metafunction/extension stx) + (syntax-case stx () + [(_ prev . rest) + (identifier? #'prev) + (internal-define-metafunction stx #'prev #'rest #f)])) + +(define-for-syntax (internal-define-metafunction orig-stx prev-metafunction stx relation?) + (not-expression-context orig-stx) + (syntax-case stx () + [(lang . rest) + (let ([syn-error-name (if relation? + 'define-relation + (if prev-metafunction + 'define-metafunction/extension + 'define-metafunction))]) + (define lang-nts + ;; keep this near the beginning, so it signals the first error (PR 10062) + (definition-nts #'lang orig-stx syn-error-name)) + (when (null? (syntax-e #'rest)) + (raise-syntax-error syn-error-name "no clauses" orig-stx)) + (when prev-metafunction + (syntax-local-value + prev-metafunction + (λ () + (raise-syntax-error syn-error-name "expected a previously defined metafunction" orig-stx prev-metafunction)))) + (let*-values ([(contract-name dom-ctcs codom-contracts pats) + (split-out-contract orig-stx syn-error-name #'rest relation?)] + [(name _) (defined-name (list contract-name) pats orig-stx)]) + (with-syntax ([(((original-names lhs-clauses ...) raw-rhses ...) ...) pats] + [(lhs-for-lw ...) (lhs-lws pats)]) + (with-syntax ([((rhs stuff ...) ...) (if relation? + #'((,(and (term raw-rhses) ...)) ...) + #'((raw-rhses ...) ...))]) + (with-syntax ([(lhs ...) #'((lhs-clauses ...) ...)] + [name name]) + (when (and prev-metafunction (eq? (syntax-e #'name) (syntax-e prev-metafunction))) + (raise-syntax-error syn-error-name "the extended and extending metafunctions cannot share a name" orig-stx prev-metafunction)) + (parse-extras #'((stuff ...) ...)) + (let-values ([(lhs-namess lhs-namess/ellipsess) + (lhss-bound-names (syntax->list (syntax (lhs ...))) lang-nts syn-error-name)]) + (with-syntax ([(rhs/wheres ...) + (map (λ (sc/b rhs names names/ellipses) + (bind-withs + syn-error-name '() + #'effective-lang lang-nts + sc/b 'flatten + #`(list (term #,rhs)) + names names/ellipses)) + (syntax->list #'((stuff ...) ...)) + (syntax->list #'(rhs ...)) + lhs-namess lhs-namess/ellipsess)] + [(rg-rhs/wheres ...) + (map (λ (sc/b rhs names names/ellipses) + (bind-withs + syn-error-name '() + #'effective-lang lang-nts + sc/b 'predicate + #`#t + names names/ellipses)) + (syntax->list #'((stuff ...) ...)) + (syntax->list #'(rhs ...)) + lhs-namess lhs-namess/ellipsess)]) + (with-syntax ([(side-conditions-rewritten ...) + (map (λ (x) (rewrite-side-conditions/check-errs + lang-nts + syn-error-name + #t + x)) + (syntax->list (syntax (lhs ...))))] + [(rg-side-conditions-rewritten ...) + (map (λ (x) (rewrite-side-conditions/check-errs + lang-nts + syn-error-name + #t + x)) + (syntax->list (syntax ((side-condition lhs rg-rhs/wheres) ...))))] + [(clause-src ...) + (map (λ (lhs) + (format "~a:~a:~a" + (syntax-source lhs) + (syntax-line lhs) + (syntax-column lhs))) + pats)] + [dom-side-conditions-rewritten + (and dom-ctcs + (rewrite-side-conditions/check-errs + lang-nts + syn-error-name + #f + dom-ctcs))] + [(codom-side-conditions-rewritten ...) + (map (λ (codom-contract) (rewrite-side-conditions/check-errs lang-nts syn-error-name #f - dom-ctcs))] - [(codom-side-conditions-rewritten ...) - (map (λ (codom-contract) - (rewrite-side-conditions/check-errs - lang-nts - syn-error-name - #f - codom-contract)) - codom-contracts)] - [(rhs-fns ...) - (map (λ (names names/ellipses rhs/where) - (with-syntax ([(names ...) names] - [(names/ellipses ...) names/ellipses] - [rhs/where rhs/where]) - (syntax - (λ (name bindings) - (term-let-fn ((name name)) - (term-let ([names/ellipses (lookup-binding bindings 'names)] ...) - rhs/where)))))) - lhs-namess lhs-namess/ellipsess - (syntax->list (syntax (rhs/wheres ...))))] - [(name2 name-predicate) (generate-temporaries (syntax (name name)))]) - (with-syntax ([defs #`(begin - (define-values (name2 name-predicate) - (let ([sc `(side-conditions-rewritten ...)] - [dsc `dom-side-conditions-rewritten]) - (let ([cases (map (λ (pat rhs-fn rg-lhs src) - (make-metafunc-case - (λ (effective-lang) (compile-pattern effective-lang pat #t)) - rhs-fn - rg-lhs src (gensym))) - sc - (list (λ (effective-lang) rhs-fns) ...) - (list (λ (effective-lang) `rg-side-conditions-rewritten) ...) - `(clause-src ...))] - [parent-cases - #,(if prev-metafunction - #`(metafunc-proc-cases #,(term-fn-get-id (syntax-local-value prev-metafunction))) - #'null)]) - (build-metafunction - lang - cases - parent-cases - (λ (f/dom) - (make-metafunc-proc - (let ([name (lambda (x) (f/dom x))]) name) - (generate-lws #,relation? - (lhs ...) - (lhs-for-lw ...) - ((stuff ...) ...) - #,(if relation? - #'((raw-rhses ...) ...) - #'(rhs ...))) - lang - #t ;; multi-args? - 'name - (let ([name (lambda (x) (name-predicate x))]) name) - dsc - (append cases parent-cases) - #,relation?)) - dsc - `(codom-side-conditions-rewritten ...) - 'name - #,relation?)))) - (term-define-fn name name2))]) - (syntax-property - (prune-syntax - (if (eq? 'top-level (syntax-local-context)) - ; Introduce the names before using them, to allow - ; metafunction definition at the top-level. - (syntax - (begin - (define-syntaxes (name2 name-predicate) (values)) - defs)) - (syntax defs))) - 'disappeared-use - (map syntax-local-introduce - (syntax->list #'(original-names ...)))))))))))))])) + codom-contract)) + codom-contracts)] + [(rhs-fns ...) + (map (λ (names names/ellipses rhs/where) + (with-syntax ([(names ...) names] + [(names/ellipses ...) names/ellipses] + [rhs/where rhs/where]) + (syntax + (λ (name bindings) + (term-let-fn ((name name)) + (term-let ([names/ellipses (lookup-binding bindings 'names)] ...) + rhs/where)))))) + lhs-namess lhs-namess/ellipsess + (syntax->list (syntax (rhs/wheres ...))))] + [(name2 name-predicate) (generate-temporaries (syntax (name name)))]) + (with-syntax ([defs #`(begin + (define-values (name2 name-predicate) + (let ([sc `(side-conditions-rewritten ...)] + [dsc `dom-side-conditions-rewritten]) + (let ([cases (map (λ (pat rhs-fn rg-lhs src) + (make-metafunc-case + (λ (effective-lang) (compile-pattern effective-lang pat #t)) + rhs-fn + rg-lhs src (gensym))) + sc + (list (λ (effective-lang) rhs-fns) ...) + (list (λ (effective-lang) `rg-side-conditions-rewritten) ...) + `(clause-src ...))] + [parent-cases + #,(if prev-metafunction + #`(metafunc-proc-cases #,(term-fn-get-id (syntax-local-value prev-metafunction))) + #'null)]) + (build-metafunction + lang + cases + parent-cases + (λ (f/dom) + (make-metafunc-proc + (let ([name (lambda (x) (f/dom x))]) name) + (generate-lws #,relation? + (lhs ...) + (lhs-for-lw ...) + ((stuff ...) ...) + #,(if relation? + #'((raw-rhses ...) ...) + #'(rhs ...))) + lang + #t ;; multi-args? + 'name + (let ([name (lambda (x) (name-predicate x))]) name) + dsc + (append cases parent-cases) + #,relation?)) + dsc + `(codom-side-conditions-rewritten ...) + 'name + #,relation?)))) + (term-define-fn name name2))]) + (syntax-property + (prune-syntax + (if (eq? 'top-level (syntax-local-context)) + ; Introduce the names before using them, to allow + ; metafunction definition at the top-level. + (syntax + (begin + (define-syntaxes (name2 name-predicate) (values)) + defs)) + (syntax defs))) + 'disappeared-use + (map syntax-local-introduce + (syntax->list #'(original-names ...)))))))))))))])) - (define (define-judgment-form/proc stx) - (not-expression-context stx) - (syntax-case stx () - [(def-form-id lang . body) - (let ([lang #'lang] - [syn-err-name (syntax-e #'def-form-id)]) - (define nts (definition-nts lang stx syn-err-name)) - (define-values (judgment-form-name dup-form-names mode position-contracts clauses) - (parse-judgment-form-body #'body syn-err-name stx)) - (define definitions - #`(begin - (define-syntax #,judgment-form-name - (judgment-form '#,judgment-form-name '#,mode #'judgment-form-proc #'#,lang #'judgment-form-lws)) - (define judgment-form-proc - (compile-judgment-form-proc #,judgment-form-name #,lang #,mode #,clauses #,position-contracts #,stx #,syn-err-name)) - (define judgment-form-lws - (compiled-judgment-form-lws #,clauses)))) - (syntax-property - (prune-syntax - (if (eq? 'top-level (syntax-local-context)) - ; Introduce the names before using them, to allow - ; judgment form definition at the top-level. - #`(begin - (define-syntaxes (judgment-form-proc judgment-form-lws) (values)) - #,definitions) - definitions)) - 'disappeared-use - (map syntax-local-introduce dup-form-names)))])) - - (define (parse-judgment-form-body body syn-err-name full-stx) - (define-syntax-class pos-mode - #:literals (I O) - (pattern I) - (pattern O)) - (define-syntax-class mode-spec - #:description "mode specification" - (pattern (_:id _:pos-mode ...))) - (define-syntax-class contract-spec - #:description "contract specification" - (pattern (_:id _:expr ...))) - (define (horizontal-line? id) - (regexp-match? #rx"^-+$" (symbol->string (syntax-e id)))) - (define-syntax-class horizontal-line - (pattern x:id #:when (horizontal-line? #'x))) - (define (parse-rules rules) - (for/list ([rule rules]) - (syntax-parse rule - [(prem ... _:horizontal-line conc) - #'(conc prem ...)] - [_ rule]))) - (define-values (name/mode mode name/contract contract rules) - (syntax-parse body #:context full-stx - [((~or (~seq #:mode ~! mode:mode-spec) - (~seq #:contract ~! contract:contract-spec)) - ... . rules:expr) - (let-values ([(name/mode mode) - (syntax-parse #'(mode ...) - [((name . mode)) (values #'name (syntax->list #'mode))] - [_ (raise-syntax-error - #f "expected definition to include a mode specification" - full-stx)])] - [(name/ctc ctc) - (syntax-parse #'(contract ...) - [() (values #f #f)] - [((name . contract)) (values #'name (syntax->list #'contract))] - [(_ . dups) - (raise-syntax-error - syn-err-name "expected at most one contract specification" - #f #f (syntax->list #'dups))])]) - (values name/mode mode name/ctc ctc (parse-rules #'rules)))])) - (check-clauses full-stx syn-err-name rules #t) - (check-arity-consistency mode contract full-stx) - (define-values (form-name dup-names) - (syntax-case rules () - [() (raise-syntax-error #f "expected at least one rule" full-stx)] - [_ (defined-name (list name/mode name/contract) rules full-stx)])) - (values form-name dup-names mode contract rules)) - - (define (check-arity-consistency mode contracts full-def) - (when (and contracts (not (= (length mode) (length contracts)))) - (raise-syntax-error - #f "mode and contract specify different numbers of positions" full-def))) - - (define (lhss-bound-names lhss nts syn-error-name) - (let loop ([lhss lhss]) - (if (null? lhss) - (values null null) - (let-values ([(namess namess/ellipsess) - (loop (cdr lhss))] - [(names names/ellipses) - (extract-names nts syn-error-name #t (car lhss))]) - (values (cons names namess) - (cons names/ellipses namess/ellipsess)))))) - - (define (defined-name declared-names clauses orig-stx) - (with-syntax ([(((used-names _ ...) _ ...) ...) clauses]) - (define-values (the-name other-names) - (let ([present (filter values declared-names)]) - (if (null? present) - (values (car (syntax->list #'(used-names ...))) - (cdr (syntax->list #'(used-names ...)))) - (values (car present) - (append (cdr present) (syntax->list #'(used-names ...))))))) - (let loop ([others other-names]) +(define-syntax (define-judgment-form stx) + (not-expression-context stx) + (syntax-case stx () + [(def-form-id lang . body) + (let ([lang #'lang] + [syn-err-name (syntax-e #'def-form-id)]) + (define nts (definition-nts lang stx syn-err-name)) + (define-values (judgment-form-name dup-form-names mode position-contracts clauses) + (parse-judgment-form-body #'body syn-err-name stx)) + (define definitions + #`(begin + (define-syntax #,judgment-form-name + (judgment-form '#,judgment-form-name '#,mode #'judgment-form-proc #'#,lang #'judgment-form-lws)) + (define judgment-form-proc + (compile-judgment-form-proc #,judgment-form-name #,lang #,mode #,clauses #,position-contracts #,stx #,syn-err-name)) + (define judgment-form-lws + (compiled-judgment-form-lws #,clauses)))) + (syntax-property + (prune-syntax + (if (eq? 'top-level (syntax-local-context)) + ; Introduce the names before using them, to allow + ; judgment form definition at the top-level. + #`(begin + (define-syntaxes (judgment-form-proc judgment-form-lws) (values)) + #,definitions) + definitions)) + 'disappeared-use + (map syntax-local-introduce dup-form-names)))])) + +(define-for-syntax (parse-judgment-form-body body syn-err-name full-stx) + (define-syntax-class pos-mode + #:literals (I O) + (pattern I) + (pattern O)) + (define-syntax-class mode-spec + #:description "mode specification" + (pattern (_:id _:pos-mode ...))) + (define-syntax-class contract-spec + #:description "contract specification" + (pattern (_:id _:expr ...))) + (define (horizontal-line? id) + (regexp-match? #rx"^-+$" (symbol->string (syntax-e id)))) + (define-syntax-class horizontal-line + (pattern x:id #:when (horizontal-line? #'x))) + (define (parse-rules rules) + (for/list ([rule rules]) + (syntax-parse rule + [(prem ... _:horizontal-line conc) + #'(conc prem ...)] + [_ rule]))) + (define-values (name/mode mode name/contract contract rules) + (syntax-parse body #:context full-stx + [((~or (~seq #:mode ~! mode:mode-spec) + (~seq #:contract ~! contract:contract-spec)) + ... . rules:expr) + (let-values ([(name/mode mode) + (syntax-parse #'(mode ...) + [((name . mode)) (values #'name (syntax->list #'mode))] + [_ (raise-syntax-error + #f "expected definition to include a mode specification" + full-stx)])] + [(name/ctc ctc) + (syntax-parse #'(contract ...) + [() (values #f #f)] + [((name . contract)) (values #'name (syntax->list #'contract))] + [(_ . dups) + (raise-syntax-error + syn-err-name "expected at most one contract specification" + #f #f (syntax->list #'dups))])]) + (values name/mode mode name/ctc ctc (parse-rules #'rules)))])) + (check-clauses full-stx syn-err-name rules #t) + (check-arity-consistency mode contract full-stx) + (define-values (form-name dup-names) + (syntax-case rules () + [() (raise-syntax-error #f "expected at least one rule" full-stx)] + [_ (defined-name (list name/mode name/contract) rules full-stx)])) + (values form-name dup-names mode contract rules)) + +(define-for-syntax (check-arity-consistency mode contracts full-def) + (when (and contracts (not (= (length mode) (length contracts)))) + (raise-syntax-error + #f "mode and contract specify different numbers of positions" full-def))) + +(define-for-syntax (lhss-bound-names lhss nts syn-error-name) + (let loop ([lhss lhss]) + (if (null? lhss) + (values null null) + (let-values ([(namess namess/ellipsess) + (loop (cdr lhss))] + [(names names/ellipses) + (extract-names nts syn-error-name #t (car lhss))]) + (values (cons names namess) + (cons names/ellipses namess/ellipsess)))))) + +(define-for-syntax (defined-name declared-names clauses orig-stx) + (with-syntax ([(((used-names _ ...) _ ...) ...) clauses]) + (define-values (the-name other-names) + (let ([present (filter values declared-names)]) + (if (null? present) + (values (car (syntax->list #'(used-names ...))) + (cdr (syntax->list #'(used-names ...)))) + (values (car present) + (append (cdr present) (syntax->list #'(used-names ...))))))) + (let loop ([others other-names]) + (cond + [(null? others) (values the-name other-names)] + [else + (unless (eq? (syntax-e the-name) (syntax-e (car others))) + (raise-syntax-error + #f + "expected the same name in both positions" + orig-stx + the-name (list (car others)))) + (loop (cdr others))])))) + +(define-for-syntax (split-out-contract stx syn-error-name rest relation?) + ;; initial test determines if a contract is specified or not + (cond + [(pair? (syntax-e (car (syntax->list rest)))) + (values #f #f (list #'any) (check-clauses stx syn-error-name (syntax->list rest) relation?))] + [else + (syntax-case rest () + [(id separator more ...) + (identifier? #'id) (cond - [(null? others) (values the-name other-names)] + [relation? + (let-values ([(contract clauses) + (parse-relation-contract #'(separator more ...) syn-error-name stx)]) + (when (null? clauses) + (raise-syntax-error syn-error-name + "expected clause definitions to follow domain contract" + stx)) + (values #'id contract (list #'any) (check-clauses stx syn-error-name clauses #t)))] [else - (unless (eq? (syntax-e the-name) (syntax-e (car others))) - (raise-syntax-error - #f - "expected the same name in both positions" - orig-stx - the-name (list (car others)))) - (loop (cdr others))])))) - - (define (split-out-contract stx syn-error-name rest relation?) - ;; initial test determines if a contract is specified or not - (cond - [(pair? (syntax-e (car (syntax->list rest)))) - (values #f #f (list #'any) (check-clauses stx syn-error-name (syntax->list rest) relation?))] - [else - (syntax-case rest () - [(id separator more ...) - (identifier? #'id) - (cond - [relation? - (let-values ([(contract clauses) - (parse-relation-contract #'(separator more ...) syn-error-name stx)]) - (when (null? clauses) - (raise-syntax-error syn-error-name - "expected clause definitions to follow domain contract" - stx)) - (values #'id contract (list #'any) (check-clauses stx syn-error-name clauses #t)))] - [else - (unless (eq? ': (syntax-e #'separator)) - (raise-syntax-error syn-error-name "expected a colon to follow the meta-function's name" stx #'separator)) - (let loop ([more (syntax->list #'(more ...))] - [dom-pats '()]) - (cond - [(null? more) - (raise-syntax-error syn-error-name "expected an ->" stx)] - [(eq? (syntax-e (car more)) '->) - (define-values (raw-clauses rev-codomains) - (let loop ([prev (car more)] - [more (cdr more)] - [codomains '()]) - (cond - [(null? more) - (raise-syntax-error syn-error-name "expected a range contract to follow" stx prev)] - [else - (define after-this-one (cdr more)) - (cond - [(null? after-this-one) - (values null (cons (car more) codomains))] - [else - (define kwd (cadr more)) - (cond - [(member (syntax-e kwd) '(or ∨ ∪)) - (loop kwd - (cddr more) - (cons (car more) codomains))] - [else - (values (cdr more) - (cons (car more) codomains))])])]))) - (let ([doms (reverse dom-pats)] - [clauses (check-clauses stx syn-error-name raw-clauses relation?)]) - (values #'id doms (reverse rev-codomains) clauses))] - [else - (loop (cdr more) (cons (car more) dom-pats))]))])] - [_ - (raise-syntax-error - syn-error-name - (format "expected the name of the ~a, followed by its contract (or no name and no contract)" - (if relation? "relation" "meta-function")) - stx - rest)])])) - - (define (check-clauses stx syn-error-name rest relation?) - (syntax-case rest () - [([(lhs ...) roc1 roc2 ...] ...) - rest] - [([(lhs ...) rhs ...] ...) - (if relation? - rest - (begin - (for-each - (λ (clause) - (syntax-case clause () - [(a b) (void)] - [x (raise-syntax-error syn-error-name "expected a pattern and a right-hand side" stx clause)])) - rest) - (raise-syntax-error syn-error-name "error checking failed.3" stx)))] - [([x roc ...] ...) - (begin - (for-each - (λ (x) - (syntax-case x () - [(lhs ...) (void)] - [x (raise-syntax-error syn-error-name "expected a function prototype" stx #'x)])) - (syntax->list #'(x ...))) - (raise-syntax-error syn-error-name "error checking failed.1" stx))] - [(x ...) - (begin - (for-each - (λ (x) - (syntax-case x () - [(stuff ...) (void)] - [x (raise-syntax-error syn-error-name "expected a clause" stx #'x)])) - (syntax->list #'(x ...))) - (raise-syntax-error syn-error-name "error checking failed.2" stx))])) - - (define (parse-extras extras) - (for-each - (λ (stuffs) - (for-each - (λ (stuff) - (syntax-case stuff (where side-condition where/hidden side-condition/hidden) - [(side-condition tl-side-conds ...) - (void)] - [(side-condition/hidden tl-side-conds ...) - (void)] - [(where x e) - (void)] - [(where/hidden x e) - (void)] - [(where . args) - (raise-syntax-error 'define-metafunction - "malformed where clause" - stuff)] - [(where/hidden . args) - (raise-syntax-error 'define-metafunction - "malformed where/hidden clause" - stuff)] - [_ - (raise-syntax-error 'define-metafunction - "expected a side-condition or where clause" - stuff)])) - (syntax->list stuffs))) - (syntax->list extras))) - - (define (parse-relation-contract after-name syn-error-name orig-stx) - (syntax-case after-name () - [(subset . rest-pieces) - (unless (memq (syntax-e #'subset) '(⊂ ⊆)) - (raise-syntax-error syn-error-name - "expected ⊂ or ⊆ to follow the relation's name" - orig-stx #'subset)) - (let ([more (syntax->list #'rest-pieces)]) - (when (null? more) - (raise-syntax-error syn-error-name - (format "expected a sequence of patterns separated by x or × to follow ~a" - (syntax-e #'subset)) - orig-stx - #'subset)) - (let loop ([more (cdr more)] - [arg-pats (list (car more))]) - (cond - [(and (not (null? more)) (memq (syntax-e (car more)) '(x ×))) - (when (null? (cdr more)) - (raise-syntax-error syn-error-name - (format "expected a pattern to follow ~a" (syntax-e (car more))) - orig-stx (car more))) - (loop (cddr more) - (cons (cadr more) arg-pats))] - [else (values (reverse arg-pats) more)])))]))) + (unless (eq? ': (syntax-e #'separator)) + (raise-syntax-error syn-error-name "expected a colon to follow the meta-function's name" stx #'separator)) + (let loop ([more (syntax->list #'(more ...))] + [dom-pats '()]) + (cond + [(null? more) + (raise-syntax-error syn-error-name "expected an ->" stx)] + [(eq? (syntax-e (car more)) '->) + (define-values (raw-clauses rev-codomains) + (let loop ([prev (car more)] + [more (cdr more)] + [codomains '()]) + (cond + [(null? more) + (raise-syntax-error syn-error-name "expected a range contract to follow" stx prev)] + [else + (define after-this-one (cdr more)) + (cond + [(null? after-this-one) + (values null (cons (car more) codomains))] + [else + (define kwd (cadr more)) + (cond + [(member (syntax-e kwd) '(or ∨ ∪)) + (loop kwd + (cddr more) + (cons (car more) codomains))] + [else + (values (cdr more) + (cons (car more) codomains))])])]))) + (let ([doms (reverse dom-pats)] + [clauses (check-clauses stx syn-error-name raw-clauses relation?)]) + (values #'id doms (reverse rev-codomains) clauses))] + [else + (loop (cdr more) (cons (car more) dom-pats))]))])] + [_ + (raise-syntax-error + syn-error-name + (format "expected the name of the ~a, followed by its contract (or no name and no contract)" + (if relation? "relation" "meta-function")) + stx + rest)])])) + +(define-for-syntax (check-clauses stx syn-error-name rest relation?) + (syntax-case rest () + [([(lhs ...) roc1 roc2 ...] ...) + rest] + [([(lhs ...) rhs ...] ...) + (if relation? + rest + (begin + (for-each + (λ (clause) + (syntax-case clause () + [(a b) (void)] + [x (raise-syntax-error syn-error-name "expected a pattern and a right-hand side" stx clause)])) + rest) + (raise-syntax-error syn-error-name "error checking failed.3" stx)))] + [([x roc ...] ...) + (begin + (for-each + (λ (x) + (syntax-case x () + [(lhs ...) (void)] + [x (raise-syntax-error syn-error-name "expected a function prototype" stx #'x)])) + (syntax->list #'(x ...))) + (raise-syntax-error syn-error-name "error checking failed.1" stx))] + [(x ...) + (begin + (for-each + (λ (x) + (syntax-case x () + [(stuff ...) (void)] + [x (raise-syntax-error syn-error-name "expected a clause" stx #'x)])) + (syntax->list #'(x ...))) + (raise-syntax-error syn-error-name "error checking failed.2" stx))])) + +(define-for-syntax (parse-extras extras) + (for-each + (λ (stuffs) + (for-each + (λ (stuff) + (syntax-case stuff (where side-condition where/hidden side-condition/hidden) + [(side-condition tl-side-conds ...) + (void)] + [(side-condition/hidden tl-side-conds ...) + (void)] + [(where x e) + (void)] + [(where/hidden x e) + (void)] + [(where . args) + (raise-syntax-error 'define-metafunction + "malformed where clause" + stuff)] + [(where/hidden . args) + (raise-syntax-error 'define-metafunction + "malformed where/hidden clause" + stuff)] + [_ + (raise-syntax-error 'define-metafunction + "expected a side-condition or where clause" + stuff)])) + (syntax->list stuffs))) + (syntax->list extras))) + +(define-for-syntax (parse-relation-contract after-name syn-error-name orig-stx) + (syntax-case after-name () + [(subset . rest-pieces) + (unless (memq (syntax-e #'subset) '(⊂ ⊆)) + (raise-syntax-error syn-error-name + "expected ⊂ or ⊆ to follow the relation's name" + orig-stx #'subset)) + (let ([more (syntax->list #'rest-pieces)]) + (when (null? more) + (raise-syntax-error syn-error-name + (format "expected a sequence of patterns separated by x or × to follow ~a" + (syntax-e #'subset)) + orig-stx + #'subset)) + (let loop ([more (cdr more)] + [arg-pats (list (car more))]) + (cond + [(and (not (null? more)) (memq (syntax-e (car more)) '(x ×))) + (when (null? (cdr more)) + (raise-syntax-error syn-error-name + (format "expected a pattern to follow ~a" (syntax-e (car more))) + orig-stx (car more))) + (loop (cddr more) + (cons (cadr more) arg-pats))] + [else (values (reverse arg-pats) more)])))])) (define-syntax (judgment-holds stx) (syntax-case stx () From ac7856a377fe85bd1ed84ddf85dcb270a6110ec5 Mon Sep 17 00:00:00 2001 From: Casey Klein <clklein@racket-lang.org> Date: Thu, 8 Sep 2011 06:24:12 -0500 Subject: [PATCH 218/235] Moves metafunction construction to later expansion step --- .../redex/private/reduction-semantics.rkt | 305 ++++++++++-------- 1 file changed, 163 insertions(+), 142 deletions(-) diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt index bee4ab9034..e78e6ddfad 100644 --- a/collects/redex/private/reduction-semantics.rkt +++ b/collects/redex/private/reduction-semantics.rkt @@ -1373,9 +1373,8 @@ (if prev-metafunction 'define-metafunction/extension 'define-metafunction))]) - (define lang-nts - ;; keep this near the beginning, so it signals the first error (PR 10062) - (definition-nts #'lang orig-stx syn-error-name)) + ;; keep this near the beginning, so it signals the first error (PR 10062) + (definition-nts #'lang orig-stx syn-error-name) (when (null? (syntax-e #'rest)) (raise-syntax-error syn-error-name "no clauses" orig-stx)) (when prev-metafunction @@ -1386,145 +1385,167 @@ (let*-values ([(contract-name dom-ctcs codom-contracts pats) (split-out-contract orig-stx syn-error-name #'rest relation?)] [(name _) (defined-name (list contract-name) pats orig-stx)]) - (with-syntax ([(((original-names lhs-clauses ...) raw-rhses ...) ...) pats] - [(lhs-for-lw ...) (lhs-lws pats)]) - (with-syntax ([((rhs stuff ...) ...) (if relation? - #'((,(and (term raw-rhses) ...)) ...) - #'((raw-rhses ...) ...))]) - (with-syntax ([(lhs ...) #'((lhs-clauses ...) ...)] - [name name]) - (when (and prev-metafunction (eq? (syntax-e #'name) (syntax-e prev-metafunction))) - (raise-syntax-error syn-error-name "the extended and extending metafunctions cannot share a name" orig-stx prev-metafunction)) - (parse-extras #'((stuff ...) ...)) - (let-values ([(lhs-namess lhs-namess/ellipsess) - (lhss-bound-names (syntax->list (syntax (lhs ...))) lang-nts syn-error-name)]) - (with-syntax ([(rhs/wheres ...) - (map (λ (sc/b rhs names names/ellipses) - (bind-withs - syn-error-name '() - #'effective-lang lang-nts - sc/b 'flatten - #`(list (term #,rhs)) - names names/ellipses)) - (syntax->list #'((stuff ...) ...)) - (syntax->list #'(rhs ...)) - lhs-namess lhs-namess/ellipsess)] - [(rg-rhs/wheres ...) - (map (λ (sc/b rhs names names/ellipses) - (bind-withs - syn-error-name '() - #'effective-lang lang-nts - sc/b 'predicate - #`#t - names names/ellipses)) - (syntax->list #'((stuff ...) ...)) - (syntax->list #'(rhs ...)) - lhs-namess lhs-namess/ellipsess)]) - (with-syntax ([(side-conditions-rewritten ...) - (map (λ (x) (rewrite-side-conditions/check-errs - lang-nts - syn-error-name - #t - x)) - (syntax->list (syntax (lhs ...))))] - [(rg-side-conditions-rewritten ...) - (map (λ (x) (rewrite-side-conditions/check-errs - lang-nts - syn-error-name - #t - x)) - (syntax->list (syntax ((side-condition lhs rg-rhs/wheres) ...))))] - [(clause-src ...) - (map (λ (lhs) - (format "~a:~a:~a" - (syntax-source lhs) - (syntax-line lhs) - (syntax-column lhs))) - pats)] - [dom-side-conditions-rewritten - (and dom-ctcs - (rewrite-side-conditions/check-errs - lang-nts - syn-error-name - #f - dom-ctcs))] - [(codom-side-conditions-rewritten ...) - (map (λ (codom-contract) - (rewrite-side-conditions/check-errs - lang-nts - syn-error-name - #f - codom-contract)) - codom-contracts)] - [(rhs-fns ...) - (map (λ (names names/ellipses rhs/where) - (with-syntax ([(names ...) names] - [(names/ellipses ...) names/ellipses] - [rhs/where rhs/where]) - (syntax - (λ (name bindings) - (term-let-fn ((name name)) - (term-let ([names/ellipses (lookup-binding bindings 'names)] ...) - rhs/where)))))) - lhs-namess lhs-namess/ellipsess - (syntax->list (syntax (rhs/wheres ...))))] - [(name2 name-predicate) (generate-temporaries (syntax (name name)))]) - (with-syntax ([defs #`(begin - (define-values (name2 name-predicate) - (let ([sc `(side-conditions-rewritten ...)] - [dsc `dom-side-conditions-rewritten]) - (let ([cases (map (λ (pat rhs-fn rg-lhs src) - (make-metafunc-case - (λ (effective-lang) (compile-pattern effective-lang pat #t)) - rhs-fn - rg-lhs src (gensym))) - sc - (list (λ (effective-lang) rhs-fns) ...) - (list (λ (effective-lang) `rg-side-conditions-rewritten) ...) - `(clause-src ...))] - [parent-cases - #,(if prev-metafunction - #`(metafunc-proc-cases #,(term-fn-get-id (syntax-local-value prev-metafunction))) - #'null)]) - (build-metafunction - lang - cases - parent-cases - (λ (f/dom) - (make-metafunc-proc - (let ([name (lambda (x) (f/dom x))]) name) - (generate-lws #,relation? - (lhs ...) - (lhs-for-lw ...) - ((stuff ...) ...) - #,(if relation? - #'((raw-rhses ...) ...) - #'(rhs ...))) - lang - #t ;; multi-args? - 'name - (let ([name (lambda (x) (name-predicate x))]) name) - dsc - (append cases parent-cases) - #,relation?)) - dsc - `(codom-side-conditions-rewritten ...) - 'name - #,relation?)))) - (term-define-fn name name2))]) - (syntax-property - (prune-syntax - (if (eq? 'top-level (syntax-local-context)) - ; Introduce the names before using them, to allow - ; metafunction definition at the top-level. - (syntax - (begin - (define-syntaxes (name2 name-predicate) (values)) - defs)) - (syntax defs))) - 'disappeared-use - (map syntax-local-introduce - (syntax->list #'(original-names ...)))))))))))))])) + (when (and prev-metafunction (eq? (syntax-e #'name) (syntax-e prev-metafunction))) + (raise-syntax-error syn-error-name "the extended and extending metafunctions cannot share a name" orig-stx prev-metafunction)) + (with-syntax ([(name2 name-predicate) (generate-temporaries (list name name))] + [name name]) + (with-syntax ([defs #`(begin + (define-values (name2 name-predicate) + (generate-metafunction #,orig-stx + lang + #,prev-metafunction + name + name-predicate + #,dom-ctcs + #,codom-contracts + #,pats + #,relation? + #,syn-error-name)) + (term-define-fn name name2))]) + (if (eq? 'top-level (syntax-local-context)) + ; Introduce the names before using them, to allow + ; metafunction definition at the top-level. + (syntax + (begin + (define-syntaxes (name2 name-predicate) (values)) + defs)) + (syntax defs))))))])) + +(define-syntax (generate-metafunction stx) + (syntax-case stx () + [(_ orig-stx lang prev-metafunction name name-predicate dom-ctcs codom-contracts pats relation? syn-error-name) + (let ([prev-metafunction (and (syntax-e #'prev-metafunction) #'prev-metafunction)] + [dom-ctcs (syntax-e #'dom-ctcs)] + [codom-contracts (syntax-e #'codom-contracts)] + [pats (syntax-e #'pats)] + [relation? (syntax-e #'relation?)] + [syn-error-name (syntax-e #'syn-err-name)]) + (define lang-nts + (definition-nts #'lang #'orig-stx syn-error-name)) + (with-syntax ([(((original-names lhs-clauses ...) raw-rhses ...) ...) pats] + [(lhs-for-lw ...) (lhs-lws pats)]) + (with-syntax ([((rhs stuff ...) ...) (if relation? + #'((,(and (term raw-rhses) ...)) ...) + #'((raw-rhses ...) ...))] + [(lhs ...) #'((lhs-clauses ...) ...)]) + (parse-extras #'((stuff ...) ...)) + (let-values ([(lhs-namess lhs-namess/ellipsess) + (lhss-bound-names (syntax->list (syntax (lhs ...))) lang-nts syn-error-name)]) + (with-syntax ([(rhs/wheres ...) + (map (λ (sc/b rhs names names/ellipses) + (bind-withs + syn-error-name '() + #'effective-lang lang-nts + sc/b 'flatten + #`(list (term #,rhs)) + names names/ellipses)) + (syntax->list #'((stuff ...) ...)) + (syntax->list #'(rhs ...)) + lhs-namess lhs-namess/ellipsess)] + [(rg-rhs/wheres ...) + (map (λ (sc/b rhs names names/ellipses) + (bind-withs + syn-error-name '() + #'effective-lang lang-nts + sc/b 'predicate + #`#t + names names/ellipses)) + (syntax->list #'((stuff ...) ...)) + (syntax->list #'(rhs ...)) + lhs-namess lhs-namess/ellipsess)]) + (with-syntax ([(side-conditions-rewritten ...) + (map (λ (x) (rewrite-side-conditions/check-errs + lang-nts + syn-error-name + #t + x)) + (syntax->list (syntax (lhs ...))))] + [(rg-side-conditions-rewritten ...) + (map (λ (x) (rewrite-side-conditions/check-errs + lang-nts + syn-error-name + #t + x)) + (syntax->list (syntax ((side-condition lhs rg-rhs/wheres) ...))))] + [(clause-src ...) + (map (λ (lhs) + (format "~a:~a:~a" + (syntax-source lhs) + (syntax-line lhs) + (syntax-column lhs))) + pats)] + [dom-side-conditions-rewritten + (and dom-ctcs + (rewrite-side-conditions/check-errs + lang-nts + syn-error-name + #f + dom-ctcs))] + [(codom-side-conditions-rewritten ...) + (map (λ (codom-contract) + (rewrite-side-conditions/check-errs + lang-nts + syn-error-name + #f + codom-contract)) + codom-contracts)] + [(rhs-fns ...) + (map (λ (names names/ellipses rhs/where) + (with-syntax ([(names ...) names] + [(names/ellipses ...) names/ellipses] + [rhs/where rhs/where]) + (syntax + (λ (name bindings) + (term-let-fn ((name name)) + (term-let ([names/ellipses (lookup-binding bindings 'names)] ...) + rhs/where)))))) + lhs-namess lhs-namess/ellipsess + (syntax->list (syntax (rhs/wheres ...))))]) + (syntax-property + (prune-syntax + #`(let ([sc `(side-conditions-rewritten ...)] + [dsc `dom-side-conditions-rewritten]) + (let ([cases (map (λ (pat rhs-fn rg-lhs src) + (make-metafunc-case + (λ (effective-lang) (compile-pattern effective-lang pat #t)) + rhs-fn + rg-lhs src (gensym))) + sc + (list (λ (effective-lang) rhs-fns) ...) + (list (λ (effective-lang) `rg-side-conditions-rewritten) ...) + `(clause-src ...))] + [parent-cases + #,(if prev-metafunction + #`(metafunc-proc-cases #,(term-fn-get-id (syntax-local-value prev-metafunction))) + #'null)]) + (build-metafunction + lang + cases + parent-cases + (λ (f/dom) + (make-metafunc-proc + (let ([name (lambda (x) (f/dom x))]) name) + (generate-lws #,relation? + (lhs ...) + (lhs-for-lw ...) + ((stuff ...) ...) + #,(if relation? + #'((raw-rhses ...) ...) + #'(rhs ...))) + lang + #t ;; multi-args? + 'name + (let ([name (lambda (x) (name-predicate x))]) name) + dsc + (append cases parent-cases) + #,relation?)) + dsc + `(codom-side-conditions-rewritten ...) + 'name + #,relation?)))) + 'disappeared-use + (map syntax-local-introduce + (syntax->list #'(original-names ...))))))))))])) (define-syntax (define-judgment-form stx) (not-expression-context stx) From 6d43376f9c5c7acbf44e29351abbe0fe6d673f3b Mon Sep 17 00:00:00 2001 From: Casey Klein <clklein@racket-lang.org> Date: Thu, 8 Sep 2011 07:36:47 -0500 Subject: [PATCH 219/235] Adds support for `judgment-holds' clauses in metafunctions --- .../redex/private/reduction-semantics.rkt | 35 ++++++++++++------- collects/redex/redex.scrbl | 11 ++++-- collects/redex/tests/bitmap-test.rkt | 14 +++++++- collects/redex/tests/tl-test.rkt | 23 ++++++++++++ 4 files changed, 67 insertions(+), 16 deletions(-) diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt index e78e6ddfad..737df91be6 100644 --- a/collects/redex/private/reduction-semantics.rkt +++ b/collects/redex/private/reduction-semantics.rkt @@ -328,7 +328,7 @@ [env (make-immutable-hash (map (λ (x e) (cons (syntax-e x) e)) names w/ellipses))]) - (syntax-case stx (fresh) + (syntax-case stx (fresh judgment-holds) [() body] [((-where x e) y ...) (where-keyword? #'-where) @@ -390,6 +390,8 @@ (verify-names-ok '#,orig-name the-names len-counter) (variables-not-in #,to-not-be-in the-names))]) #,(loop #'(z ...) #`(list (term (y #,'...)) #,to-not-be-in) env))] + [((judgment-holds j) . after) + (loop (cons #'j #'after) to-not-be-in env)] [((form-name . pats) . after) (judgment-form-id? #'form-name) (let*-values ([(premise) (syntax-case stx () [(p . _) #'p])] @@ -1763,7 +1765,7 @@ (λ (stuffs) (for-each (λ (stuff) - (syntax-case stuff (where side-condition where/hidden side-condition/hidden) + (syntax-case stuff (where side-condition where/hidden side-condition/hidden judgment-holds) [(side-condition tl-side-conds ...) (void)] [(side-condition/hidden tl-side-conds ...) @@ -1780,6 +1782,11 @@ (raise-syntax-error 'define-metafunction "malformed where/hidden clause" stuff)] + [(judgment-holds (form-name . _)) + (unless (judgment-form-id? #'form-name) + (raise-syntax-error 'define-metafunction + "expected the name of a judgment-form" + #'form-name))] [_ (raise-syntax-error 'define-metafunction "expected a side-condition or where clause" @@ -1876,16 +1883,6 @@ (for/fold ([outputs '()]) ([rule (list clause-proc ...)]) (append (rule input) outputs))))) -(define-for-syntax (in-order-non-hidden extras) - (reverse - (filter (λ (extra) - (syntax-case extra (where/hidden - side-condition/hidden) - [(where/hidden pat exp) #f] - [(side-condition/hidden x) #f] - [_ #t])) - (syntax->list extras)))) - (define-for-syntax (do-compile-judgment-form-lws clauses) (syntax-case clauses () [(((_ . conc-body) . prems) ...) @@ -2000,6 +1997,9 @@ (map (λ (lst) (syntax-case lst (unquote side-condition where) + [(form-name . _) + (judgment-form-id? #'form-name) + #`(make-metafunc-extra-side-cond #,(to-lw/proc lst))] [(form-name . _) (judgment-form-id? #'form-name) #`(make-metafunc-extra-side-cond #,(to-lw/proc lst))] @@ -2054,6 +2054,17 @@ rhs/lw) ...))])) +(define-for-syntax (in-order-non-hidden extras) + (for/fold ([visible empty]) ([extra (syntax->list extras)]) + (syntax-case extra (where/hidden + side-condition/hidden + judgment-holds) + [(where/hidden pat exp) visible] + [(side-condition/hidden x) visible] + [(judgment-holds judgment) + (cons #'judgment visible)] + [_ (cons extra visible)]))) + (define-syntax (compile-judgment-form-proc stx) (syntax-case stx () [(_ judgment-form-name lang mode clauses ctcs full-def syn-err-name) diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index 25e9f61360..7b94318b28 100644 --- a/collects/redex/redex.scrbl +++ b/collects/redex/redex.scrbl @@ -706,7 +706,7 @@ otherwise. (fresh fresh-clause ...) (side-condition racket-expression) (where @#,ttpattern @#,tttterm) - (judgment-holds (judgment-form-id pat/term)) + (judgment-holds (judgment-form-id pat/term ...)) (side-condition/hidden racket-expression) (where/hidden @#,ttpattern @#,tttterm)] [shortcuts (code:line) @@ -960,7 +960,10 @@ it is traversing through the reduction graph. @declare-exporting[redex/reduction-semantics redex] -@defform/subs[#:literals (: -> where side-condition side-condition/hidden where/hidden) +@defform/subs[#:literals (: -> + where side-condition + side-condition/hidden where/hidden + judgment-holds) (define-metafunction language metafunction-contract [(name @#,ttpattern ...) @#,tttterm extras ...] @@ -974,7 +977,9 @@ it is traversing through the reduction graph. [extras (side-condition racket-expression) (side-condition/hidden racket-expression) (where pat @#,tttterm) - (where/hidden pat @#,tttterm)])]{ + (where/hidden pat @#,tttterm) + (judgment-holds + (judgment-form-id pat/term ...))])]{ The @racket[define-metafunction] form builds a function on sexpressions according to the pattern and right-hand-side diff --git a/collects/redex/tests/bitmap-test.rkt b/collects/redex/tests/bitmap-test.rkt index 448de5d24f..7c5639abd1 100644 --- a/collects/redex/tests/bitmap-test.rkt +++ b/collects/redex/tests/bitmap-test.rkt @@ -98,6 +98,18 @@ (test (render-metafunction S) "metafunction.png") +(let () + (define-metafunction lang + [(f (e_1 e_2)) + (e_3 e_4) + (judgment-holds (J e_1 e_3)) + (judgment-holds (J e_2 e_4))]) + (define-judgment-form lang + #:mode (J I O) + [(J e e)]) + (test (render-metafunction f) + "metafunction-judgment-holds.png")) + (define-metafunction lang [(T x y) 1 @@ -367,4 +379,4 @@ "stlc.png")) (printf "bitmap-test.rkt: ") -(done) \ No newline at end of file +(done) diff --git a/collects/redex/tests/tl-test.rkt b/collects/redex/tests/tl-test.rkt index 6a9ab71b79..c58a04472f 100644 --- a/collects/redex/tests/tl-test.rkt +++ b/collects/redex/tests/tl-test.rkt @@ -977,6 +977,29 @@ x) '(2 1))) + (let () + (define-language L + (n z (s n))) + + (define-metafunction L + [(f n) + n_1 + (judgment-holds (p n n_1))]) + + (define-judgment-form L + #:mode (p I O) + #:contract (p n n) + [(p z z)] + [(p (s n) n)] + [(p (s n) z)]) + + (test (term (f (s z))) + (term z)) + (test (with-handlers ([exn:fail:redex? exn-message]) + (term (f (s (s z)))) + "") + #rx"different ways and returned different results")) + (parameterize ([current-namespace (make-base-namespace)]) (eval '(require redex/reduction-semantics)) (exec-runtime-error-tests "run-err-tests/judgment-form-undefined.rktd")) From 97e792200f2a302083e5a9cdc24753209a17dd62 Mon Sep 17 00:00:00 2001 From: Casey Klein <clklein@racket-lang.org> Date: Thu, 8 Sep 2011 07:54:55 -0500 Subject: [PATCH 220/235] Gives a function a better name --- collects/redex/private/reduction-semantics.rkt | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt index 737df91be6..abfcaa6cb3 100644 --- a/collects/redex/private/reduction-semantics.rkt +++ b/collects/redex/private/reduction-semantics.rkt @@ -2024,11 +2024,11 @@ [maybe-ellipsis (ellipsis? #'maybe-ellipsis) (to-lw/proc #'maybe-ellipsis)])) - (in-order-non-hidden hm))) + (visible-extras hm))) (syntax->list #'seq-of-tl-side-cond/binds))] [(((where-bind-id/lw . where-bind-pat/lw) ...) ...) (map (λ (clauses) - (for/fold ([binds '()]) ([clause (in-order-non-hidden clauses)]) + (for/fold ([binds '()]) ([clause (visible-extras clauses)]) (syntax-case clause (where) [(form-name . pieces) (judgment-form-id? #'form-name) @@ -2054,7 +2054,7 @@ rhs/lw) ...))])) -(define-for-syntax (in-order-non-hidden extras) +(define-for-syntax (visible-extras extras) (for/fold ([visible empty]) ([extra (syntax->list extras)]) (syntax-case extra (where/hidden side-condition/hidden From 634f5c9e0c4e8130fe18b653e8236ff09192c37f Mon Sep 17 00:00:00 2001 From: Casey Klein <clklein@racket-lang.org> Date: Thu, 8 Sep 2011 08:08:24 -0500 Subject: [PATCH 221/235] Removes now outdated comment --- collects/redex/private/reduction-semantics.rkt | 3 --- 1 file changed, 3 deletions(-) diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt index abfcaa6cb3..fcfca2f1d8 100644 --- a/collects/redex/private/reduction-semantics.rkt +++ b/collects/redex/private/reduction-semantics.rkt @@ -1976,9 +1976,6 @@ (fold-clause (bind 'rhs-only) void (make-immutable-free-id-table) clause))) (fold-clause (bind 'rhs-only) do-tmpl (make-immutable-free-id-table) clause))) -;; Defined as a macro instead of an ordinary phase 1 function so that the -;; to-lw/proc calls occur after bindings are established for all meta-functions -;; and relations. (define-syntax (generate-lws stx) (syntax-case stx () [(_ relation? seq-of-lhs seq-of-lhs-for-lw seq-of-tl-side-cond/binds seq-of-rhs) From 9944e6b3f620b777c0d1929b5d2ac4b81a30f781 Mon Sep 17 00:00:00 2001 From: Casey Klein <clklein@racket-lang.org> Date: Thu, 8 Sep 2011 10:43:23 -0500 Subject: [PATCH 222/235] Adds missing test image --- .../bmps-macosx/metafunction-judgment-holds.png | Bin 0 -> 2374 bytes 1 file changed, 0 insertions(+), 0 deletions(-) create mode 100644 collects/redex/tests/bmps-macosx/metafunction-judgment-holds.png diff --git a/collects/redex/tests/bmps-macosx/metafunction-judgment-holds.png b/collects/redex/tests/bmps-macosx/metafunction-judgment-holds.png new file mode 100644 index 0000000000000000000000000000000000000000..df49babea94d15158a90a45b619e1681abbb75b3 GIT binary patch literal 2374 zcmV-M3Ay%(P)<h;3K|Lk000e1NJLTq005Q%0018d0ssI2irk~600006VoOIv0RI60 z0RN!9r;`8x2>VGyK~!jg?V4Fk6JHy~Pbp;)lzkHdM1m}>$P(0)27^RmAq49`ghB}j z!Gs_PMh%KVxv)eu7*J6IDw`k*DAf`v1{4#73k^~XVOT_<6etv-P=uCtzKcnk+S1yV zviODP>Ya1mbKW0wIx}Z@1_i?~06-uRa5x+X2M4gDe@*C|oSdgmpAw10v9U1{i9{d} zK79Bf5{Z(MlG@tZL?V%cgM)#A0RTWC5IlVN5R1j?>FH^uc6WDoPfw4Fiwko2?b|m7 zgFzyZI2;a(#UhbNdU|^P{{HK%veDREFBpai1VU<RDh$Ig3<m@R(CKvP0Fgi-NJvPS zo}Pxas<&_7mX(!Bw~)!?`}gll2kX(MVQ-;yl9Q8}OlDJ46O~F;veK26m0n(6mX?;< z{Q-rAg_V|;E-o%gH=<A|nLuN0CiYfICptRX#>OTnDCoqA6N-{x7^YIGCr_T#dU+HI z6%Y{c=+Pss&kX)qY;~o3^ypDjQ_}+n4*2=`DM}h2A0HVRadL8!ZtU&tefRDi0AP7} z`RdiHN@^(2#Nlw|<>ePIUQ``AD=Vw4tW2gcGcz+iJ$*Z4Z;*6UNg5m+w6e02zOB7~ z|Ng>-3+K+A+p}lS<m4m(U}<TowY7C>YD#9Td}d!?ADvDYi9|?(nVH$Zz<^rNX=!Qi z<rEVWqX9Ob&wumg4VTOPD>kC8t}czSH%PjwB=LAW=|c{OL!nTfJb7~O-o2@*soS@2 z0|0jI+Er0eQBY8zJac}2et3A8$z*>2{{8ah%K!jFL&NFmX|<s3?Ck99?6iW-<MH<I z-=CYCo1dSrJQDy=S6A2G-tOb$qZ#%FNu?!pb93WxI3ke<jYb0iXf&FYm6g7}ep*@@ z27{5L{r>&i)YMdZpnRr*fdP?7TwGj~tO1wHRrh`L?%lf$4Gl7liHV7^v9ao6)9Lj3 z`g%H@t{fWxz+f=gY<6g9sK(eEB$bxX#l=NWPmjalAm^RW=UZA@hJ=Iw03Zl*c6Qd+ z*YEA^_3-eJ8MtQV+}zyC$_jx%KyoH0C$U(pTF`-kf%f+HGL7<+sDho8l+@JJ#A30W zot>3n(`Ym|H@EWg@~EgNjj=aKDm@Ezb#>Fy(!PHEiX28qN3+@N#Kgp^s;arUIemS7 z06<ey6Y@7pOFnaTb+xgvF*Y_<C=?<&EiEl6DJg0}dwYBTCntAzcMY&nC{$ozpp})C za_sT(@y5nR2!gu1yEVq%D9OAhDtfh_pPwg_$%@`C*=#l*j~^Qw`|Eq?*|TTk;^Jar zVn#<tVHjqySaET2(g|cTxu~c}I#`dCV^gWr&!0bk`t(Vasd{^R^YZeLSRQ)|wZ;-& zxpJkyzaNjsBf-kb3ev@7GAk=9wOD&*W+pv7T{1tH%kAsyJ9OyKty{N{VEs!7E5#NH zg(8ti-3eu|w_GR~hE>00*=)9<p`n?XnO1H9Jv}`h9v-^7Dm{<aqkj}zMX9%hJKBa) zX*;u{?W~<8{O5(v$;nYMwW_Mh$Hyl!GE!y>t`$9h{`}y<gV(QL2LLGXEVV0*9m;J* ztHxDGp-?vM8BQjXBO@cxXfzU-n3!xt6>o3v`1trEM~>Lr+arNyJA<vIRqsZsqx1iH z<JF==xe1b?{bNZgD=W>-%}Yv3CMG5V0|R}1eIW<}03;_T7Zw&GIbB^{;o;#H78W%% zHAqWybMu)qX9xtsg9i@)05lry`0?Y_)zvs0?$V`8GQB&}y8gH^QYe({>}(Sg6FWP* z)YQ~#*RHv_xd8yIt*sLi6Oo*up`ll=UKJJ=-n@B}OeX*Q`LnjRwz#<X*RNl8c6PzR z!G3;zt*x!@?(U_fr9(qQGQG%z8cTJzZ~ddzug#(T<0{nA(TR_br_pEt04FCW2!eWg zdc<O}SS;SXdpD9378ZuVVDNbS@bEAIpt!i0$K&0&aigfH2#3Rc{P@wq!NJPPDk37n z-`}6fWXklaaRTI|$iv%+QR~;H(aLU5;^X7Jy}kK-enUe8g+i&RsR<4aK6dPwOd1A* zSzTQP06-8F5fKp=7Y6{y&dx@9b#!zPk7mtYi5eRlZEbCluLZ<nv2xHgJ-nr*rOwVy zEEa2HW25>gKA+#x(h?95U}0hL*At{g+P=QN!NEZyk%*XIDvm<b)zyXgl=70@p6uJV z&&S87tgOt~*f=F6<;9B^ZEbBqK|zXGJv}|YeEA|dWV6|-_ZAcsR8&+T@xsD_a{Eo% z!^_LdLw4<m&y08us*jS`yh_T+Yn`+buUmRyRG|d`)Ya8VO3Q1F9p>rNr?axM5)u;d zcsv@7Mx)Wl&Ig8Jkw}DGe5<RgNDvwtT3TBA`t@rVh9L;*=;)ASD(aQU)zy{3U`$U> z_xJZ#R8)9*c_}$55)Ti9!9WnSva*7-OMK>;nHf5rE^~dXIf_oFXJlmL<>e_UCqLUd zX-!N_h(w~Rt1DuZs!l6oHOp&_C5()WB$LT|_wEG%BqStAzDcRBt`-V~RaI5<^Yhi! z)dGQ_wzl^0;lm^n>C~xHo}QkMA3r9MNHsMzQ&UqVB_*Syqw>Adg)%cUjg5`%?d`Ex z?8wN7@^iYT+b8Wa*VWa9hle8@0p+8Tl9G&!j94s|l5+C1t)Euf>sFEW<;$10wzi#} zoyvYOYx)-gfj}luuG!hy<>h6~dPhb^dV71NO&>*`rC2QHa=FrD^YioD+uJ3FbUMAe zyIW>{`B5+o7ZemME-oUmB8PI#*)*mV3Wd*}J%goAsVcO0?%bhLslL9x3<g6H?b@&E zk`G3tKaEi$Gcz+K4<zNij*gBV9v(9PG-z*c9~c;bVHgPn0s#O3g+iH|n@e&gCMN3Z z>m3~(k;9pp86J-(|7(>Qm7AN}(b3`S>uY3WG&?&BLC}vMKlpq;5=hb%&89JJMn*<+ zb2EiPLH3y{(w;wmo<t%=MMZ^#geaojj%HI|U*E#Q0ssJm!64sf;BYuYLqn|>VzF2g s6BE*foSdAjt*!qp+U>Z6J5o#k1BK@(KT?IV<NyEw07*qoM6N<$g7<ZOlmGw# literal 0 HcmV?d00001 From bb73a9b8aef146ef7a9963759de7b90b3b00e4d1 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt <samth@racket-lang.org> Date: Thu, 8 Sep 2011 12:31:00 -0400 Subject: [PATCH 223/235] Make the back button work. --- collects/meta/drdr/static/chart.js | 54 +++++++++++++++++++++++------- 1 file changed, 42 insertions(+), 12 deletions(-) diff --git a/collects/meta/drdr/static/chart.js b/collects/meta/drdr/static/chart.js index 07a130c62e..f3e12e279a 100644 --- a/collects/meta/drdr/static/chart.js +++ b/collects/meta/drdr/static/chart.js @@ -19,19 +19,18 @@ var options = { selection: { mode: "xy" }, } var v = '<div '+css+' onclick="legend_click(\''+label+'\')">' + label + '</div>'; return v;}}, - xaxes: [{label: 'push'}], - yaxes: [{}, {position: "right"}], + xaxes: [{min: null, max: null, label: 'push'}], + yaxes: [{min: null, max: null, label: "time"}, + {position: "right"}], grid: { clickable: true, hoverable : true } }; function legend_click(l) { - console.log(show_hide[l]); show_hide[l] = !show_hide[l]; show(); } var placeholder = $("#_chart"); -var cur_options = options; var previousPoint = null; function showTooltip(x, y, contents) { @@ -94,8 +93,7 @@ function click(e,pos,item) { makeTooltip(item,path); } } -placeholder.bind("plothover", hover); -placeholder.bind("plotclick", click); + function load_data(d) { chart_data = []; @@ -135,15 +133,13 @@ function load_data(d) { for(var i = 0; i < sub_times.length; i++) { chart_data.push({data: sub_times[i], label: "Timer "+ (i+1), points: { show: true }, yaxis: ya}); } - options.legend.noColumns = Math.max(1,Math.round(chart_data.length / 10)); + cur_options.legend.noColumns = Math.max(1,Math.round(chart_data.length / 10)); } function get_data(_path) { if (_path[0] != '/') _path = '/' + _path; path = _path; - console.log("_path",_path); - console.log("path",path); $.ajax({url: 'http://drdr.racket-lang.org/json/timing'+path, beforeSend: function(xhr) { xhr.overrideMimeType( 'text/plain; charset=x-user-defined' ); @@ -164,15 +160,29 @@ function show() { chart_data[i].saved = null; } } - //console.log(chart_data); $.plot(placeholder, chart_data, cur_options); } +function serialize_zoom(options) { + var o = {}; + if (options.xaxes[0].min) + o.xmin = options.xaxes[0].min; + if (options.xaxes[0].max) + o.xmax = options.xaxes[0].max; + if (options.yaxes[0].min) + o.ymin = options.yaxes[0].min; + if (options.yaxes[0].max) + o.ymax = options.yaxes[0].max; + window.location.hash = "#" + (JSON.stringify(o)); +} + function handle_selection(event, ranges) { cur_options = $.extend(true, {}, cur_options, { yaxes: [ { min: ranges.yaxis.from, max: ranges.yaxis.to },cur_options.yaxes[1]], - xaxis: { min: ranges.xaxis.from, max: ranges.xaxis.to }}); + xaxes: [ { min: ranges.xaxis.from, max: ranges.xaxis.to } ]}); + serialize_zoom(cur_options); show(); + } function set_legend(new_val) { @@ -184,4 +194,24 @@ function set_legend(new_val) { $("#setlegend").text("Show Legend") } -function reset_chart() { cur_options = options; show_hide = {}; show(); } +function reset_chart() { + cur_options = options; show_hide = {}; show(); +} + +placeholder.bind("plothover", hover); +placeholder.bind("plotclick", click); + +var opts = {xmin : null, ymin: null, xmax: null, ymax : null}; + +var cur_options = options; + +try { + opts = JSON.parse(window.location.hash.substring(1)); +} catch(e) {} + +if (opts) { + cur_options.xaxes[0].min = opts.xmin; + cur_options.xaxes[0].max = opts.xmax; + cur_options.yaxes[0].min = opts.ymin; + cur_options.yaxes[0].max = opts.ymax; +} From 17a1f749d166f4c8ccae562feb4ab538edf4bf22 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt <samth@racket-lang.org> Date: Thu, 8 Sep 2011 13:06:40 -0400 Subject: [PATCH 224/235] Save hidden serieses as well. --- collects/meta/drdr/static/chart.js | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/collects/meta/drdr/static/chart.js b/collects/meta/drdr/static/chart.js index f3e12e279a..951988ad11 100644 --- a/collects/meta/drdr/static/chart.js +++ b/collects/meta/drdr/static/chart.js @@ -28,6 +28,7 @@ var options = { selection: { mode: "xy" }, function legend_click(l) { show_hide[l] = !show_hide[l]; show(); + serialize_opts(options); } var placeholder = $("#_chart"); @@ -100,7 +101,6 @@ function load_data(d) { overall_times = []; sub_times = []; pdata = [] - reset_chart(); data = d; pdata = data && JSON.parse(data); @@ -163,7 +163,7 @@ function show() { $.plot(placeholder, chart_data, cur_options); } -function serialize_zoom(options) { +function serialize_opts(options) { var o = {}; if (options.xaxes[0].min) o.xmin = options.xaxes[0].min; @@ -173,14 +173,14 @@ function serialize_zoom(options) { o.ymin = options.yaxes[0].min; if (options.yaxes[0].max) o.ymax = options.yaxes[0].max; - window.location.hash = "#" + (JSON.stringify(o)); + window.location.hash = "#" + (JSON.stringify([o,show_hide])); } function handle_selection(event, ranges) { cur_options = $.extend(true, {}, cur_options, { yaxes: [ { min: ranges.yaxis.from, max: ranges.yaxis.to },cur_options.yaxes[1]], xaxes: [ { min: ranges.xaxis.from, max: ranges.xaxis.to } ]}); - serialize_zoom(cur_options); + serialize_opts(cur_options); show(); } @@ -210,8 +210,12 @@ try { } catch(e) {} if (opts) { - cur_options.xaxes[0].min = opts.xmin; - cur_options.xaxes[0].max = opts.xmax; - cur_options.yaxes[0].min = opts.ymin; - cur_options.yaxes[0].max = opts.ymax; + cur_options.xaxes[0].min = opts[0].xmin; + cur_options.xaxes[0].max = opts[0].xmax; + cur_options.yaxes[0].min = opts[0].ymin; + cur_options.yaxes[0].max = opts[0].ymax; + for(i in opts[1]) { + console.log(i,opts[1][i]); + show_hide[i] = opts[1][i]; + } } From f61b9efea4856419c89e58d48434224f6db80f9f Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt <samth@racket-lang.org> Date: Thu, 8 Sep 2011 14:13:16 -0400 Subject: [PATCH 225/235] Color fixes, show lines for dense data. --- collects/meta/drdr/static/chart.js | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/collects/meta/drdr/static/chart.js b/collects/meta/drdr/static/chart.js index 951988ad11..3235c208fa 100644 --- a/collects/meta/drdr/static/chart.js +++ b/collects/meta/drdr/static/chart.js @@ -102,7 +102,7 @@ function load_data(d) { sub_times = []; pdata = [] data = d; - + reset_chart(); pdata = data && JSON.parse(data); var max_overall = 0; @@ -129,9 +129,13 @@ function load_data(d) { ya = 2; // put the data into the chart format - chart_data.push({data: overall_times, label: "Overall Time"}); + chart_data.push({data: overall_times, label: "Overall Time", color: "#804040"}); for(var i = 0; i < sub_times.length; i++) { - chart_data.push({data: sub_times[i], label: "Timer "+ (i+1), points: { show: true }, yaxis: ya}); + var n = (sub_times[i].length/overall_times.length); + chart_data.push({data: sub_times[i], label: "Timer "+ (i+1), + lines: { show: (.9<n) }, + points: { show: !(.9<n) }, + yaxis: ya}); } cur_options.legend.noColumns = Math.max(1,Math.round(chart_data.length / 10)); } @@ -209,7 +213,7 @@ try { opts = JSON.parse(window.location.hash.substring(1)); } catch(e) {} -if (opts) { +if (opts && opts.length == 2) { cur_options.xaxes[0].min = opts[0].xmin; cur_options.xaxes[0].max = opts[0].xmax; cur_options.yaxes[0].min = opts[0].ymin; From 2f9f780727095870fda967d295965f4ac14ce909 Mon Sep 17 00:00:00 2001 From: Robby Findler <robby@racket-lang.org> Date: Thu, 8 Sep 2011 14:41:53 -0500 Subject: [PATCH 226/235] add tooltips for the module level imports in check syntax this also gets rid of the module-level imports as annotations in the bar along the buttom of a drracket window, which eliminates the use of the 'drracket:check-syntax:mouse-over status line and thus: closes PR 12186 --- collects/drracket/private/module-language.rkt | 22 +--- collects/drracket/private/syncheck/gui.rkt | 110 ++++++++++++------ .../drracket/private/syncheck/online-comp.rkt | 2 +- collects/drracket/private/tooltip.rkt | 87 ++++++++++++++ 4 files changed, 169 insertions(+), 52 deletions(-) create mode 100644 collects/drracket/private/tooltip.rkt diff --git a/collects/drracket/private/module-language.rkt b/collects/drracket/private/module-language.rkt index e1ceed4e85..3eb7812097 100644 --- a/collects/drracket/private/module-language.rkt +++ b/collects/drracket/private/module-language.rkt @@ -18,6 +18,7 @@ planet/config setup/dirs racket/place + "tooltip.rkt" "drsig.rkt" "rep.rkt" "eval-helpers.rkt" @@ -909,24 +910,11 @@ (cond [tooltip-labels (unless tooltip-frame - (set! tooltip-frame - (new (class frame% - (define/override (on-subwindow-event r evt) - (cond - [(send evt button-down?) - (hide-tooltip) - #t] - [else #f])) - (super-new [style '(no-resize-border no-caption float)] - [label ""] - [stretchable-width #f] - [stretchable-height #f] )))) - (new yellow-message% [parent tooltip-frame])) - (send (car (send tooltip-frame get-children)) set-lab tooltip-labels) - (send tooltip-frame reflow-container) + (set! tooltip-frame (new tooltip-frame%))) + (send tooltip-frame set-tooltip tooltip-labels) (define-values (rx ry) (send running-canvas client->screen 0 0)) - (send tooltip-frame move (- rx (send tooltip-frame get-width)) (- ry (send tooltip-frame get-height))) - (send tooltip-frame show #t)] + (define-values (cw ch) (send running-canvas get-client-size)) + (send tooltip-frame show-over rx ry cw ch #:prefer-upper-left? #t)] [else (when tooltip-frame (send tooltip-frame show #f))])) diff --git a/collects/drracket/private/syncheck/gui.rkt b/collects/drracket/private/syncheck/gui.rkt index 28ba64e1af..713156a3a1 100644 --- a/collects/drracket/private/syncheck/gui.rkt +++ b/collects/drracket/private/syncheck/gui.rkt @@ -50,7 +50,8 @@ If the namespace does not, they are colored the unbound color. "intf.rkt" "colors.rkt" "traversals.rkt" - "annotate.rkt") + "annotate.rkt" + "../tooltip.rkt") (provide tool@) (define orig-output-port (current-output-port)) @@ -198,6 +199,8 @@ If the namespace does not, they are colored the unbound color. #:transparent) (define-struct (tail-arrow arrow) (from-text from-pos to-text to-pos) #:transparent) + (define-struct tooltip-info (text pos-left pos-right msg) #:transparent) + ;; color : string ;; text: text:basic<%> ;; start, fin: number @@ -470,10 +473,7 @@ If the namespace does not, they are colored the unbound color. (set! arrow-records (make-hasheq)) (set! bindings-table (make-hash)) (set! cleanup-texts '()) - (set! style-mapping (make-hash)) - (let ([f (get-top-level-window)]) - (when f - (send f open-status-line 'drracket:check-syntax:mouse-over)))) + (set! style-mapping (make-hash))) (define/public (syncheck:arrows-visible?) (or arrow-records cursor-location cursor-text)) @@ -493,9 +493,7 @@ If the namespace does not, they are colored the unbound color. (set! style-mapping #f) (invalidate-bitmap-cache) (update-docs-background #f) - (let ([f (get-top-level-window)]) - (when f - (send f close-status-line 'drracket:check-syntax:mouse-over))))) + (clear-tooltips))) ;; syncheck:apply-style/remember : (is-a?/c text%) number number style% symbol -> void (define/public (syncheck:apply-style/remember txt start finish style mode) @@ -705,9 +703,10 @@ If the namespace does not, they are colored the unbound color. ;; syncheck:add-mouse-over-status : text pos-left pos-right string -> void (define/public (syncheck:add-mouse-over-status text pos-left pos-right str) - (let ([str (gui-utils:format-literal-label "~a" str)]) - (when arrow-records - (add-to-range/key text pos-left pos-right str #f #f)))) + (when arrow-records + (add-to-range/key text pos-left pos-right + (make-tooltip-info text pos-left pos-right str) + #f #f))) ;; add-to-range/key : text number number any any boolean -> void ;; adds `key' to the range `start' - `end' in the editor @@ -897,9 +896,6 @@ If the namespace does not, they are colored the unbound color. (set! cursor-location #f) (set! cursor-text #f) (set! cursor-eles #f) - (let ([f (get-top-level-window)]) - (when f - (send f update-status-line 'drracket:check-syntax:mouse-over #f))) (invalidate-bitmap-cache)) (super on-event event)] [(or (send event moving?) @@ -938,20 +934,18 @@ If the namespace does not, they are colored the unbound color. (set! cursor-eles eles) (update-docs-background eles) (when eles - (update-status-line eles) + (update-tooltips eles) (for ([ele (in-list eles)]) (cond [(arrow? ele) (update-arrow-poss ele)])) (invalidate-bitmap-cache)))))] [else (update-docs-background #f) - (let ([f (get-top-level-window)]) - (when f - (send f update-status-line 'drracket:check-syntax:mouse-over #f))) (when (or cursor-location cursor-text) (set! cursor-location #f) (set! cursor-text #f) (set! cursor-eles #f) + (clear-tooltips) (invalidate-bitmap-cache))]))) (define/public (syncheck:build-popup-menu pos text) @@ -1036,22 +1030,70 @@ If the namespace does not, they are colored the unbound color. menu)])))))) - (define/private (update-status-line eles) - (let ([has-txt? #f]) - (for-each (λ (ele) - (cond - [(string? ele) - (set! has-txt? #t) - (let ([f (get-top-level-window)]) - (when f - (send f update-status-line - 'drracket:check-syntax:mouse-over - ele)))])) - eles) - (unless has-txt? - (let ([f (get-top-level-window)]) - (when f - (send f update-status-line 'drracket:check-syntax:mouse-over #f)))))) + (define tooltip-frame #f) + (define/private (update-tooltips eles) + (unless tooltip-frame (set! tooltip-frame (new tooltip-frame%))) + (define tooltip-infos (filter tooltip-info? eles)) + (cond + [(null? tooltip-infos) + (send tooltip-frame show #f)] + [else + (send tooltip-frame set-tooltip (map tooltip-info-msg tooltip-infos)) + (let loop ([tooltip-infos tooltip-infos] + [l #f] + [t #f] + [r #f] + [b #f]) + (cond + [(null? tooltip-infos) + (if (and l t r b) + (send tooltip-frame show-over l t (- r l) (- b t)) + (send tooltip-frame show #f))] + [else + (define-values (tl tt tr tb) (tooltip-info->ltrb (car tooltip-infos))) + (define (min/f x y) (cond [(and x y) (min x y)] [x x] [y y] [else #f])) + (define (max/f x y) (cond [(and x y) (max x y)] [x x] [y y] [else #f])) + (loop (cdr tooltip-infos) + (min/f tl l) + (min/f tt t) + (max/f tr r) + (max/f tb b))]))])) + + (define/private (clear-tooltips) + (when tooltip-frame (send tooltip-frame show #f))) + + (define/private (tooltip-info->ltrb tooltip) + (define xlb (box 0)) + (define ylb (box 0)) + (define xrb (box 0)) + (define yrb (box 0)) + (define left-pos (tooltip-info-pos-left tooltip)) + (define right-pos (tooltip-info-pos-right tooltip)) + (define text (tooltip-info-text tooltip)) + (send text position-location left-pos xlb ylb #t) + (send text position-location right-pos xrb yrb #f) + (define-values (xl-off yl-off) (send text editor-location-to-dc-location (unbox xlb) (unbox ylb))) + (define-values (xr-off yr-off) (send text editor-location-to-dc-location (unbox xrb) (unbox yrb))) + (define window + (let loop ([ed text]) + (cond + [(send ed get-canvas) => values] + [else + (define admin (send ed get-admin)) + (if (is-a? admin editor-snip-editor-admin<%>) + (loop (send (send admin get-snip) get-editor)) + #f)]))) + (cond + [window + (define (c n) (inexact->exact (round n))) + (define-values (glx gly) (send window client->screen (c xl-off) (c yl-off))) + (define-values (grx gry) (send window client->screen (c xr-off) (c yr-off))) + (values (min glx grx) + (min gly gry) + (max glx grx) + (max gly gry))] + [else + (values #f #f #f #f)])) (define current-colored-region #f) ;; update-docs-background : (or/c false/c (listof any)) -> void diff --git a/collects/drracket/private/syncheck/online-comp.rkt b/collects/drracket/private/syncheck/online-comp.rkt index a4733f5cc5..a30cfe8a68 100644 --- a/collects/drracket/private/syncheck/online-comp.rkt +++ b/collects/drracket/private/syncheck/online-comp.rkt @@ -31,7 +31,7 @@ (set! trace (cons (cons 'name args) trace)))) ; (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) ;; we don't log these as they require space in the window + (log syncheck:add-mouse-over-status) (log syncheck:add-arrow) (log syncheck:add-tail-arrow) (log syncheck:add-background-color) diff --git a/collects/drracket/private/tooltip.rkt b/collects/drracket/private/tooltip.rkt new file mode 100644 index 0000000000..57196182f1 --- /dev/null +++ b/collects/drracket/private/tooltip.rkt @@ -0,0 +1,87 @@ +#lang racket/base +(require racket/gui/base + racket/class) + +(provide tooltip-frame%) + +(define tooltip-frame% + (class frame% + (inherit show reflow-container move get-width get-height) + (define/override (on-subwindow-event r evt) + (cond + [(send evt button-down?) + (show #f) + #t] + [else #f])) + (define/public (set-tooltip ls) + (send yellow-message set-lab ls)) + + (define/public (show-over x y w h #:prefer-upper-left? [prefer-upper-left? #f]) + (reflow-container) + (define mw (get-width)) + (define mh (get-height)) + (define (upper-left must?) + (define the-x (- x mw)) + (define the-y (- y mh)) + (if must? + (move the-x the-y) + (try-moving-to the-x the-y mw mh))) + (define (lower-right must?) + (define the-x (+ x w)) + (define the-y (+ y h)) + (if must? + (move the-x the-y) + (try-moving-to the-x the-y mw mh))) + (if prefer-upper-left? + (or (upper-left #t) (lower-right #f) (upper-left #t)) + (or (lower-right #t) (upper-left #f) (lower-right #t))) + (show #t)) + + (define/private (try-moving-to x y w h) + (and (for/or ([m (in-range 0 (get-display-count))]) + (define-values (mx my) (get-display-left-top-inset #:monitor m)) + (define-values (mw mh) (get-display-size #:monitor m)) + (and (<= (- mx) x (+ x w) (+ (- mx) mw)) + (<= (- my) y (+ y h) (+ (- my) mh)))) + (begin (move x y) + #t))) + + (super-new [style '(no-resize-border no-caption float)] + [label ""] + [stretchable-width #f] + [stretchable-height #f]) + (define yellow-message (new yellow-message% [parent this])))) + +(define yellow-message% + (class canvas% + (inherit get-dc refresh get-client-size + min-width min-height + get-parent) + (define labels '("")) + (define/public (set-lab _ls) + (unless (equal? labels _ls) + (set! labels _ls) + (update-size) + (refresh))) + (define/private (update-size) + (define dc (get-dc)) + (send dc set-font small-control-font) + (define-values (w h _1 _2) (send dc get-text-extent (car labels))) + (send (get-parent) begin-container-sequence) + (min-width (+ 5 (inexact->exact (ceiling w)))) + (min-height (+ 5 (* (length labels) (inexact->exact (ceiling h))))) + (send (get-parent) end-container-sequence) + (send (get-parent) reflow-container)) + (define/override (on-paint) + (define dc (get-dc)) + (send dc set-font small-control-font) + (define-values (w h) (get-client-size)) + (define-values (tw th _1 _2) (send dc get-text-extent (car labels))) + (send dc set-pen "black" 1 'transparent) + (send dc set-brush "LemonChiffon" 'solid) + (send dc set-pen "black" 1 'solid) + (send dc draw-rectangle 0 0 w h) + (for ([label (in-list labels)] + [i (in-naturals)]) + (send dc draw-text label 2 (+ 2 (* i th))))) + (super-new [stretchable-width #f] [stretchable-height #f]))) From d3c56c9f13327d07513f8b6bf7ea0230acb7f489 Mon Sep 17 00:00:00 2001 From: Matthew Flatt <mflatt@racket-lang.org> Date: Mon, 5 Sep 2011 16:08:16 -0600 Subject: [PATCH 227/235] generalized `begin-for-syntax' --- collects/compiler/decompile.rkt | 25 +- .../compiler/demodularizer/gc-toplevels.rkt | 4 +- collects/compiler/demodularizer/merge.rkt | 3 +- collects/compiler/demodularizer/nodep.rkt | 5 +- .../demodularizer/update-toplevels.rkt | 2 +- collects/compiler/zo-marshal.rkt | 103 +- collects/compiler/zo-parse.rkt | 159 +- collects/compiler/zo-structs.rkt | 27 +- .../deinprogramm/signature/module-begin.rkt | 4 +- .../private/syncheck/contract-traversal.rkt | 2 +- collects/errortrace/stacktrace.rkt | 18 +- collects/gui-debugger/annotator.rkt | 5 +- collects/lang/private/teach-module-begin.rkt | 4 +- collects/macro-debugger/model/trace.rkt | 2 +- collects/mzlib/include.rkt | 5 +- collects/r6rs/main.rkt | 7 +- collects/racket/private/define.rkt | 79 +- collects/racket/private/modbeg.rkt | 4 +- collects/racket/private/old-rp.rkt | 45 +- collects/racket/private/reqprov.rkt | 76 +- collects/racket/private/stxcase-scheme.rkt | 21 +- collects/scribble/doclang.rkt | 2 +- collects/scribble/private/lp.rkt | 1 - collects/scribble/text/syntax-utils.rkt | 2 +- collects/scribblings/guide/proc-macros.scrbl | 22 +- collects/scribblings/raco/zo-struct.scrbl | 62 +- .../scribblings/reference/eval-model.scrbl | 21 +- .../scribblings/reference/stx-trans.scrbl | 30 +- .../scribblings/reference/syntax-model.scrbl | 68 +- collects/scribblings/reference/syntax.scrbl | 90 +- collects/syntax/kerncase.rkt | 4 +- collects/tests/compiler/zo.rkt | 40 + collects/tests/racket/module.rktl | 34 + collects/typed-racket/base-env/base-env.rkt | 2 +- .../typed-racket/typecheck/tc-toplevel.rkt | 2 +- doc/release-notes/racket/HISTORY.txt | 11 + src/racket/include/schthread.h | 4 +- src/racket/src/compenv.c | 2 +- src/racket/src/compile.c | 146 +- src/racket/src/cstartup.inc | 315 +-- src/racket/src/env.c | 42 +- src/racket/src/eval.c | 49 +- src/racket/src/fun.c | 27 +- src/racket/src/jit.c | 2 +- src/racket/src/jitprep.c | 29 +- src/racket/src/marshal.c | 347 ++- src/racket/src/module.c | 2436 ++++++++++------- src/racket/src/mzmark_type.inc | 67 +- src/racket/src/mzmarksrc.c | 30 +- src/racket/src/optimize.c | 51 +- src/racket/src/resolve.c | 61 +- src/racket/src/schpriv.h | 43 +- src/racket/src/schvers.h | 4 +- src/racket/src/sfs.c | 54 +- src/racket/src/startup.inc | 4 +- src/racket/src/startup.rktl | 4 +- src/racket/src/stypes.h | 3 +- src/racket/src/syntax.c | 5 +- src/racket/src/type.c | 5 +- src/racket/src/validate.c | 59 +- 60 files changed, 2814 insertions(+), 1966 deletions(-) create mode 100644 collects/tests/compiler/zo.rkt diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index 903e6843ef..053ad00fb9 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -164,16 +164,20 @@ (define (decompile-module mod-form stack stx-ht) (match mod-form - [(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported + [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies unexported max-let-depth dummy lang-info internal-context)) (let-values ([(globs defns) (decompile-prefix prefix stx-ht)] [(stack) (append '(#%modvars) stack)] [(closed) (make-hasheq)]) `(module ,name .... ,@defns - ,@(map (lambda (form) - (decompile-form form globs stack closed stx-ht)) - syntax-body) + ,@(for/list ([b (in-list syntax-bodies)]) + (let loop ([n (sub1 (car b))]) + (if (zero? n) + (cons 'begin + (for/list ([form (in-list (cdr b))]) + (decompile-form form globs stack closed stx-ht))) + (list 'begin-for-syntax (loop (sub1 n)))))) ,@(map (lambda (form) (decompile-form form globs stack closed stx-ht)) body)))] @@ -190,18 +194,19 @@ (list-ref/protect (glob-desc-vars globs) pos 'def-vals)])) ids) ,(decompile-expr rhs globs stack closed))] - [(struct def-syntaxes (ids rhs prefix max-let-depth)) + [(struct def-syntaxes (ids rhs prefix max-let-depth dummy)) `(define-syntaxes ,ids ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) `(let () ,@defns ,(decompile-form rhs globs '(#%globals) closed stx-ht))))] - [(struct def-for-syntax (ids rhs prefix max-let-depth)) - `(define-values-for-syntax ,ids - ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) - `(let () + [(struct seq-for-syntax (exprs prefix max-let-depth dummy)) + `(begin-for-syntax + ,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]) + `(let () ,@defns - ,(decompile-form rhs globs '(#%globals) closed stx-ht))))] + ,@(for/list ([rhs (in-list exprs)]) + (decompile-form rhs globs '(#%globals) closed stx-ht)))))] [(struct seq (forms)) `(begin ,@(map (lambda (form) (decompile-form form globs stack closed stx-ht)) diff --git a/collects/compiler/demodularizer/gc-toplevels.rkt b/collects/compiler/demodularizer/gc-toplevels.rkt index 1118214a8e..f212b66081 100644 --- a/collects/compiler/demodularizer/gc-toplevels.rkt +++ b/collects/compiler/demodularizer/gc-toplevels.rkt @@ -64,7 +64,7 @@ (build-graph! new-lhs rhs)] [(? def-syntaxes?) (error 'build-graph "Doesn't handle syntax")] - [(? def-for-syntax?) + [(? seq-for-syntax?) (error 'build-graph "Doesn't handle syntax")] [(struct req (reqs dummy)) (build-graph! lhs dummy)] @@ -197,7 +197,7 @@ #f)] [(? def-syntaxes?) (error 'gc-tls "Doesn't handle syntax")] - [(? def-for-syntax?) + [(? seq-for-syntax?) (error 'gc-tls "Doesn't handle syntax")] [(struct req (reqs dummy)) (make-req reqs (update dummy))] diff --git a/collects/compiler/demodularizer/merge.rkt b/collects/compiler/demodularizer/merge.rkt index 5c63e6d22b..6e57f5962c 100644 --- a/collects/compiler/demodularizer/merge.rkt +++ b/collects/compiler/demodularizer/merge.rkt @@ -108,7 +108,8 @@ (define (merge-module max-let-depth top-prefix mod-form) (match mod-form - [(struct mod (name srcname self-modidx mod-prefix provides requires body syntax-body unexported mod-max-let-depth dummy lang-info internal-context)) + [(struct mod (name srcname self-modidx mod-prefix provides requires body syntax-bodies + unexported mod-max-let-depth dummy lang-info internal-context)) (define toplevel-offset (length (prefix-toplevels top-prefix))) (define topsyntax-offset (length (prefix-stxs top-prefix))) (define lift-offset (prefix-num-lifts top-prefix)) diff --git a/collects/compiler/demodularizer/nodep.rkt b/collects/compiler/demodularizer/nodep.rkt index b9d7a8eb79..c37f82ceea 100644 --- a/collects/compiler/demodularizer/nodep.rkt +++ b/collects/compiler/demodularizer/nodep.rkt @@ -112,7 +112,8 @@ (define (nodep-module mod-form phase) (match mod-form - [(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported max-let-depth dummy lang-info internal-context)) + [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies + unexported max-let-depth dummy lang-info internal-context)) (define new-prefix prefix) ; Cache all the mpi paths (for-each (match-lambda @@ -127,7 +128,7 @@ (append (requires->modlist requires phase) (if (and phase (zero? phase)) (begin (log-debug (format "[~S] lang-info : ~S" name lang-info)) ; XXX Seems to always be #f now - (list (make-mod name srcname self-modidx new-prefix provides requires body empty + (list (make-mod name srcname self-modidx new-prefix provides requires body syntax-bodies empty unexported max-let-depth dummy lang-info internal-context))) (begin (log-debug (format "[~S] Dropping module @ ~S" name phase)) empty))))] diff --git a/collects/compiler/demodularizer/update-toplevels.rkt b/collects/compiler/demodularizer/update-toplevels.rkt index 90a7b8f2c2..15584bb5d3 100644 --- a/collects/compiler/demodularizer/update-toplevels.rkt +++ b/collects/compiler/demodularizer/update-toplevels.rkt @@ -10,7 +10,7 @@ (update rhs))] [(? def-syntaxes?) (error 'increment "Doesn't handle syntax")] - [(? def-for-syntax?) + [(? seq-for-syntax?) (error 'increment "Doesn't handle syntax")] [(struct req (reqs dummy)) (make-req reqs (update dummy))] diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index e435a97080..22f5d5b95e 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -158,7 +158,7 @@ (define quote-syntax-type-num 14) (define define-values-type-num 15) (define define-syntaxes-type-num 16) -(define define-for-syntax-type-num 17) +(define begin-for-syntax-type-num 17) (define set-bang-type-num 18) (define boxenv-type-num 19) (define begin0-sequence-type-num 20) @@ -256,8 +256,6 @@ (define BITS_PER_MZSHORT 32) -(define *dummy* #f) - (define (int->bytes x) (integer->integer-bytes x 4 @@ -522,21 +520,20 @@ (out-marshaled define-values-type-num (list->vector (cons (protect-quote rhs) ids)) out)] - [(struct def-syntaxes (ids rhs prefix max-let-depth)) + [(struct def-syntaxes (ids rhs prefix max-let-depth dummy)) (out-marshaled define-syntaxes-type-num (list->vector (list* (protect-quote rhs) prefix max-let-depth - *dummy* + dummy ids)) out)] - [(struct def-for-syntax (ids rhs prefix max-let-depth)) - (out-marshaled define-for-syntax-type-num - (list->vector (list* (protect-quote rhs) - prefix - max-let-depth - *dummy* - ids)) + [(struct seq-for-syntax (rhs prefix max-let-depth dummy)) + (out-marshaled begin-for-syntax-type-num + (vector (map protect-quote rhs) + prefix + max-let-depth + dummy) out)] [(struct beg0 (forms)) (out-marshaled begin0-sequence-type-num (map protect-quote forms) out)] @@ -825,7 +822,7 @@ (define (out-module mod-form out) (match mod-form - [(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported + [(struct mod (name srcname self-modidx prefix provides requires body syntax-bodies unexported max-let-depth dummy lang-info internal-context)) (let* ([lookup-req (lambda (phase) (let ([a (assq phase requires)]) @@ -844,6 +841,11 @@ (if (ormap values p) (list->vector p) #f)))))] + [extract-unexported + (lambda (phase) + (let ([a (assq phase unexported)]) + (and a + (cdr a))))] [list->vector/#f (lambda (default l) (if (andmap (lambda (x) (equal? x default)) l) #f @@ -861,45 +863,54 @@ [l (cons (lookup-req 1) l)] ; et-requires [l (cons (lookup-req 0) l)] ; requires [l (cons (list->vector body) l)] - [l (cons (list->vector - (for/list ([i (in-list syntax-body)]) - (define (maybe-one l) ;; a single symbol is ok - (if (and (pair? l) (null? (cdr l))) - (car l) - l)) - (match i - [(struct def-syntaxes (ids rhs prefix max-let-depth)) - (vector (maybe-one ids) rhs max-let-depth prefix #f)] - [(struct def-for-syntax (ids rhs prefix max-let-depth)) - (vector (maybe-one ids) rhs max-let-depth prefix #t)]))) - l)] + [l (append (reverse + (for/list ([b (in-list syntax-bodies)]) + (for/vector ([i (in-list (cdr b))]) + (define (maybe-one l) ;; a single symbol is ok + (if (and (pair? l) (null? (cdr l))) + (car l) + l)) + (match i + [(struct def-syntaxes (ids rhs prefix max-let-depth dummy)) + (vector (maybe-one ids) rhs max-let-depth prefix #f)] + [(struct seq-for-syntax ((list rhs) prefix max-let-depth dummy)) + (vector #f rhs max-let-depth prefix #t)])))) + l)] [l (append (apply append (map (lambda (l) - (let ([phase (car l)] - [all (append (cadr l) (caddr l))]) - (list phase - (list->vector/#f 0 (map (lambda (p) (= 1 (provided-src-phase p))) - all)) - (list->vector/#f #f (map (lambda (p) - (if (eq? (provided-nom-src p) - (provided-src p)) - #f ; #f means "same as src" - (provided-nom-src p))) - all)) - (list->vector (map provided-src-name all)) - (list->vector (map provided-src all)) - (list->vector (map provided-name all)) - (length (cadr l)) - (length all)))) + (let* ([phase (car l)] + [all (append (cadr l) (caddr l))] + [protects (extract-protects phase)] + [unexported (extract-unexported phase)]) + (append + (list phase) + (if (and (not protects) + (not unexported)) + (list (void)) + (let ([unexported (or unexported + '(() ()))]) + (list (list->vector (cadr unexported)) + (length (cadr unexported)) + (list->vector (car unexported)) + (length (car unexported)) + protects))) + (list (list->vector/#f 0 (map provided-src-phase all)) + (list->vector/#f #f (map (lambda (p) + (if (eq? (provided-nom-src p) + (provided-src p)) + #f ; #f means "same as src" + (provided-nom-src p))) + all)) + (list->vector (map provided-src-name all)) + (list->vector (map provided-src all)) + (list->vector (map provided-name all)) + (length (cadr l)) + (length all))))) provides)) l)] [l (cons (length provides) l)] ; number of provide sets - [l (cons (extract-protects 0) l)] ; protects - [l (cons (extract-protects 1) l)] ; et protects - [l (list* (list->vector (car unexported)) (length (car unexported)) l)] ; indirect-provides - [l (list* (list->vector (cadr unexported)) (length (cadr unexported)) l)] ; indirect-syntax-provides - [l (list* (list->vector (caddr unexported)) (length (caddr unexported)) l)] ; indirect-et-provides + [l (cons (add1 (length syntax-bodies)) l)] [l (cons prefix l)] [l (cons dummy l)] [l (cons max-let-depth l)] diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 3c559ec62b..468c27fe21 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -181,19 +181,19 @@ (cdr (vector->list v)) (vector-ref v 0))) -; XXX Allocates unnessary list -(define (read-define-syntaxes mk v) - (mk (list-tail (vector->list v) 4) - (vector-ref v 0) - (vector-ref v 1) - (vector-ref v 2) - #;(vector-ref v 3))) - (define (read-define-syntax v) - (read-define-syntaxes make-def-syntaxes v)) + (make-def-syntaxes (list-tail (vector->list v) 4) + (vector-ref v 0) + (vector-ref v 1) + (vector-ref v 2) + (vector-ref v 3))) -(define (read-define-for-syntax v) - (read-define-syntaxes make-def-for-syntax v)) +(define (read-begin-for-syntax v) + (make-seq-for-syntax + (vector-ref v 0) + (vector-ref v 1) + (vector-ref v 2) + (vector-ref v 3))) (define (read-set! v) (make-assign (cadr v) (cddr v) (car v))) @@ -225,50 +225,65 @@ (lambda _ #t) (lambda _ #t))))) +(define (split-phase-data rest n) + (let loop ([n n] [rest rest] [phase-accum null]) + (cond + [(zero? n) + (values (reverse phase-accum) rest)] + [else + (let ([maybe-indirect (list-ref rest 1)]) + (if (void? maybe-indirect) + ;; no indirect or protect info: + (loop (sub1 n) + (list-tail rest 9) + (cons (take rest 9) phase-accum)) + ;; has indirect or protect info: + (loop (sub1 n) + (list-tail rest (+ 5 8)) + (cons (take rest (+ 5 8)) phase-accum))))]))) + (define (read-module v) (match v [`(,name ,srcname ,self-modidx ,lang-info ,functional? ,et-functional? ,rename ,max-let-depth ,dummy - ,prefix - ,indirect-et-provides ,num-indirect-et-provides - ,indirect-syntax-provides ,num-indirect-syntax-provides - ,indirect-provides ,num-indirect-provides - ,protects ,et-protects + ,prefix ,num-phases ,provide-phase-count . ,rest) - (let ([phase-data (take rest (* 8 provide-phase-count))]) - (match (list-tail rest (* 8 provide-phase-count)) - [`(,syntax-body ,body - ,requires ,syntax-requires ,template-requires ,label-requires - ,more-requires-count . ,more-requires) + (let*-values ([(phase-data rest-module) (split-phase-data rest provide-phase-count)] + [(bodies rest-module) (values (take rest-module num-phases) + (drop rest-module num-phases))]) + (match rest-module + [`(,requires ,syntax-requires ,template-requires ,label-requires + ,more-requires-count . ,more-requires) (make-mod name srcname self-modidx - prefix (let loop ([l phase-data]) - (if (null? l) - null - (let ([num-vars (list-ref l 6)] - [ps (for/list ([name (in-vector (list-ref l 5))] - [src (in-vector (list-ref l 4))] - [src-name (in-vector (list-ref l 3))] - [nom-src (or (list-ref l 2) - (in-cycle (in-value #f)))] - [src-phase (or (list-ref l 1) - (in-cycle (in-value #f)))] - [protected? (or (case (car l) - [(0) protects] - [(1) et-protects] - [else #f]) - (in-cycle (in-value #f)))]) - (make-provided name src src-name - (or nom-src src) - (if src-phase 1 0) - protected?))]) - (if (null? ps) - (loop (list-tail l 8)) - (cons - (list - (car l) - (take ps num-vars) - (drop ps num-vars)) - (loop (list-tail l 8))))))) + prefix + ;; provides: + (for/list ([l (in-list phase-data)]) + (let* ([phase (list-ref l 0)] + [has-info? (not (void? (list-ref l 1)))] + [delta (if has-info? 5 1)] + [num-vars (list-ref l (+ delta 6))] + [num-all (list-ref l (+ delta 7))] + [ps (for/list ([name (in-vector (list-ref l (+ delta 5)))] + [src (in-vector (list-ref l (+ delta 4)))] + [src-name (in-vector (list-ref l (+ delta 3)))] + [nom-src (or (list-ref l (+ delta 2)) + (in-cycle (in-value #f)))] + [src-phase (or (list-ref l (+ delta 1)) + (in-cycle (in-value 0)))] + [protected? (cond + [(or (not has-info?) + (not (list-ref l 5))) + (in-cycle (in-value #f))] + [else (list-ref l 5)])]) + (make-provided name src src-name + (or nom-src src) + src-phase + protected?))]) + (list + phase + (take ps num-vars) + (drop ps num-vars)))) + ;; requires: (list* (cons 0 requires) (cons 1 syntax-requires) @@ -276,20 +291,34 @@ (cons #f label-requires) (for/list ([(phase reqs) (in-list* more-requires 2)]) (cons phase reqs))) - (vector->list body) - (map (lambda (sb) - (match sb - [(? def-syntaxes?) sb] - [(? def-for-syntax?) sb] - [`#(,ids ,expr ,max-let-depth ,prefix ,for-stx?) - ((if for-stx? - make-def-for-syntax - make-def-syntaxes) - (if (list? ids) ids (list ids)) expr prefix max-let-depth)])) - (vector->list syntax-body)) - (list (vector->list indirect-provides) - (vector->list indirect-syntax-provides) - (vector->list indirect-et-provides)) + ;; body: + (vector->list (last bodies)) + ;; syntax-bodies: add phase to each list, break apart + (for/list ([b (cdr (reverse bodies))] + [i (in-naturals 1)]) + (cons i + (for/list ([sb (in-vector b)]) + (match sb + [`#(,ids ,expr ,max-let-depth ,prefix ,for-stx?) + (if for-stx? + (make-seq-for-syntax (list expr) prefix max-let-depth #f) + (make-def-syntaxes + (if (list? ids) ids (list ids)) expr prefix max-let-depth #f))] + [else (error 'zo-parse "bad phase ~a body element: ~e" i sb)])))) + ;; unexported: + (for/list ([l (in-list phase-data)] + #:when (not (void? (list-ref l 1)))) + (let* ([phase (list-ref l 0)] + [indirect-syntax + ;; could check: (list-ref l 2) should be size of vector: + (list-ref l 1)] + [indirect + ;; could check: (list-ref l 4) should be size of vector: + (list-ref l 3)]) + (list + phase + (vector->list indirect) + (vector->list indirect-syntax)))) max-let-depth dummy lang-info @@ -313,7 +342,7 @@ [(14) 'quote-syntax-type] [(15) 'define-values-type] [(16) 'define-syntaxes-type] - [(17) 'define-for-syntax-type] + [(17) 'begin-for-syntax-type] [(18) 'set-bang-type] [(19) 'boxenv-type] [(20) 'begin0-sequence-type] @@ -350,7 +379,7 @@ (cons 'free-id-info-type read-free-id-info) (cons 'define-values-type read-define-values) (cons 'define-syntaxes-type read-define-syntax) - (cons 'define-for-syntax-type read-define-for-syntax) + (cons 'begin-for-syntax-type read-begin-for-syntax) (cons 'set-bang-type read-set!) (cons 'boxenv-type read-boxenv) (cons 'require-form-type read-require) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 86c8052a15..d1ed02537d 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -80,7 +80,7 @@ [src (or/c module-path-index? #f)] [src-name symbol?] [nom-src any/c] ; should be (or/c module-path-index? #f) - [src-phase (or/c 0 1)] + [src-phase exact-nonnegative-integer?] [protected? boolean?])) (define-form-struct (toplevel expr) ([depth exact-nonnegative-integer?] @@ -89,18 +89,19 @@ [ready? boolean?])) ; access binding via prefix array (which is on stack) (define-form-struct (seq form) ([forms (listof (or/c form? any/c))])) ; `begin' +(define-form-struct (seq-for-syntax form) ([forms (listof (or/c form? any/c))] ; `begin-for-syntax' + [prefix prefix?] + [max-let-depth exact-nonnegative-integer?] + [dummy (or/c toplevel? #f)])) ;; Definitions (top level or within module): -(define-form-struct (def-values form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol? +(define-form-struct (def-values form) ([ids (listof (or/c toplevel? symbol?))] [rhs (or/c expr? seq? any/c)])) -(define-form-struct (def-syntaxes form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol? +(define-form-struct (def-syntaxes form) ([ids (listof (or/c toplevel? symbol?))] [rhs (or/c expr? seq? any/c)] [prefix prefix?] - [max-let-depth exact-nonnegative-integer?])) -(define-form-struct (def-for-syntax form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol? - [rhs (or/c expr? seq? any/c)] - [prefix prefix?] - [max-let-depth exact-nonnegative-integer?])) + [max-let-depth exact-nonnegative-integer?] + [dummy (or/c toplevel? #f)])) (define-form-struct (mod form) ([name symbol?] [srcname symbol?] @@ -111,10 +112,12 @@ (listof provided?)))] [requires (listof (cons/c (or/c exact-integer? #f) (listof module-path-index?)))] - [body (listof (or/c form? any/c))] - [syntax-body (listof (or/c def-syntaxes? def-for-syntax?))] - [unexported (list/c (listof symbol?) (listof symbol?) - (listof symbol?))] + [body (listof (or/c form? any/c))] + [syntax-bodies (listof (cons/c exact-positive-integer? + (listof (or/c def-syntaxes? seq-for-syntax?))))] + [unexported (listof (list/c exact-nonnegative-integer? + (listof symbol?) + (listof symbol?)))] [max-let-depth exact-nonnegative-integer?] [dummy toplevel?] [lang-info (or/c #f (vector/c module-path? symbol? any/c))] diff --git a/collects/deinprogramm/signature/module-begin.rkt b/collects/deinprogramm/signature/module-begin.rkt index 20c05553f8..ddcba39e81 100644 --- a/collects/deinprogramm/signature/module-begin.rkt +++ b/collects/deinprogramm/signature/module-begin.rkt @@ -174,7 +174,7 @@ ;; Lift out certain forms to make them visible to the module ;; expander: (syntax-case e2 (#%require #%provide - define-syntaxes define-values-for-syntax define-values begin + define-syntaxes begin-for-syntax define-values begin define-record-procedures define-record-procedures-2 define-record-procedures-parametric define-record-procedures-parametric-2 define-contract :) @@ -184,7 +184,7 @@ #`(begin #,e2 (frm e3s #,e1s #,def-ids))) ((define-syntaxes (id ...) . _) #`(begin #,e2 (frm e3s #,e1s (id ... . #,def-ids)))) - ((define-values-for-syntax . _) + ((begin-for-syntax . _) #`(begin #,e2 (frm e3s #,e1s #,def-ids))) ((begin b1 ...) (syntax-track-origin diff --git a/collects/drracket/private/syncheck/contract-traversal.rkt b/collects/drracket/private/syncheck/contract-traversal.rkt index 4c7e473826..095c90c71d 100644 --- a/collects/drracket/private/syncheck/contract-traversal.rkt +++ b/collects/drracket/private/syncheck/contract-traversal.rkt @@ -109,7 +109,7 @@ (call-give-up)] [(define-syntaxes (id ...) expr) (call-give-up)] - [(define-values-for-syntax (id ...) expr) + [(begin-for-syntax (id ...) expr) (call-give-up)] [(#%require rspec ...) (call-give-up)] diff --git a/collects/errortrace/stacktrace.rkt b/collects/errortrace/stacktrace.rkt index 0a616764ef..3db268756b 100644 --- a/collects/errortrace/stacktrace.rkt +++ b/collects/errortrace/stacktrace.rkt @@ -377,17 +377,15 @@ expr (rebuild disarmed-expr (list (cons #'rhs marked)))))] - [(define-values-for-syntax (name ...) rhs) + [(begin-for-syntax . exprs) top? - (let ([marked (with-mark expr - (annotate-named - (one-name (syntax (name ...))) - (syntax rhs) - (add1 phase)))]) - (rearm - expr - (rebuild disarmed-expr (list (cons #'rhs marked)))))] - + (rearm + expr + (annotate-seq disarmed-expr + (syntax exprs) + annotate-top + (add1 phase)))] + [(module name init-import mb) (syntax-case (disarm #'mb) () [(__plain-module-begin body ...) diff --git a/collects/gui-debugger/annotator.rkt b/collects/gui-debugger/annotator.rkt index cc96b2afc6..af0f87fb15 100644 --- a/collects/gui-debugger/annotator.rkt +++ b/collects/gui-debugger/annotator.rkt @@ -203,9 +203,8 @@ ] [(define-syntaxes (var ...) expr) stx] - [(define-values-for-syntax (var ...) expr) - ;; define-values-for-syntax's RHS is compile time, so treat it - ;; like define-syntaxes + [(begin-for-syntax . exprs) + ;; compile time, so treat it like define-syntaxes stx] [(begin . top-level-exprs) (quasisyntax/loc stx (begin #,@(map (lambda (expr) diff --git a/collects/lang/private/teach-module-begin.rkt b/collects/lang/private/teach-module-begin.rkt index 2741142f3e..22addf011d 100644 --- a/collects/lang/private/teach-module-begin.rkt +++ b/collects/lang/private/teach-module-begin.rkt @@ -180,7 +180,7 @@ ;; Lift out certain forms to make them visible to the module ;; expander: (syntax-case e2 (#%require #%provide - define-syntaxes define-values-for-syntax define-values begin + define-syntaxes begin-for-syntax define-values begin define-signature :) ((#%require . __) #`(begin #,e2 (frm e3s #,e1s #,def-ids))) @@ -188,7 +188,7 @@ #`(begin #,e2 (frm e3s #,e1s #,def-ids))) ((define-syntaxes (id ...) . _) #`(begin #,e2 (frm e3s #,e1s (id ... . #,def-ids)))) - ((define-values-for-syntax . _) + ((begin-for-syntax . _) #`(begin #,e2 (frm e3s #,e1s #,def-ids))) ((begin b1 ...) (syntax-track-origin diff --git a/collects/macro-debugger/model/trace.rkt b/collects/macro-debugger/model/trace.rkt index 527494b87d..db358c36a0 100644 --- a/collects/macro-debugger/model/trace.rkt +++ b/collects/macro-debugger/model/trace.rkt @@ -152,7 +152,7 @@ (eval/compile stx)] [(define-syntaxes . _) (eval/compile stx)] - [(define-values-for-syntax . _) + [(begin-for-syntax . _) (eval/compile stx)] [(define-values (id ...) . _) (with-syntax ([defvals (stx-car stx)] diff --git a/collects/mzlib/include.rkt b/collects/mzlib/include.rkt index 356f3260b1..350efea469 100644 --- a/collects/mzlib/include.rkt +++ b/collects/mzlib/include.rkt @@ -20,7 +20,10 @@ fn)) (string->path s))] [(-build-path elem ...) - (module-or-top-identifier=? #'-build-path build-path-stx) + (begin + (collect-garbage) + (module-identifier=? #'-build-path build-path-stx) + (module-or-top-identifier=? #'-build-path build-path-stx)) (let ([l (syntax-object->datum (syntax (elem ...)))]) (when (null? l) (raise-syntax-error diff --git a/collects/r6rs/main.rkt b/collects/r6rs/main.rkt index d4dd0dcb13..b5cc3f3a60 100644 --- a/collects/r6rs/main.rkt +++ b/collects/r6rs/main.rkt @@ -161,7 +161,7 @@ FIXME: (free-identifier=? id #'def))) (list #'define-values #'define-syntaxes - #'define-values-for-syntax)) + #'begin-for-syntax)) #`(begin #,a (library-body/defns . more))] [(#%require . _) ;; We allow `require' mixed with definitions, because it @@ -268,9 +268,8 @@ FIXME: (hash-set! table (syntax-e id) (cons (cons id phase) l))))))]) - (let-values ([(ids for-syntax-ids) (syntax-local-module-defined-identifiers)]) - (for-each (map-id 0) ids) - (for-each (map-id 1) for-syntax-ids)) + (for ([(phase ids) (in-hash (syntax-local-module-defined-identifiers))]) + (for-each (map-id phase) ids)) (for-each (lambda (l) (if (car l) (for-each (map-id (car l)) (cdr l)) diff --git a/collects/racket/private/define.rkt b/collects/racket/private/define.rkt index 9c955c88f3..8df9e8050d 100644 --- a/collects/racket/private/define.rkt +++ b/collects/racket/private/define.rkt @@ -7,7 +7,22 @@ "letstx-scheme.rkt" "stxcase-scheme.rkt" "stx.rkt" "qqstx.rkt" "norm-define.rkt")) - (#%provide define define-syntax define-for-syntax begin-for-syntax) + (#%provide define + define-syntax + define-values-for-syntax + define-for-syntax) + + (define-syntaxes (define-values-for-syntax) + (lambda (stx) + (syntax-case stx () + [(_ (id ...) expr) + (begin + (for-each (lambda (x) + (unless (identifier? x) + (raise-syntax-error #f "not an identifier" x stx))) + (syntax->list #'(id ...))) + #'(begin-for-syntax + (define-values (id ...) expr)))]))) (define-syntaxes (define define-syntax define-for-syntax) (let ([go @@ -18,64 +33,4 @@ (#,define-values-stx (#,id) #,rhs))))]) (values (lambda (stx) (go #'define-values stx)) (lambda (stx) (go #'define-syntaxes stx)) - (lambda (stx) (go #'define-values-for-syntax stx))))) - - (define-syntaxes (begin-for-syntax) - (lambda (stx) - (let ([ctx (syntax-local-context)]) - (unless (memq ctx '(module module-begin top-level)) - (raise-syntax-error #f "allowed only at the top-level or a module top-level" stx)) - (syntax-case stx () - [(_) #'(begin)] - [(_ elem) - (not (eq? ctx 'module-begin)) - (let ([e (local-transformer-expand/capture-lifts - #'elem - ctx - (syntax->list - #'(begin - define-values - define-syntaxes - define-values-for-syntax - set! - let-values - let*-values - letrec-values - lambda - case-lambda - if - quote - letrec-syntaxes+values - fluid-let-syntax - with-continuation-mark - #%expression - #%variable-reference - #%app - #%top - #%provide - #%require)))]) - (syntax-case* e (begin define-values define-syntaxes require require-for-template) - free-transformer-identifier=? - [(begin (begin v ...)) - #'(begin-for-syntax v ...)] - [(begin (define-values (id ...) expr)) - #'(define-values-for-syntax (id ...) expr)] - [(begin (require v ...)) - #'(require (for-syntax v ...))] - [(begin (define-syntaxes (id ...) expr)) - (raise-syntax-error - #f - "syntax definitions not allowed within begin-for-syntax" - #'elem)] - [(begin other) - #'(define-values-for-syntax () (begin other (values)))] - [(begin v ...) - #'(begin-for-syntax v ...)]))] - [(_ elem ...) - ;; We split up the elems so that someone else can - ;; worry about the fact that properly expanding the second - ;; things might depend somehow on the first thing. - ;; This also avoids a problem when `begin-for-syntax' is the - ;; only thing in a module body, and `module' has to expand - ;; it looking for #%module-begin. - (syntax/loc stx (begin (begin-for-syntax elem) ...))]))))) + (lambda (stx) (go #'define-values-for-syntax stx)))))) diff --git a/collects/racket/private/modbeg.rkt b/collects/racket/private/modbeg.rkt index d4930d049b..4169926c30 100644 --- a/collects/racket/private/modbeg.rkt +++ b/collects/racket/private/modbeg.rkt @@ -61,7 +61,7 @@ begin begin0 set! with-continuation-mark if #%app #%expression - define-values define-syntaxes define-values-for-syntax + define-values define-syntaxes begin-for-syntax module #%module-begin #%require #%provide @@ -98,7 +98,7 @@ (free-identifier=? i a)) (syntax->list (quote-syntax - (define-values define-syntaxes define-values-for-syntax + (define-values define-syntaxes begin-for-syntax module #%module-begin #%require #%provide)))) diff --git a/collects/racket/private/old-rp.rkt b/collects/racket/private/old-rp.rkt index 74f15547f2..14b78db0c5 100644 --- a/collects/racket/private/old-rp.rkt +++ b/collects/racket/private/old-rp.rkt @@ -5,28 +5,29 @@ (#%provide require require-for-syntax require-for-template require-for-label provide provide-for-syntax provide-for-label) - (define-values-for-syntax (rebuild-elem) - (lambda (stx elem sub pos loop ids) - ;; For sub-forms, we loop and reconstruct: - (for-each (lambda (id) - (unless (identifier? id) - (raise-syntax-error - #f - "expected an identifier" - stx - id))) - (syntax->list ids)) - (let rloop ([elem elem][pos pos]) - (if (syntax? elem) - (datum->syntax elem - (rloop (syntax-e elem) pos) - elem - elem) - (if (zero? pos) - (cons (loop (car elem)) - (cdr elem)) - (cons (car elem) - (rloop (cdr elem) (sub1 pos)))))))) + (begin-for-syntax + (define-values (rebuild-elem) + (lambda (stx elem sub pos loop ids) + ;; For sub-forms, we loop and reconstruct: + (for-each (lambda (id) + (unless (identifier? id) + (raise-syntax-error + #f + "expected an identifier" + stx + id))) + (syntax->list ids)) + (let rloop ([elem elem][pos pos]) + (if (syntax? elem) + (datum->syntax elem + (rloop (syntax-e elem) pos) + elem + elem) + (if (zero? pos) + (cons (loop (car elem)) + (cdr elem)) + (cons (car elem) + (rloop (cdr elem) (sub1 pos))))))))) (define-syntaxes (require require-for-syntax require-for-template require-for-label) diff --git a/collects/racket/private/reqprov.rkt b/collects/racket/private/reqprov.rkt index fa01fb7792..03a6eee8f2 100644 --- a/collects/racket/private/reqprov.rkt +++ b/collects/racket/private/reqprov.rkt @@ -636,36 +636,41 @@ (lambda (stx modes) (syntax-case stx () [(_) - (let-values ([(ids stx-ids) (syntax-local-module-defined-identifiers)] - [(same-ctx?) (lambda (free-identifier=?) - (lambda (id) - (free-identifier=? id - (datum->syntax - stx - (syntax-e id)))))]) - (append - (if (memq 1 modes) - (map (lambda (id) - (make-export id (syntax-e id) 1 #f stx)) - (filter (same-ctx? free-transformer-identifier=?) - stx-ids)) - null) - (if (or (null? modes) - (memq 0 modes)) - (map (lambda (id) - (make-export id (syntax-e id) 0 #f stx)) - (filter (lambda (id) - (and ((same-ctx? free-identifier=?) id) - (let-values ([(v id) (syntax-local-value/immediate - id - (lambda () (values #f #f)))]) - (not - (and (rename-transformer? v) - (syntax-property - (rename-transformer-target v) - 'not-provide-all-defined)))))) - ids)) - null)))])))) + (let* ([ht (syntax-local-module-defined-identifiers)] + [same-ctx? (lambda (free-identifier=?) + (lambda (id) + (free-identifier=? id + (datum->syntax + stx + (syntax-e id)))))] + [modes (if (null? modes) + '(0) + modes)]) + (apply + append + (map (lambda (mode) + (let* ([phase (and mode (+ mode (syntax-local-phase-level)))] + [same-ctx-in-phase? + (same-ctx? + (cond + [(eq? mode 0) free-identifier=?] + [(eq? mode 1) free-transformer-identifier=?] + [else (lambda (a b) + (free-identifier=? a b phase))]))]) + (map (lambda (id) + (make-export id (syntax-e id) mode #f stx)) + (filter (lambda (id) + (and (same-ctx-in-phase? id) + (let-values ([(v id) (syntax-local-value/immediate + id + (lambda () (values #f #f)))]) + (not + (and (rename-transformer? v) + (syntax-property + (rename-transformer-target v) + 'not-provide-all-defined)))))) + (hash-ref ht phase null))))) + modes)))])))) (define-syntax all-from-out (make-provide-transformer @@ -815,7 +820,7 @@ (equal? '(0) modes)) (raise-syntax-error #f - "allowed only for phase level 0" + "allowed only for relative phase level 0" stx)) (syntax-case stx () [(_ id) @@ -848,13 +853,14 @@ null] [else (cons (car ids) (loop (cdr ids)))]))))] ;; FIXME: we're building a list of all imports on every expansion - ;; of `syntax-out'. That could become expensive if `syntax-out' is + ;; of `struct-out'. That could become expensive if `struct-out' is ;; used a lot. - [avail-ids (append (let-values ([(ids _) (syntax-local-module-defined-identifiers)]) - ids) + [avail-ids (append (hash-ref (syntax-local-module-defined-identifiers) + (syntax-local-phase-level) + null) (let ([idss (syntax-local-module-required-identifiers #f #t)]) (if idss - (let ([a (assoc 0 idss)]) + (let ([a (assoc (syntax-local-phase-level) idss)]) (if a (cdr a) null)) diff --git a/collects/racket/private/stxcase-scheme.rkt b/collects/racket/private/stxcase-scheme.rkt index 5cc44492ba..a3b707b91c 100644 --- a/collects/racket/private/stxcase-scheme.rkt +++ b/collects/racket/private/stxcase-scheme.rkt @@ -25,16 +25,17 @@ names) #f))) - (define-values-for-syntax (check-sr-rules) - (lambda (stx kws) - (for-each (lambda (id) - (unless (identifier? id) - (raise-syntax-error - #f - "pattern must start with an identifier, found something else" - stx - id))) - (syntax->list kws)))) + (begin-for-syntax + (define-values (check-sr-rules) + (lambda (stx kws) + (for-each (lambda (id) + (unless (identifier? id) + (raise-syntax-error + #f + "pattern must start with an identifier, found something else" + stx + id))) + (syntax->list kws))))) ;; From Dybvig, mostly: (-define-syntax syntax-rules diff --git a/collects/scribble/doclang.rkt b/collects/scribble/doclang.rkt index 3d6ce9b7cd..1acbea935f 100644 --- a/collects/scribble/doclang.rkt +++ b/collects/scribble/doclang.rkt @@ -54,7 +54,7 @@ provide define-values define-syntaxes - define-values-for-syntax + begin-for-syntax #%require #%provide)))) #`(begin #,expanded (doc-begin m-id post-process exprs . body))] diff --git a/collects/scribble/private/lp.rkt b/collects/scribble/private/lp.rkt index ac8a10f61d..a565a293bd 100644 --- a/collects/scribble/private/lp.rkt +++ b/collects/scribble/private/lp.rkt @@ -50,7 +50,6 @@ [(rest ...) (if n #`((subscript #,(format "~a" n))) #`())]) - #`(begin (require (for-label for-label-mod ... ...)) #,@(if n diff --git a/collects/scribble/text/syntax-utils.rkt b/collects/scribble/text/syntax-utils.rkt index 794ea84b0b..16c249b3d1 100644 --- a/collects/scribble/text/syntax-utils.rkt +++ b/collects/scribble/text/syntax-utils.rkt @@ -7,7 +7,7 @@ (begin-for-syntax (define definition-ids ; ids that don't require forcing - (syntax->list #'(define-values define-syntaxes define-values-for-syntax + (syntax->list #'(define-values define-syntaxes begin-for-syntax require provide #%require #%provide))) (define stoplist (append definition-ids (kernel-form-identifier-list))) (define (definition-id? id) diff --git a/collects/scribblings/guide/proc-macros.scrbl b/collects/scribblings/guide/proc-macros.scrbl index b01ba6bb3f..fe251289f3 100644 --- a/collects/scribblings/guide/proc-macros.scrbl +++ b/collects/scribblings/guide/proc-macros.scrbl @@ -352,19 +352,20 @@ make all of these modes treat code consistently, Racket separates the binding spaces for different phases. To define a @racket[check-ids] function that can be referenced at -compile time, use @racket[define-for-syntax]: +compile time, use @racket[begin-for-syntax]: @racketblock/eval[ #:eval check-eval -(define-for-syntax (check-ids stx forms) - (for-each - (lambda (form) - (unless (identifier? form) - (raise-syntax-error #f - "not an identifier" - stx - form))) - (syntax->list forms))) +(begin-for-syntax + (define (check-ids stx forms) + (for-each + (lambda (form) + (unless (identifier? form) + (raise-syntax-error #f + "not an identifier" + stx + form))) + (syntax->list forms)))) ] With this for-syntax definition, then @racket[swap] works: @@ -446,6 +447,7 @@ the right-hand side of the inner @racket[define-syntax] is in the 2}. To import @racket[syntax-case] into that phase level, you would have to use @racket[(require (for-syntax (for-syntax racket/base)))] or, equivalently, @racket[(require (for-meta 2 racket/base))]. For example, + @codeblock|{ #lang racket/base (require ;; This provides the bindings for the definition diff --git a/collects/scribblings/raco/zo-struct.scrbl b/collects/scribblings/raco/zo-struct.scrbl index 1840367273..a08ebf4522 100644 --- a/collects/scribblings/raco/zo-struct.scrbl +++ b/collects/scribblings/raco/zo-struct.scrbl @@ -106,26 +106,28 @@ structures that are produced by @racket[zo-parse] and consumed by @defstruct+[(def-syntaxes form) ([ids (listof symbol?)] [rhs (or/c expr? seq? any/c)] [prefix prefix?] - [max-let-depth exact-nonnegative-integer?])] -@defstruct+[(def-for-syntax form) - ([ids (listof toplevel?)] - [rhs (or/c expr? seq? any/c)] + [max-let-depth exact-nonnegative-integer?] + [dummy (or/c toplevel? #f)])] +@defstruct+[(seq-for-syntax form) + ([forms (listof (or/c form? any/c))] [prefix prefix?] - [max-let-depth exact-nonnegative-integer?])] + [max-let-depth exact-nonnegative-integer?] + [dummy (or/c toplevel? #f)])] )]{ Represents a @racket[define-syntaxes] or - @racket[define-values-for-syntax] form. The @racket[rhs] expression - has its own @racket[prefix], which is pushed before evaluating - @racket[rhs]; the stack is restored after obtaining the result values. + @racket[begin-for-syntax] form. The @racket[rhs] expression or set of + @racket[forms] forms has its own @racket[prefix], which is pushed before evaluating + @racket[rhs] or the @racket[forms]; the stack is restored after obtaining the result values. The @racket[max-let-depth] field indicates the maximum size of the stack that will be created by @racket[rhs] (not counting - @racket[prefix]).} + @racket[prefix]). The @racket[dummy] variable is used to access the enclosing + namespace.} @defstruct+[(req form) ([reqs stx?] [dummy toplevel?])]{ Represents a top-level @racket[#%require] form (but not one in a @racket[module] form) with a sequence of specifications @racket[reqs]. - The @racket[dummy] variable is used to access to the top-level + The @racket[dummy] variable is used to access the top-level namespace.} @defstruct+[(seq form) ([forms (listof (or/c form? any/c))])]{ @@ -155,17 +157,17 @@ structures that are produced by @racket[zo-parse] and consumed by [requires (listof (cons/c (or/c exact-integer? #f) (listof module-path-index?)))] [body (listof (or/c form? any/c))] - [syntax-body (listof (or/c def-syntaxes? def-for-syntax?))] - [unexported (list/c (listof symbol?) - (listof symbol?) - (listof symbol?))] + [syntax-bodies (listof (cons/c exact-positive-integer? + (listof (or/c def-syntaxes? + seq-for-syntax?))))] + [unexported (listof (list/c exact-nonnegative-integer? + (listof symbol?) + (listof symbol?)))] [max-let-depth exact-nonnegative-integer?] [dummy toplevel?] [lang-info (or/c #f (vector/c module-path? symbol? any/c))] [internal-context (or/c #f #t stx?)])]{ - Represents a @racket[module] declaration. The @racket[body] forms use - @racket[prefix], rather than any prefix in place for the module - declaration itself (and each @racket[syntax-body] has its own prefix). + Represents a @racket[module] declaration. The @racket[provides] and @racket[requires] lists are each an association list from phases to exports or imports. In the case of @@ -173,15 +175,21 @@ structures that are produced by @racket[zo-parse] and consumed by variables, and another for exported syntax. In the case of @racket[requires], each phase maps to a list of imported module paths. - The @racket[body] field contains the module's run-time code, and - @racket[syntax-body] contains the module's compile-time code. After - each form in @racket[body] or @racket[syntax-body] is evaluated, the - stack is restored to its depth from before evaluating the form. + The @racket[body] field contains the module's run-time (i.e., phase + 0) code. The @racket[syntax-bodies] list has a list of forms for + each higher phase in the module body; the phases are in order + starting with phase 1. The @racket[body] forms use @racket[prefix], + rather than any prefix in place for the module declaration itself, + while members of lists in @racket[syntax-bodies] have their own + prefixes. After each form in @racket[body] or @racket[syntax-bodies] + is evaluated, the stack is restored to its depth from before + evaluating the form. - The @racket[unexported] list contains lists of symbols for unexported - definitions that can be accessed through macro expansion. The first - list is phase-0 variables, the second is phase-0 syntax, and the last - is phase-1 variables. + The @racket[unexported] list contains lists of symbols for + unexported definitions that can be accessed through macro expansion + and that are implemented through the forms in @racket[body] and + @racket[syntax-bodies]. Each list in @racket[unexported] starts + with a phase level. The @racket[max-let-depth] field indicates the maximum stack depth created by @racket[body] forms (not counting the @racket[prefix] @@ -202,8 +210,8 @@ structures that are produced by @racket[zo-parse] and consumed by ([name symbol?] [src (or/c module-path-index? #f)] [src-name symbol?] - [nom-mod (or/c module-path-index? #f)] - [src-phase (or/c 0 1)] + [nom-src (or/c module-path-index? #f)] + [src-phase exact-nonnegative-integer?] [protected? boolean?])]{ Describes an individual provided identifier within a @racket[mod] instance.} diff --git a/collects/scribblings/reference/eval-model.scrbl b/collects/scribblings/reference/eval-model.scrbl index 84e8433380..2e8550449f 100644 --- a/collects/scribblings/reference/eval-model.scrbl +++ b/collects/scribblings/reference/eval-model.scrbl @@ -556,15 +556,18 @@ effect on further program parsing, as described in @secref["intro-binding"]. Within a module, some definitions are shifted by a phase already; the -@racket[define-for-syntax] form is like @racket[define], but it -defines a variable at relative @tech{phase} 1, instead of relative -@tech{phase} 0. Thus, if the module is @tech{instantiate}d at phase 1, -the variables for @racket[define-for-syntax] are created at phase 2, +@racket[begin-for-syntax] form is similar to @racket[begin], but it +shifts expressions and definitions by a relative @tech{phase} 1. +Thus, if the module is @tech{instantiate}d at phase 1, +the variables defined with @racket[begin-for-syntax] are created at phase 2, and so on. Moreover, this relative phase acts as another layer of -prefixing, so that a @racket[define] of @racket[x] and a -@racket[define-for-syntax] of @racket[x] can co-exist in a module -without colliding. Again, the higher phases are mainly related to -program parsing, instead of normal evaluation. +prefixing, so that a @racket[define] of @racket[x] and a +@racket[begin-for-syntax]-wrapped +@racket[define] of @racket[x] can co-exist in a module +without colliding. A @racket[begin-for-syntax] form can be nested +within a @racket[begin-for-syntax] form, in which case definitions and +expressions are in relative @tech{phase} 2, and so on. Higher phases are +mainly related to program parsing, instead of normal evaluation. If a module @tech{instantiate}d at @tech{phase} @math{n} @racket[require]s another module, then the @racket[require]d module is @@ -588,7 +591,7 @@ module forms (see @secref["mod-parse"]), and are, again, conceptually distinguished by prefixes. Top-level variables can exist in multiple phases in the same way as -within modules. For example, @racket[define-for-syntax] creates a +within modules. For example, @racket[define] within @racket[begin-for-syntax] creates a @tech{phase} 1 variable. Furthermore, reflective operations like @racket[make-base-namespace] and @racket[eval] provide access to top-level variables in higher @tech{phases}, while module diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index 0da27eea60..efbdd493a1 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -473,8 +473,9 @@ to a top-level definition. A compile-time expression in a @racket[letrec-syntaxes+values] or @racket[define-syntaxes] binding is lifted to a @racket[let] wrapper around the corresponding right-hand side of the binding. A compile-time expression within -@racket[begin-for-syntax] is lifted to a @racket[define-for-syntax] -declaration just before the requesting expression. +@racket[begin-for-syntax] is lifted to a @racket[define] +declaration just before the requesting expression within the +@racket[begin-for-syntax]. Other syntactic forms can capture lifts by using @racket[local-expand/capture-lifts] or @@ -524,9 +525,8 @@ then the @exnraise[exn:fail:contract].} Lifts a @racket[#%require] form corresponding to @racket[raw-require-spec] (either as a @tech{syntax object} or datum) -to the top-level or to the top of the module currently being expanded, -wrapping it with @racket[for-meta] if the current expansion context is -not @tech{phase level} 0. +to the top-level or to the top of the module currently being expanded + or to an enclosing @racket[begin-for-syntax].. The resulting syntax object is the same as @racket[stx], except that a fresh @tech{syntax mark} is added. The same @tech{syntax mark} is @@ -551,7 +551,7 @@ by the macro expander can prevent access to the new imports. Lifts a @racket[#%provide] form corresponding to @racket[raw-provide-spec-stx] to the top of the module currently being -expanded. +expanded or to an enclosing @racket[begin-for-syntax]. @transform-time[] If the current expression being transformed is not within a @racket[module] form, or if it is not a run-time expression, @@ -732,20 +732,20 @@ Returns @racket[#t] while a @tech{provide transformer} is running (see @racket[#%provide] is expanded, @racket[#f] otherwise.} -@defproc[(syntax-local-module-defined-identifiers) - (values (listof identifier?) (listof identifier?))]{ +@defproc[(syntax-local-module-defined-identifiers) (and/c hash? immutable?)]{ Can be called only while @racket[syntax-local-transforming-module-provides?] returns @racket[#t]. -It returns two lists of identifiers corresponding to all definitions +It returns a hash table mapping a @tech{phase-level} number (such as +@racket[0]) to a list of all definitions at that @tech{phase level} within the module being expanded. This information is used for implementing @racket[provide] sub-forms like @racket[all-defined-out]. -The first result list corresponds to @tech{phase} 0 (i.e., normal) -definitions, and the second corresponds to @tech{phase} -1 (i.e., -for-syntax) definitions.} +Beware that the @tech{phase-level} keys are absolute relative to the +enclosing module, and not relative to the current transformer phase +level as reported by @racket[syntax-local-phase-level].} @defproc[(syntax-local-module-required-identifiers @@ -769,7 +769,11 @@ with a @racket[phase-level] shift, of all shifts if When an identifier is renamed on import, the result association list includes the identifier by its internal name. Use @racket[identifier-binding] to obtain more information about the -identifier.} +identifier. + +Beware that the @tech{phase-level} keys are absolute relative to the +enclosing module, and not relative to the current transformer phase +level as reported by @racket[syntax-local-phase-level].} @deftogether[( @defthing[prop:liberal-define-context struct-type-property?] diff --git a/collects/scribblings/reference/syntax-model.scrbl b/collects/scribblings/reference/syntax-model.scrbl index 24f768dba4..0c0aa42eb5 100644 --- a/collects/scribblings/reference/syntax-model.scrbl +++ b/collects/scribblings/reference/syntax-model.scrbl @@ -11,19 +11,19 @@ The syntax of a Racket program is defined by @itemize[ - @item{a @deftech{read} phase that processes a character stream into a + @item{a @deftech{read} pass that processes a character stream into a @tech{syntax object}; and} - @item{an @deftech{expand} phase that processes a syntax object to + @item{an @deftech{expand} pass that processes a syntax object to produce one that is fully parsed.} ] -For details on the @tech{read} phase, see @secref["reader"]. Source +For details on the @tech{read} pass, see @secref["reader"]. Source code is normally read in @racket[read-syntax] mode, which produces a @tech{syntax object}. -The @tech{expand} phase recursively processes a @tech{syntax object} +The @tech{expand} pass recursively processes a @tech{syntax object} to produce a complete @tech{parse} of the program. @tech{Binding} information in a @tech{syntax object} drives the @tech{expansion} process, and when the @tech{expansion} process encounters a @@ -186,7 +186,7 @@ the binding (according to @racket[free-identifier=?]) matters.} @racketgrammar*[ #:literals (#%expression module #%plain-module-begin begin #%provide - define-values define-syntaxes define-values-for-syntax + define-values define-syntaxes begin-for-syntax #%require #%plain-lambda case-lambda if begin begin0 let-values letrec-values set! quote-syntax quote with-continuation-mark @@ -196,13 +196,14 @@ the binding (according to @racket[free-identifier=?]) matters.} (module id name-id (#%plain-module-begin module-level-form ...)) - (begin top-level-form ...)] + (begin top-level-form ...) + (begin-for-syntax top-level-form ...)] [module-level-form general-top-level-form - (#%provide raw-provide-spec ...)] + (#%provide raw-provide-spec ...) + (begin-for-syntax module-level-form ...)] [general-top-level-form expr (define-values (id ...) expr) (define-syntaxes (id ...) expr) - (define-values-for-syntax (id ...) expr) (#%require raw-require-spec ...)] [expr id (#%plain-lambda formals expr ...+) @@ -243,15 +244,14 @@ binding to the @racket[#%plain-lambda] of the syntactic-form names refer to the bindings defined in @secref["syntax"]. -Only @tech{phase levels} 0 and 1 are relevant for the parse of a -program (though the @racket[_datum] in a @racket[quote-syntax] form -preserves its information for all @tech{phase level}s). In particular, -the relevant @tech{phase level} is 0, except for the @racket[_expr]s -in a @racket[define-syntax], @racket[define-syntaxes], -@racket[define-for-syntax], or @racket[define-values-for-syntax] form, -in which case the relevant @tech{phase level} is 1 (for which -comparisons are made using @racket[free-transformer-identifier=?] -instead of @racket[free-identifier=?]). +In a fully expanded program for a namespace whose @tech{base phase} is +0, the relevant @tech{phase level} for a binding in the program is +@math{N} if the bindings has @math{N} surrounding +@racket[begin-for-syntax] and @racket[define-syntaxes] forms---not +counting any @racket[begin-for-syntax] forms that wrap a +@racket[module] form for the body of the @racket[module]. The +@racket[_datum] in a @racket[quote-syntax] form, however, always +preserves its information for all @tech{phase level}s. In addition to the grammar above, @racket[letrec-syntaxes+values] can appear in a fully local-expanded expression, as can @@ -427,11 +427,13 @@ core syntactic forms are encountered: at @tech{phase level} 0 (i.e., the @tech{base environment} is extended).} - @item{When a @racket[define-for-syntax] or - @racket[define-values-for-syntax] form is encountered at the - top level or module level, bindings are introduced as for - @racket[define-values], but at @tech{phase level} 1 (i.e., the - @tech{transformer environment} is extended).} + @item{When a @racket[begin-for-syntax] form is encountered at the top + level or module level, bindings are introduced as for + @racket[define-values] and @racket[define-syntaxes], but at + @tech{phase level} 1 (i.e., the @tech{transformer environment} + is extended). More generally, @racket[begin-for-syntax] forms + can be nested, an each @racket[begin-for-syntax] shifts its + body definition by one @tech{phase level}.} @item{When a @racket[let-values] form is encountered, the body of the @racket[let-values] form is extended (by creating new @@ -578,11 +580,11 @@ to its handling of @racket[define-syntaxes]. A level @math{n} (not just 0), in which case the expression for the @tech{transformer binding} is expanded at @tech{phase level} @math{n+1}. -The expression in a @racket[define-for-syntax] or -@racket[define-values-for-syntax] form is expanded and evaluated in -the same way as for @racket[syntax]. However, the introduced binding -is a variable binding at @tech{phase level} 1 (not a @tech{transformer -binding} at @tech{phase level} 0). +The expressions in a @racket[begin-for-syntax] form are expanded and +evaluated in the same way as for @racket[define-syntaxes]. However, +any introduced bindings from definition within +@racket[begin-for-syntax] are at @tech{phase level} 1 (not a +@tech{transformer binding} at @tech{phase level} 0). @;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @subsection[#:tag "partial-expansion"]{Partial Expansion} @@ -654,10 +656,10 @@ the @racket[letrec-syntaxes+values] form. A @racket[require] form not only introduces @tech{bindings} at expansion time, but also @deftech{visits} the referenced module when -it is encountered by the expander. That is, the expander -instantiates any @racket[define-for-syntax]ed variables defined -in the module, and also evaluates all expressions for -@racket[define-syntaxes] @tech{transformer bindings}. +it is encountered by the expander. That is, the expander instantiates +any variables defined in the module within @racket[begin-for-syntax], +and it also evaluates all expressions for @racket[define-syntaxes] +@tech{transformer bindings}. Module @tech{visits} propagate through @racket[require]s in the same way as module @tech{instantiation}. Moreover, when a module is @@ -673,8 +675,8 @@ implicitly @tech{visit}ed. Thus, when the expander encounters @tech{instantiate}s the required module at @tech{phase} 1, in addition to adding bindings at @tech{phase level} 1 (i.e., the @tech{transformer environment}). Similarly, the expander immediately -evaluates any @racket[define-values-for-syntax] form that it -encounters. +evaluates any form that it encounters within +@racket[begin-for-syntax]. @tech{Phases} beyond 0 are @tech{visit}ed on demand. For example, when the right-hand side of a @tech{phase}-0 @racket[let-syntax] is to diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index 2f1245f317..3ec647c7d6 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -152,18 +152,26 @@ action depends on the shape of the form: out into the module's body and immediately processed in place of the @racket[begin].} - @item{If it is a @racket[define-syntaxes] or - @racket[define-values-for-syntax] form, then the right-hand side is + @item{If it is a @racket[define-syntaxes] form, then the right-hand side is evaluated (in @tech{phase} 1), and the binding is immediately installed for further partial expansion within the module. Evaluation of the right-hand side is @racket[parameterize]d to set @racket[current-namespace] as in @racket[let-syntax].} - @item{If the form is a @racket[require] form, bindings are introduced + @item{If it is a @racket[begin-for-syntax] form, then the body is + expanded (in @tech{phase} 1) and evaluated. Expansion within a + @racket[begin-for-syntax] form proceeds with the same + partial-expansion process as for a @racket[module] body, but in a + higher @tech{phase}, and saving all @racket[#%provide] forms for all + phases until the end of the @racket[module]'s expansion. Evaluation + of the body is @racket[parameterize]d to set + @racket[current-namespace] as in @racket[let-syntax].} + + @item{If the form is a @racket[#%require] form, bindings are introduced immediately, and the imported modules are @tech{instantiate}d or @tech{visit}ed as appropriate.} - @item{If the form is a @racket[provide] form, then it is recorded for + @item{If the form is a @racket[#%provide] form, then it is recorded for processing after the rest of the body.} @item{If the form is a @racket[define-values] form, then the binding @@ -177,7 +185,9 @@ action depends on the shape of the form: After all @racket[form]s have been partially expanded this way, then the remaining expression forms (including those on the right-hand side -of a definition) are expanded in an expression context. +of a definition) are expanded in an expression context. Finally, +@racket[#%provide] forms are processed in the order in which they +appear (independent of @tech{phase}) in the expanded module. The scope of all imported identifiers covers the entire module body, as does the scope of any identifier defined within the module body. @@ -707,7 +717,10 @@ A @racket[provide-spec] indicates one or more bindings to provide. For each exported binding, the external name is a symbol that can be different from the symbolic form of the identifier that is bound within the module. Also, each export is drawn from a particular -@tech{phase level} and exported at the same @tech{phase level}. +@tech{phase level} and exported at the same @tech{phase level}; by +default, the relevant phase level is the number of +@racket[begin-for-syntax] forms that enclose the @racket[provide] +form. The syntax of @racket[provide-spec] can be extended via @racket[define-provide-syntax], but the pre-defined forms are as @@ -733,7 +746,7 @@ follows. @racket[make-rename-transformer] for more information.} @defsubform[(all-defined-out)]{ Exports all identifiers that are - defined at @tech{phase level} 0 or @tech{phase level} 1 within the + defined at the relevant @tech{phase level} within the exporting module, and that have the same lexical context as the @racket[(all-defined-out)] form, excluding bindings to @tech{rename transformers} where the target identifier has the @@ -776,7 +789,7 @@ follows. @defsubform[(rename-out [orig-id export-id] ...)]{ Exports each @racket[orig-id], which must be @tech{bound} within the module at - @tech{phase level} 0. The symbolic name for each export is + the relevant @tech{phase level}. The symbolic name for each export is @racket[export-id] instead @racket[orig-d]. @defexamples[#:eval (syntax-eval) @@ -821,8 +834,8 @@ follows. @defsubform[(struct-out id)]{Exports the bindings associated with a structure type @racket[id]. Typically, @racket[id] is bound with @racket[(struct id ....)]; more generally, @racket[id] must have a - @tech{transformer binding} of structure-type information at - @tech{phase level} 0; see @secref["structinfo"]. Furthermore, for + @tech{transformer binding} of structure-type information at the relevant + @tech{phase level}; see @secref["structinfo"]. Furthermore, for each identifier mentioned in the structure-type information, the enclosing module must define or import one identifier that is @racket[free-identifier=?]. If the structure-type information @@ -877,17 +890,21 @@ follows. @specsubform[#:literals (for-meta) (for-meta phase-level provide-spec ...)]{ Like the union of the - @racket[provide-spec]s, but adjusted to apply to @tech{phase level} - specified by @racket[phase-level] (where @racket[#f] corresponds to the - @tech{label phase level}). In particular, an @racket[_id] or @racket[rename-out] form as - a @racket[provide-spec] refers to a binding at @racket[phase-level], an - @racket[all-defined-out] exports only @racket[phase-level] - definitions, and an @racket[all-from-out] exports bindings - imported with a shift by @racket[phase-level]. + @racket[provide-spec]s, but adjusted to apply to the @tech{phase + level} specified by @racket[phase-level] relative to the current + phase level (where @racket[#f] corresponds to the @tech{label phase + level}). In particular, an @racket[_id] or @racket[rename-out] form + as a @racket[provide-spec] refers to a binding at + @racket[phase-level] relative to the current level, an + @racket[all-defined-out] exports only definitions at + @racket[phase-level] relative to the current phase level, and an + @racket[all-from-out] exports bindings imported with a shift by + @racket[phase-level]. @examples[#:eval (syntax-eval) (module nest racket - (define-for-syntax eggs 2) + (begin-for-syntax + (define eggs 2)) (define chickens 3) (provide (for-syntax eggs) chickens)) @@ -905,7 +922,8 @@ follows. chickens)) (module nest2 racket - (define-for-syntax eggs 2) + (begin-for-syntax + (define eggs 2)) (provide (for-syntax eggs))) (require (for-meta 2 racket/base) (for-syntax 'nest2)) @@ -2138,9 +2156,9 @@ a @racket[define-syntaxes] form introduces local bindings. Like @racket[define], except that the binding is at @tech{phase level} 1 instead of @tech{phase level} 0 relative to its context. The expression for the binding is also at @tech{phase level} 1. (See -@secref["id-model"] for information on @tech{phase levels}.) -Evaluation of @racket[expr] side is @racket[parameterize]d to set -@racket[current-namespace] as in @racket[let-syntax]. +@secref["id-model"] for information on @tech{phase levels}.) The form +is a shorthand for @racket[(begin-for-syntax (define id expr))] or +@racket[(begin-for-syntax (define (head args) body ...+))]. Within a module, bindings introduced by @racket[define-for-syntax] must appear before their uses or in the same @@ -2275,18 +2293,24 @@ in tail position only if no @racket[body]s are present. @defform[(begin-for-syntax form ...)]{ -Allowed only in a @tech{top-level context} or @tech{module context}. -Each @racket[form] is partially expanded (see -@secref["partial-expansion"]) to determine one of the following -classifications: +Allowed only in a @tech{top-level context} or @tech{module context}, +shifts the @tech{phase level} of each @racket[form] by one: @itemize[ - @item{@racket[define] or @racket[define-values] form: converted to - a @racket[define-values-for-syntax] form.} + @item{expressions reference bindings at a @tech{phase level} one + greater than in the context of the @racket[begin-for-syntax] + form;} - @item{@racket[require] form: content is wrapped with - @racket[for-syntax].} + @item{@racket[define], @racket[define-values], + @racket[define-syntax], and @racket[define-syntaxes] forms bind + at a @tech{phase level} one greater than in the context of the + @racket[begin-for-syntax] form;} + + @item{in @racket[require] and @racket[provide] forms, the default + @tech{phase level} is greater, which is roughly like wrapping + the content of the @racket[require] form with + @racket[for-syntax];} @item{expression form @racket[_expr]: converted to @racket[(define-values-for-syntax () (begin _expr (values)))], which @@ -2296,6 +2320,12 @@ classifications: ] +See also @racket[module] for information about expansion order and +partial expansion for @racket[begin-for-syntax] within a module +context. Evaluation of an @racket[expr] within +@racket[begin-for-syntax] is @racket[parameterize]d to set +@racket[current-namespace] as in @racket[let-syntax]. + } @;------------------------------------------------------------------------ diff --git a/collects/syntax/kerncase.rkt b/collects/syntax/kerncase.rkt index a561fd9ba4..6a8f44cd62 100644 --- a/collects/syntax/kerncase.rkt +++ b/collects/syntax/kerncase.rkt @@ -21,7 +21,7 @@ begin begin0 set! with-continuation-mark if #%plain-app #%expression - define-values define-syntaxes define-values-for-syntax + define-values define-syntaxes begin-for-syntax module #%plain-module-begin #%require #%provide @@ -78,7 +78,7 @@ begin0 define-values define-syntaxes - define-values-for-syntax + begin-for-syntax set! let-values letrec-values diff --git a/collects/tests/compiler/zo.rkt b/collects/tests/compiler/zo.rkt new file mode 100644 index 0000000000..84b3bd6951 --- /dev/null +++ b/collects/tests/compiler/zo.rkt @@ -0,0 +1,40 @@ +#lang racket/base +(require racket/pretty + compiler/zo-parse + compiler/zo-marshal + compiler/decompile) + +(define ex-mod1 + '(module m racket + (begin-for-syntax + (define fs 10) + (list fs)) + (define-syntax (m stx) + #'10) + (m) + (begin-for-syntax + (list fs)))) + +(define ex-mod2 + '(module m racket + (define t 8) + (define s 10) + (provide t (protect-out s)))) + +(define (check ex-mod) + (let ([c (parameterize ([current-namespace (make-base-namespace)]) + (compile ex-mod))]) + (let ([o (open-output-bytes)]) + (write c o) + (let ([p (zo-parse (open-input-bytes (get-output-bytes o)))]) + (let ([b (zo-marshal p)]) + (let ([p2 (zo-parse (open-input-bytes b))] + [to-string (lambda (p) + (let ([o (open-output-bytes)]) + (print p o) + (get-output-string o)))]) + (unless (equal? (to-string p) (to-string p2)) + (error 'zo "failed on example: ~e" ex-mod)))))))) + +(check ex-mod1) +(check ex-mod2) diff --git a/collects/tests/racket/module.rktl b/collects/tests/racket/module.rktl index f17c36a7bd..b8e99d6352 100644 --- a/collects/tests/racket/module.rktl +++ b/collects/tests/racket/module.rktl @@ -194,6 +194,40 @@ (eval `(require 'f)) (test (list* 'd 'b finished) values l))))) +(let* ([n (make-base-namespace)] + [l null] + [here (lambda (v) + (set! l (cons v l)))]) + (parameterize ([current-namespace n]) + (eval `(module a racket/base + (require (for-syntax racket/base) + (for-meta 2 racket/base)) + (define a 1) + (define-syntax (a-macro stx) #'-1) + (begin-for-syntax + (,here 'pma)) + (begin-for-syntax + (,here 'ma) + (define a-meta 10) + (define-syntax (a-meta-macro stx) #'-1) + (begin-for-syntax + (define a-meta-meta 100) + (,here 'mma))) + (,here 'a) + (provide a a-macro (for-syntax a-meta-macro)))) + (test '(ma mma pma) values l) + (set! l null) + (dynamic-require ''a #f) + (test '(a) values l) + (eval `10) + (test '(a) values l) + (dynamic-require ''a 0) ; => 'a is available... + (eval `10) + (test '(ma pma a) values l) + (eval '(begin-for-syntax)) ; triggers phase-1 visit => phase-2 instantiate + (test '(mma ma pma a) values l) + (void))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Check redundant import and re-provide diff --git a/collects/typed-racket/base-env/base-env.rkt b/collects/typed-racket/base-env/base-env.rkt index 8c4d4a2ead..d80eae8855 100644 --- a/collects/typed-racket/base-env/base-env.rkt +++ b/collects/typed-racket/base-env/base-env.rkt @@ -1293,7 +1293,7 @@ [syntax-local-make-delta-introducer (-> (-Syntax Sym) (-> (-Syntax Sym) (-Syntax Sym)))] [syntax-local-transforming-module-provides? (-> B)] -[syntax-local-module-defined-identifiers (-> (-values (list (-Syntax Sym) (-Syntax Sym))))] +[syntax-local-module-defined-identifiers (-> (-HT (Un B -Int) (-lst (-Syntax Sym))))] [syntax-local-module-required-identifiers (-> (-opt -Module-Path) (Un B -Int) (-lst (-pair (-opt -Int) (-lst (-Syntax Sym)))))] ;Section 11.5 diff --git a/collects/typed-racket/typecheck/tc-toplevel.rkt b/collects/typed-racket/typecheck/tc-toplevel.rkt index 4d991585e2..d388f711ad 100644 --- a/collects/typed-racket/typecheck/tc-toplevel.rkt +++ b/collects/typed-racket/typecheck/tc-toplevel.rkt @@ -187,7 +187,7 @@ [(#%require . _) (void)] [(#%provide . _) (void)] [(define-syntaxes . _) (void)] - [(define-values-for-syntax . _) (void)] + [(begin-for-syntax . _) (void)] ;; FIXME - we no longer need these special cases ;; these forms are handled in pass1 diff --git a/doc/release-notes/racket/HISTORY.txt b/doc/release-notes/racket/HISTORY.txt index 1724ad7830..9f1649fb30 100644 --- a/doc/release-notes/racket/HISTORY.txt +++ b/doc/release-notes/racket/HISTORY.txt @@ -1,3 +1,14 @@ +Version 5.1.3.7 +Generalized begin-with-syntax to allow phase-N definitions, + both variable and syntax, within a module for all N >= 0; + removed define-values-for-syntax from fully expanded forms; + added begin-with-syntax to fully expanded forms +Changed syntax-local-module-defined-identifiers to return + a table for all phases instead of just two values +compiler/zo-structs: removed def-for-syntax, added + seq-for-syntax, changed some mod fields, added field to + def-syntaxes + Version 5.1.3.4 Add support for the collection links file, including (find-system-path 'links-file) and the raco link command diff --git a/src/racket/include/schthread.h b/src/racket/include/schthread.h index a5186c5235..48047efb84 100644 --- a/src/racket/include/schthread.h +++ b/src/racket/include/schthread.h @@ -150,7 +150,7 @@ typedef struct Thread_Local_Variables { struct Scheme_Object *cached_mod_beg_stx_; struct Scheme_Object *cached_dv_stx_; struct Scheme_Object *cached_ds_stx_; - struct Scheme_Object *cached_dvs_stx_; + struct Scheme_Object *cached_bfs_stx_; int cached_stx_phase_; struct Scheme_Object *cwv_stx_; int cwv_stx_phase_; @@ -488,7 +488,7 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL; #define cached_mod_beg_stx XOA (scheme_get_thread_local_variables()->cached_mod_beg_stx_) #define cached_dv_stx XOA (scheme_get_thread_local_variables()->cached_dv_stx_) #define cached_ds_stx XOA (scheme_get_thread_local_variables()->cached_ds_stx_) -#define cached_dvs_stx XOA (scheme_get_thread_local_variables()->cached_dvs_stx_) +#define cached_bfs_stx XOA (scheme_get_thread_local_variables()->cached_bfs_stx_) #define cached_stx_phase XOA (scheme_get_thread_local_variables()->cached_stx_phase_) #define cwv_stx XOA (scheme_get_thread_local_variables()->cwv_stx_) #define cwv_stx_phase XOA (scheme_get_thread_local_variables()->cwv_stx_phase_) diff --git a/src/racket/src/compenv.c b/src/racket/src/compenv.c index 9544fb0b56..0505864fde 100644 --- a/src/racket/src/compenv.c +++ b/src/racket/src/compenv.c @@ -1883,7 +1883,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, /* Try syntax table: */ if (modname) { - val = scheme_module_syntax(modname, env->genv, find_id); + val = scheme_module_syntax(modname, env->genv, find_id, SCHEME_INT_VAL(mod_defn_phase)); if (val && !(flags & SCHEME_NO_CERT_CHECKS)) scheme_check_accessible_in_module(genv, env->insp, in_modidx, find_id, src_find_id, NULL, NULL, rename_insp, diff --git a/src/racket/src/compile.c b/src/racket/src/compile.c index 8648ae2cb0..b015547653 100644 --- a/src/racket/src/compile.c +++ b/src/racket/src/compile.c @@ -108,8 +108,8 @@ static Scheme_Object *quote_syntax_syntax(Scheme_Object *form, Scheme_Comp_Env * static Scheme_Object *quote_syntax_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); static Scheme_Object *define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); static Scheme_Object *define_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *define_for_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *define_for_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); +static Scheme_Object *begin_for_syntax_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); +static Scheme_Object *begin_for_syntax_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); static Scheme_Object *letrec_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); static Scheme_Object *letrec_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); @@ -273,9 +273,9 @@ void scheme_init_compile (Scheme_Env *env) quote_syntax_expand), env); scheme_add_global_keyword("define-syntaxes", scheme_define_syntaxes_syntax, env); - scheme_add_global_keyword("define-values-for-syntax", - scheme_make_compiled_syntax(define_for_syntaxes_syntax, - define_for_syntaxes_expand), + scheme_add_global_keyword("begin-for-syntax", + scheme_make_compiled_syntax(begin_for_syntax_syntax, + begin_for_syntax_expand), env); scheme_add_global_keyword("letrec-syntaxes+values", scheme_make_compiled_syntax(letrec_syntaxes_syntax, @@ -3135,7 +3135,7 @@ single_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info form_name = SCHEME_STX_CAR(form); if (simplify && (erec[drec].depth == -1)) { - /* FIXME: this needs EXPAND_OBSERVE callbacks. */ + /* FIXME [Ryan?]: this needs EXPAND_OBSERVE callbacks? */ expr = scheme_stx_track(expr, form, form_name); SCHEME_EXPAND_OBSERVE_TAG(erec[drec].observer,expr); return expr; @@ -3224,6 +3224,19 @@ quote_syntax_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Inf /* define-syntaxes */ /**********************************************************************/ +static void prep_exp_env_compile_rec(Scheme_Compile_Info *rec, int drec) +{ + rec[0].comp = 1; + rec[0].dont_mark_local_use = 0; + rec[0].resolve_module_ids = 0; + rec[0].value_name = NULL; + rec[0].observer = NULL; + rec[0].pre_unwrapped = 0; + rec[0].testing_constantness = 0; + rec[0].env_already = 0; + rec[0].comp_flags = rec[drec].comp_flags; +} + static Scheme_Object *stx_val(Scheme_Object *name, Scheme_Object *_env) { Scheme_Env *env = (Scheme_Env *)_env; @@ -3233,7 +3246,7 @@ static Scheme_Object *stx_val(Scheme_Object *name, Scheme_Object *_env) static Scheme_Object * do_define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec, int for_stx) + Scheme_Compile_Info *rec, int drec) { Scheme_Object *names, *code, *dummy; Scheme_Object *val, *vec; @@ -3248,27 +3261,13 @@ do_define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, scheme_prepare_exp_env(env->genv); scheme_prepare_compile_env(env->genv->exp_env); - if (!for_stx) - names = scheme_named_map_1(NULL, stx_val, names, (Scheme_Object *)env->genv); + names = scheme_named_map_1(NULL, stx_val, names, (Scheme_Object *)env->genv); exp_env = scheme_new_comp_env(env->genv->exp_env, env->insp, 0); dummy = scheme_make_environment_dummy(env); - - rec1.comp = 1; - rec1.dont_mark_local_use = 0; - rec1.resolve_module_ids = 0; - rec1.value_name = NULL; - rec1.observer = NULL; - rec1.pre_unwrapped = 0; - rec1.testing_constantness = 0; - rec1.env_already = 0; - rec1.comp_flags = rec[drec].comp_flags; - if (for_stx) { - names = defn_targets_syntax(names, exp_env, &rec1, 0); - scheme_compile_rec_done_local(&rec1, 0); - } + prep_exp_env_compile_rec(&rec1, 0); val = scheme_compile_expr_lift_to_let(code, exp_env, &rec1, 0); @@ -3278,7 +3277,7 @@ do_define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, SCHEME_VEC_ELS(vec)[2] = names; SCHEME_VEC_ELS(vec)[3] = val; - vec->type = (for_stx ? scheme_define_for_syntax_type : scheme_define_syntaxes_type); + vec->type = scheme_define_syntaxes_type; scheme_merge_undefineds(exp_env, env); @@ -3289,14 +3288,7 @@ static Scheme_Object * define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) { - return do_define_syntaxes_syntax(form, env, rec, drec, 0); -} - -static Scheme_Object * -define_for_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - return do_define_syntaxes_syntax(form, env, rec, drec, 1); + return do_define_syntaxes_syntax(form, env, rec, drec); } static Scheme_Object * @@ -3328,9 +3320,91 @@ define_syntaxes_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Ex } static Scheme_Object * -define_for_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +begin_for_syntax_expand(Scheme_Object *orig_form, Scheme_Comp_Env *in_env, Scheme_Expand_Info *rec, int drec) { - return define_syntaxes_expand(form, env, erec, drec); + Scheme_Expand_Info recs[1]; + Scheme_Object *form, *context_key, *l, *fn, *vec, *dummy; + Scheme_Comp_Env *env; + + /* FIXME [Ryan?]: */ + /* SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(erec[drec].observer); */ + + form = orig_form; + + if (!scheme_is_toplevel(in_env)) + scheme_wrong_syntax(NULL, NULL, form, "illegal use (not at top-level)"); + + (void)check_form(form, form); + + scheme_prepare_exp_env(in_env->genv); + scheme_prepare_compile_env(in_env->genv->exp_env); + + if (rec[drec].comp) + env = scheme_new_comp_env(in_env->genv->exp_env, in_env->insp, 0); + else + env = scheme_new_expand_env(in_env->genv->exp_env, in_env->insp, 0); + + if (rec[drec].comp) + dummy = scheme_make_environment_dummy(in_env); + else + dummy = NULL; + + context_key = scheme_generate_lifts_key(); + + l = SCHEME_STX_CDR(form); + form = scheme_null; + + while (1) { + scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env), + scheme_false, scheme_false, scheme_null, scheme_false); + + if (rec[drec].comp) { + scheme_init_compile_recs(rec, drec, recs, 1); + prep_exp_env_compile_rec(recs, 0); + l = scheme_compile_list(l, env, recs, 0); + } else { + scheme_init_expand_recs(rec, drec, recs, 1); + l = scheme_expand_list(l, env, recs, 0); + } + + if (SCHEME_NULLP(form)) + form = l; + else + form = scheme_append(l, form); + + l = scheme_frame_get_lifts(env); + if (SCHEME_NULLP(l)) { + /* No lifts */ + if (rec[drec].comp) + scheme_merge_compile_recs(rec, drec, NULL, 1); /* fix this if merge changes to do something */ + break; + } else { + /* We have lifts: */ + /* FIXME [Ryan?]: need some expand-observe callback here? */ + } + } + + if (rec[drec].comp) { + vec = scheme_make_vector(4, NULL); + SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)env->prefix; + SCHEME_VEC_ELS(vec)[1] = dummy; + SCHEME_VEC_ELS(vec)[2] = form; + vec->type = scheme_begin_for_syntax_type; + + return vec; + } else { + fn = SCHEME_STX_CAR(orig_form); + return scheme_datum_to_syntax(cons(fn, form), + orig_form, orig_form, + 0, 2); + } +} + +static Scheme_Object * +begin_for_syntax_syntax(Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Compile_Info *rec, int drec) +{ + return begin_for_syntax_expand(form, env, rec, drec); } Scheme_Object *scheme_make_environment_dummy(Scheme_Comp_Env *env) @@ -4325,7 +4399,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, #if 1 if (!SCHEME_STXP(form)) - scheme_signal_error("not syntax"); + scheme_signal_error("internal error: not syntax"); #endif if (rec[drec].comp) { @@ -4338,7 +4412,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, var = SCHEME_STX_VAL(form); if (scheme_stx_has_empty_wraps(form) && same_effective_env(SCHEME_PTR2_VAL(var), env)) { - /* FIXME: this needs EXPAND_OBSERVE callbacks. */ + /* FIXME [Ryan?]: this needs EXPAND_OBSERVE callbacks. */ form = scheme_stx_track(SCHEME_PTR1_VAL(var), form, form); if (!rec[drec].comp && (rec[drec].depth != -1)) { /* Already fully expanded. */ diff --git a/src/racket/src/cstartup.inc b/src/racket/src/cstartup.inc index 52767c1fdb..af411a6375 100644 --- a/src/racket/src/cstartup.inc +++ b/src/racket/src/cstartup.inc @@ -1,26 +1,26 @@ { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,54,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,13,0,22, -0,26,0,31,0,38,0,51,0,58,0,63,0,68,0,72,0,79,0,82,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,55,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,13,0,17, +0,22,0,29,0,42,0,49,0,54,0,59,0,63,0,70,0,73,0,82,0, 85,0,91,0,105,0,119,0,122,0,128,0,132,0,134,0,145,0,147,0,161, 0,168,0,190,0,192,0,206,0,17,1,46,1,57,1,68,1,93,1,126,1, 159,1,218,1,17,2,95,2,150,2,155,2,175,2,68,3,88,3,140,3,206, -3,95,4,237,4,34,5,45,5,124,5,0,0,69,7,0,0,69,35,37,109, -105,110,45,115,116,120,29,11,11,68,104,101,114,101,45,115,116,120,63,108,101, -116,64,99,111,110,100,66,117,110,108,101,115,115,72,112,97,114,97,109,101,116, -101,114,105,122,101,66,100,101,102,105,110,101,64,119,104,101,110,64,108,101,116, -42,63,97,110,100,66,108,101,116,114,101,99,62,111,114,29,11,11,65,113,117, +3,95,4,237,4,34,5,45,5,124,5,0,0,83,7,0,0,69,35,37,109, +105,110,45,115,116,120,29,11,11,63,108,101,116,64,99,111,110,100,66,117,110, +108,101,115,115,72,112,97,114,97,109,101,116,101,114,105,122,101,66,100,101,102, +105,110,101,64,119,104,101,110,64,108,101,116,42,63,97,110,100,66,108,101,116, +114,101,99,62,111,114,68,104,101,114,101,45,115,116,120,29,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,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,126,76,0, -0,95,159,2,17,36,36,159,2,16,36,36,159,2,16,36,36,16,20,2,4, -2,2,2,6,2,2,2,8,2,2,2,7,2,2,2,9,2,2,2,10,2, -2,2,11,2,2,2,5,2,2,2,12,2,2,2,13,2,2,97,37,11,8, -240,126,76,0,0,93,159,2,16,36,37,16,2,2,3,161,2,2,37,2,3, -2,2,2,3,96,11,11,8,240,126,76,0,0,16,0,96,38,11,8,240,126, +100,101,102,105,110,101,45,118,97,108,117,101,115,97,36,11,8,240,83,76,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,5,2,2,2,7,2,2,2,6,2,2,2,8,2,2,2,9,2, +2,2,10,2,2,2,4,2,2,2,11,2,2,2,12,2,2,97,37,11,8, +240,83,76,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,83,76,0,0,16,0,96,11,11,8,240,83, 76,0,0,16,0,18,98,64,104,101,114,101,13,16,5,36,2,14,2,2,11, 11,8,32,8,31,8,30,8,29,27,248,22,155,4,195,249,22,148,4,80,158, 39,36,251,22,83,2,18,248,22,98,199,12,249,22,73,2,19,248,22,100,201, @@ -28,16 +28,16 @@ 98,199,249,22,73,2,19,248,22,100,201,12,27,248,22,75,248,22,155,4,196, 28,248,22,81,193,20,14,159,37,36,37,28,248,22,81,248,22,75,194,248,22, 74,193,249,22,148,4,80,158,39,36,251,22,83,2,18,248,22,74,199,249,22, -73,2,11,248,22,75,201,11,18,100,10,13,16,5,36,2,14,2,2,11,11, +73,2,10,248,22,75,201,11,18,100,10,13,16,5,36,2,14,2,2,11,11, 8,32,8,31,8,30,8,29,16,4,11,11,2,20,3,1,8,101,110,118,49, -52,56,48,57,16,4,11,11,2,21,3,1,8,101,110,118,49,52,56,49,48, +52,55,51,57,16,4,11,11,2,21,3,1,8,101,110,118,49,52,55,52,48, 27,248,22,75,248,22,155,4,196,28,248,22,81,193,20,14,159,37,36,37,28, 248,22,81,248,22,75,194,248,22,74,193,249,22,148,4,80,158,39,36,250,22, 83,2,22,248,22,83,249,22,83,248,22,83,2,23,248,22,74,201,251,22,83, -2,18,2,23,2,23,249,22,73,2,13,248,22,75,204,18,100,11,13,16,5, +2,18,2,23,2,23,249,22,73,2,12,248,22,75,204,18,100,11,13,16,5, 36,2,14,2,2,11,11,8,32,8,31,8,30,8,29,16,4,11,11,2,20, -3,1,8,101,110,118,49,52,56,49,50,16,4,11,11,2,21,3,1,8,101, -110,118,49,52,56,49,51,248,22,155,4,193,27,248,22,155,4,194,249,22,73, +3,1,8,101,110,118,49,52,55,52,50,16,4,11,11,2,21,3,1,8,101, +110,118,49,52,55,52,51,248,22,155,4,193,27,248,22,155,4,194,249,22,73, 248,22,83,248,22,74,196,248,22,75,195,27,248,22,75,248,22,155,4,23,197, 1,249,22,148,4,80,158,39,36,28,248,22,58,248,22,149,4,248,22,74,23, 198,2,27,249,22,2,32,0,88,163,8,36,37,43,11,9,222,33,40,248,22, @@ -51,7 +51,7 @@ 163,8,36,37,47,11,9,222,33,43,248,22,155,4,248,22,74,201,248,22,75, 198,27,248,22,75,248,22,155,4,196,27,248,22,155,4,248,22,74,195,249,22, 148,4,80,158,40,36,28,248,22,81,195,250,22,84,2,22,9,248,22,75,199, -250,22,83,2,4,248,22,83,248,22,74,199,250,22,84,2,10,248,22,75,201, +250,22,83,2,3,248,22,83,248,22,74,199,250,22,84,2,9,248,22,75,201, 248,22,75,202,27,248,22,75,248,22,155,4,23,197,1,27,249,22,1,22,87, 249,22,2,22,155,4,248,22,155,4,248,22,74,199,248,22,174,4,249,22,148, 4,80,158,41,36,251,22,83,1,22,119,105,116,104,45,99,111,110,116,105,110, @@ -62,43 +62,44 @@ 75,204,27,248,22,75,248,22,155,4,196,28,248,22,81,193,20,14,159,37,36, 37,249,22,148,4,80,158,39,36,27,248,22,155,4,248,22,74,197,28,249,22, 140,9,62,61,62,248,22,149,4,248,22,98,196,250,22,83,2,22,248,22,83, -249,22,83,21,93,2,27,248,22,74,199,250,22,84,2,5,249,22,83,2,27, +249,22,83,21,93,2,27,248,22,74,199,250,22,84,2,4,249,22,83,2,27, 249,22,83,248,22,107,203,2,27,248,22,75,202,251,22,83,2,18,28,249,22, 140,9,248,22,149,4,248,22,74,200,64,101,108,115,101,10,248,22,74,197,250, -22,84,2,22,9,248,22,75,200,249,22,73,2,5,248,22,75,202,99,13,16, +22,84,2,22,9,248,22,75,200,249,22,73,2,4,248,22,75,202,99,13,16, 5,36,2,14,2,2,11,11,8,32,8,31,8,30,8,29,16,4,11,11,2, -20,3,1,8,101,110,118,49,52,56,51,53,16,4,11,11,2,21,3,1,8, -101,110,118,49,52,56,51,54,18,158,94,10,64,118,111,105,100,8,48,27,248, +20,3,1,8,101,110,118,49,52,55,54,53,16,4,11,11,2,21,3,1,8, +101,110,118,49,52,55,54,54,18,158,94,10,64,118,111,105,100,8,48,27,248, 22,75,248,22,155,4,196,249,22,148,4,80,158,39,36,28,248,22,58,248,22, 149,4,248,22,74,197,250,22,83,2,28,248,22,83,248,22,74,199,248,22,98, 198,27,248,22,149,4,248,22,74,197,250,22,83,2,28,248,22,83,248,22,74, 197,250,22,84,2,25,248,22,75,199,248,22,75,202,159,36,20,112,159,36,16, -1,11,16,0,20,26,142,2,1,2,1,2,2,11,11,11,10,36,80,158,36, -36,20,112,159,36,16,0,16,0,16,1,2,3,37,16,0,36,16,0,36,11, -11,39,36,11,11,16,10,2,4,2,5,2,6,2,7,2,8,2,9,2,10, -2,11,2,12,2,13,16,10,11,11,11,11,11,11,11,11,11,11,16,10,2, -4,2,5,2,6,2,7,2,8,2,9,2,10,2,11,2,12,2,13,36,46, -37,11,11,16,0,16,0,16,0,36,36,11,11,11,16,0,16,0,16,0,36, -36,16,11,16,5,2,3,20,14,159,36,36,36,36,20,112,159,36,16,0,16, -1,33,33,10,16,5,2,6,88,163,8,36,37,53,37,9,223,0,33,34,36, -20,112,159,36,16,1,2,3,16,0,11,16,5,2,9,88,163,8,36,37,53, -37,9,223,0,33,35,36,20,112,159,36,16,1,2,3,16,0,11,16,5,2, -11,88,163,8,36,37,53,37,9,223,0,33,36,36,20,112,159,36,16,1,2, -3,16,1,33,37,11,16,5,2,13,88,163,8,36,37,56,37,9,223,0,33, -38,36,20,112,159,36,16,1,2,3,16,1,33,39,11,16,5,2,4,88,163, -8,36,37,58,37,9,223,0,33,42,36,20,112,159,36,16,1,2,3,16,0, -11,16,5,2,12,88,163,8,36,37,53,37,9,223,0,33,44,36,20,112,159, -36,16,1,2,3,16,0,11,16,5,2,10,88,163,8,36,37,54,37,9,223, -0,33,45,36,20,112,159,36,16,1,2,3,16,0,11,16,5,2,7,88,163, -8,36,37,56,37,9,223,0,33,46,36,20,112,159,36,16,1,2,3,16,0, -11,16,5,2,5,88,163,8,36,37,58,37,9,223,0,33,47,36,20,112,159, -36,16,1,2,3,16,1,33,49,11,16,5,2,8,88,163,8,36,37,54,37, -9,223,0,33,50,36,20,112,159,36,16,1,2,3,16,0,11,16,0,94,2, -16,2,17,93,2,16,9,9,36,0}; - EVAL_ONE_SIZED_STR((char *)expr, 2004); +1,11,16,0,20,26,146,2,1,2,1,2,2,11,11,11,10,36,80,158,36, +36,20,112,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,112,159,36,16,1,2,13,16,1,33,33,10,16,5,2, +5,88,163,8,36,37,53,37,9,223,0,33,34,36,20,112,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,112,159,36,16,1,2,13,16,0,11,16,5,2,10,88,163,8,36,37,53, +37,9,223,0,33,36,36,20,112,159,36,16,1,2,13,16,1,33,37,11,16, +5,2,12,88,163,8,36,37,56,37,9,223,0,33,38,36,20,112,159,36,16, +1,2,13,16,1,33,39,11,16,5,2,3,88,163,8,36,37,58,37,9,223, +0,33,42,36,20,112,159,36,16,1,2,13,16,0,11,16,5,2,11,88,163, +8,36,37,53,37,9,223,0,33,44,36,20,112,159,36,16,1,2,13,16,0, +11,16,5,2,9,88,163,8,36,37,54,37,9,223,0,33,45,36,20,112,159, +36,16,1,2,13,16,0,11,16,5,2,6,88,163,8,36,37,56,37,9,223, +0,33,46,36,20,112,159,36,16,1,2,13,16,0,11,16,5,2,4,88,163, +8,36,37,58,37,9,223,0,33,47,36,20,112,159,36,16,1,2,13,16,1, +33,49,11,16,5,2,7,88,163,8,36,37,54,37,9,223,0,33,50,36,20, +112,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, 2018); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,54,0,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,55,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,109,0,0,0,1,0,0,8,0,21,0,26, 0,43,0,65,0,94,0,109,0,127,0,143,0,157,0,179,0,195,0,212,0, 234,0,245,0,251,0,4,1,11,1,18,1,30,1,46,1,70,1,102,1,120, @@ -110,7 +111,7 @@ 15,17,23,17,129,17,192,17,194,17,50,18,110,18,115,18,238,18,249,18,129, 19,139,19,62,21,84,21,93,21,86,22,104,22,118,22,77,23,96,23,34,26, 154,30,68,31,213,31,198,32,180,33,187,33,12,34,95,34,180,34,206,34,79, -35,0,0,180,39,0,0,67,35,37,117,116,105,108,115,72,112,97,116,104,45, +35,0,0,177,39,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,1,20,102,105,110,100,45,101,120,101,99,117,116, 97,98,108,101,45,112,97,116,104,1,27,112,97,116,104,45,108,105,115,116,45, @@ -369,7 +370,7 @@ 22,157,2,195,88,163,8,36,38,48,11,9,223,3,33,88,28,197,86,94,20, 18,159,11,80,158,42,47,193,20,18,159,11,80,158,42,48,196,86,94,20,18, 159,11,80,158,42,53,193,20,18,159,11,80,158,42,54,196,193,28,193,80,158, -38,47,80,158,38,53,248,22,8,88,163,8,32,37,8,40,8,240,0,188,23, +38,47,80,158,38,53,248,22,9,88,163,8,32,37,8,40,8,240,0,188,23, 0,9,224,1,2,33,89,0,7,35,114,120,34,47,43,34,28,248,22,130,7, 23,195,2,27,249,22,138,15,2,91,196,28,192,28,249,22,184,3,248,22,97, 195,248,22,174,3,248,22,133,7,198,249,22,7,250,22,152,7,199,36,248,22, @@ -541,7 +542,7 @@ 28,23,194,2,23,194,1,86,94,23,194,1,36,249,22,185,5,23,199,1,20, 20,95,88,163,8,36,36,48,11,9,224,4,2,33,107,23,195,1,23,197,1, 27,248,22,170,5,23,195,1,248,80,159,39,8,31,39,193,159,36,20,112,159, -36,16,1,11,16,0,20,26,142,2,1,2,1,29,11,11,11,11,11,10,43, +36,16,1,11,16,0,20,26,141,2,1,2,1,29,11,11,11,11,11,10,43, 80,158,36,36,20,112,159,40,16,28,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,30,2,18,76, 102,105,110,100,45,108,105,110,107,115,45,112,97,116,104,33,4,30,2,19,1, @@ -549,58 +550,58 @@ 6,30,2,19,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,20,2,21,2,22,30,2,18,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,23,2,24,2,25,2,26,2,27,2,28,2,29,16,0,16,0,36,16,0, +2,23,2,24,2,25,2,26,2,27,2,28,2,29,16,0,37,39,36,16,0, 36,16,12,2,8,2,7,2,3,2,24,2,22,2,20,2,15,2,21,2,23, -2,13,2,12,2,14,48,11,11,39,36,11,11,16,12,2,11,2,9,2,29, -2,10,2,5,2,28,2,27,2,4,2,26,2,6,2,25,2,2,16,12,11, -11,11,11,11,11,11,11,11,11,11,11,16,12,2,11,2,9,2,29,2,10, -2,5,2,28,2,27,2,4,2,26,2,6,2,25,2,2,48,48,37,11,11, -16,0,16,0,16,0,36,36,11,11,11,16,0,16,0,16,0,36,36,16,0, -16,28,20,15,16,2,88,163,8,36,37,51,16,2,8,240,0,128,0,0,8, -240,1,128,0,0,2,30,223,0,33,50,80,159,36,8,31,39,20,15,16,2, -88,163,8,36,37,56,16,2,44,8,240,0,64,0,0,2,30,223,0,33,51, -80,159,36,8,30,39,20,15,16,2,88,163,8,36,37,51,16,2,44,8,128, -128,2,30,223,0,33,52,80,159,36,8,29,39,20,15,16,2,88,163,8,36, -37,51,16,2,44,8,128,64,2,30,223,0,33,53,80,159,36,8,28,39,20, -15,16,2,32,0,88,163,36,37,45,11,2,2,222,33,54,80,159,36,36,37, -20,15,16,2,249,22,132,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,55,80,159,36,38,37,20,15,16,2, -20,25,96,2,5,88,163,8,36,39,8,24,52,9,223,0,33,62,88,163,36, -38,47,44,9,223,0,33,63,88,163,36,37,46,44,9,223,0,33,64,80,159, -36,39,37,20,15,16,2,27,248,22,132,15,248,22,144,8,27,28,249,22,140, -9,247,22,152,8,2,32,6,1,1,59,6,1,1,58,250,22,178,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,6,223,0,33,68,80,159,36,40,37,20,15,16, -2,32,0,88,163,8,36,38,50,11,2,7,222,33,69,80,159,36,41,37,20, -15,16,2,32,0,88,163,8,36,39,51,11,2,8,222,33,71,80,159,36,42, -37,20,15,16,2,88,163,45,38,51,8,128,4,2,9,223,0,33,74,80,159, -36,43,37,20,15,16,2,88,163,45,39,52,8,128,4,2,11,223,0,33,77, -80,159,36,45,37,20,15,16,2,248,22,188,14,70,108,105,110,107,115,45,102, -105,108,101,80,159,36,46,37,20,15,16,2,247,22,133,2,80,158,36,47,20, -15,16,2,2,78,80,158,36,48,20,15,16,2,248,80,159,37,50,37,88,163, -36,36,49,8,240,8,128,1,0,9,223,1,33,79,80,159,36,49,37,20,15, -16,2,247,22,133,2,80,158,36,53,20,15,16,2,2,78,80,158,36,54,20, -15,16,2,88,163,36,37,44,8,240,0,188,23,0,2,22,223,0,33,90,80, -159,36,55,37,20,15,16,2,88,163,36,38,56,8,240,0,0,32,0,2,23, -223,0,33,92,80,159,36,57,37,20,15,16,2,88,163,36,41,8,24,8,240, -0,32,40,0,2,10,223,0,33,99,80,159,36,44,37,20,15,16,2,32,0, -88,163,36,39,50,11,2,24,222,33,100,80,159,36,58,37,20,15,16,2,32, -0,88,163,36,38,53,11,2,25,222,33,101,80,159,36,59,37,20,15,16,2, -32,0,88,163,36,38,54,11,2,26,222,33,102,80,159,36,8,24,37,20,15, -16,2,32,0,88,163,36,37,44,11,2,27,222,33,103,80,159,36,8,25,37, -20,15,16,2,20,25,96,2,28,88,163,36,36,53,16,2,52,8,128,64,9, -223,0,33,104,88,163,36,37,54,16,2,52,8,128,128,9,223,0,33,105,88, -163,36,38,55,16,2,52,8,240,0,64,0,0,9,223,0,33,106,80,159,36, -8,26,37,20,15,16,2,88,163,8,36,39,54,16,2,44,8,240,0,128,0, -0,2,29,223,0,33,108,80,159,36,8,27,37,95,29,94,2,16,68,35,37, -107,101,114,110,101,108,11,29,94,2,16,69,35,37,109,105,110,45,115,116,120, -11,2,18,9,9,9,36,0}; - EVAL_ONE_SIZED_STR((char *)expr, 10423); +2,13,2,12,2,14,48,11,11,11,16,12,2,11,2,9,2,29,2,10,2, +5,2,28,2,27,2,4,2,26,2,6,2,25,2,2,16,12,11,11,11,11, +11,11,11,11,11,11,11,11,16,12,2,11,2,9,2,29,2,10,2,5,2, +28,2,27,2,4,2,26,2,6,2,25,2,2,48,48,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,28,20, +15,16,2,88,163,8,36,37,51,16,2,8,240,0,128,0,0,8,240,1,128, +0,0,2,30,223,0,33,50,80,159,36,8,31,39,20,15,16,2,88,163,8, +36,37,56,16,2,44,8,240,0,64,0,0,2,30,223,0,33,51,80,159,36, +8,30,39,20,15,16,2,88,163,8,36,37,51,16,2,44,8,128,128,2,30, +223,0,33,52,80,159,36,8,29,39,20,15,16,2,88,163,8,36,37,51,16, +2,44,8,128,64,2,30,223,0,33,53,80,159,36,8,28,39,20,15,16,2, +32,0,88,163,36,37,45,11,2,2,222,33,54,80,159,36,36,37,20,15,16, +2,249,22,132,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,55,80,159,36,38,37,20,15,16,2,20,25,96, +2,5,88,163,8,36,39,8,24,52,9,223,0,33,62,88,163,36,38,47,44, +9,223,0,33,63,88,163,36,37,46,44,9,223,0,33,64,80,159,36,39,37, +20,15,16,2,27,248,22,132,15,248,22,144,8,27,28,249,22,140,9,247,22, +152,8,2,32,6,1,1,59,6,1,1,58,250,22,178,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,6,223,0,33,68,80,159,36,40,37,20,15,16,2,32,0, +88,163,8,36,38,50,11,2,7,222,33,69,80,159,36,41,37,20,15,16,2, +32,0,88,163,8,36,39,51,11,2,8,222,33,71,80,159,36,42,37,20,15, +16,2,88,163,45,38,51,8,128,4,2,9,223,0,33,74,80,159,36,43,37, +20,15,16,2,88,163,45,39,52,8,128,4,2,11,223,0,33,77,80,159,36, +45,37,20,15,16,2,248,22,188,14,70,108,105,110,107,115,45,102,105,108,101, +80,159,36,46,37,20,15,16,2,247,22,133,2,80,158,36,47,20,15,16,2, +2,78,80,158,36,48,20,15,16,2,248,80,159,37,50,37,88,163,36,36,49, +8,240,8,128,1,0,9,223,1,33,79,80,159,36,49,37,20,15,16,2,247, +22,133,2,80,158,36,53,20,15,16,2,2,78,80,158,36,54,20,15,16,2, +88,163,36,37,44,8,240,0,188,23,0,2,22,223,0,33,90,80,159,36,55, +37,20,15,16,2,88,163,36,38,56,8,240,0,0,32,0,2,23,223,0,33, +92,80,159,36,57,37,20,15,16,2,88,163,36,41,8,24,8,240,0,32,40, +0,2,10,223,0,33,99,80,159,36,44,37,20,15,16,2,32,0,88,163,36, +39,50,11,2,24,222,33,100,80,159,36,58,37,20,15,16,2,32,0,88,163, +36,38,53,11,2,25,222,33,101,80,159,36,59,37,20,15,16,2,32,0,88, +163,36,38,54,11,2,26,222,33,102,80,159,36,8,24,37,20,15,16,2,32, +0,88,163,36,37,44,11,2,27,222,33,103,80,159,36,8,25,37,20,15,16, +2,20,25,96,2,28,88,163,36,36,53,16,2,52,8,128,64,9,223,0,33, +104,88,163,36,37,54,16,2,52,8,128,128,9,223,0,33,105,88,163,36,38, +55,16,2,52,8,240,0,64,0,0,9,223,0,33,106,80,159,36,8,26,37, +20,15,16,2,88,163,8,36,39,54,16,2,44,8,240,0,128,0,0,2,29, +223,0,33,108,80,159,36,8,27,37,95,29,94,2,16,68,35,37,107,101,114, +110,101,108,11,29,94,2,16,69,35,37,109,105,110,45,115,116,120,11,2,18, +9,9,9,36,0}; + EVAL_ONE_SIZED_STR((char *)expr, 10420); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,54,0,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,55,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,178,1, +0,75,0,97,0,120,0,140,0,162,0,169,0,176,0,183,0,0,0,175,1, 0,0,74,35,37,112,108,97,99,101,45,115,116,114,117,99,116,1,23,115,116, 114,117,99,116,58,84,72,45,112,108,97,99,101,45,99,104,97,110,110,101,108, 76,84,72,45,112,108,97,99,101,45,99,104,97,110,110,101,108,77,84,72,45, @@ -610,29 +611,29 @@ 112,108,97,99,101,45,99,104,97,110,110,101,108,45,105,110,1,20,84,72,45, 112,108,97,99,101,45,99,104,97,110,110,101,108,45,111,117,116,249,80,158,38, 39,195,36,249,80,158,38,39,195,36,249,80,158,38,39,195,37,159,36,20,112, -159,36,16,1,11,16,0,20,26,142,2,1,2,1,29,11,11,11,11,11,10, +159,36,16,1,11,16,0,20,26,141,2,1,2,1,29,11,11,11,11,11,10, 45,80,158,36,36,20,112,159,36,16,7,2,2,2,3,2,4,2,5,2,6, -2,7,2,8,16,0,16,0,36,16,0,36,16,2,2,5,2,6,38,11,11, -39,36,11,11,16,5,2,3,2,7,2,8,2,4,2,2,16,5,11,11,11, -11,11,16,5,2,3,2,7,2,8,2,4,2,2,41,41,37,11,11,16,0, -16,0,16,0,36,36,11,11,11,16,0,16,0,16,0,36,36,16,0,16,2, -20,15,16,6,253,22,176,10,2,3,11,38,36,11,248,22,83,249,22,73,22, -164,10,88,163,36,37,45,44,9,223,9,33,9,80,159,36,36,37,80,159,36, -37,37,80,159,36,38,37,80,159,36,39,37,80,159,36,40,37,20,15,16,3, -249,22,7,88,163,36,37,45,44,9,223,2,33,10,88,163,36,37,45,44,9, -223,2,33,11,80,159,36,41,37,80,159,36,42,37,93,29,94,65,113,117,111, -116,101,68,35,37,107,101,114,110,101,108,11,9,9,9,36,0}; - EVAL_ONE_SIZED_STR((char *)expr, 499); +2,7,2,8,16,0,37,39,36,16,0,36,16,2,2,5,2,6,38,11,11, +11,16,5,2,3,2,7,2,8,2,4,2,2,16,5,11,11,11,11,11,16, +5,2,3,2,7,2,8,2,4,2,2,41,41,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,2,20,15,16, +6,253,22,176,10,2,3,11,38,36,11,248,22,83,249,22,73,22,164,10,88, +163,36,37,45,44,9,223,9,33,9,80,159,36,36,37,80,159,36,37,37,80, +159,36,38,37,80,159,36,39,37,80,159,36,40,37,20,15,16,3,249,22,7, +88,163,36,37,45,44,9,223,2,33,10,88,163,36,37,45,44,9,223,2,33, +11,80,159,36,41,37,80,159,36,42,37,93,29,94,65,113,117,111,116,101,68, +35,37,107,101,114,110,101,108,11,9,9,9,36,0}; + EVAL_ONE_SIZED_STR((char *)expr, 496); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,54,0,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,55,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,65,0,0,0,1,0,0,7,0,18,0,45, 0,51,0,64,0,73,0,80,0,102,0,124,0,150,0,158,0,170,0,185,0, 201,0,219,0,239,0,251,0,11,1,34,1,46,1,77,1,84,1,89,1,94, 1,99,1,104,1,109,1,118,1,123,1,127,1,135,1,144,1,152,1,213,1, 60,2,81,2,102,2,132,2,162,2,220,2,22,3,71,3,120,3,54,9,105, 9,168,9,187,9,201,9,103,10,116,10,250,10,36,12,159,12,165,12,179,12, -206,12,226,12,30,13,117,13,119,13,188,13,16,20,69,20,93,20,0,0,185, +206,12,226,12,30,13,117,13,119,13,188,13,16,20,69,20,93,20,0,0,182, 23,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,29,94,2,4,67,35,37,117,116, @@ -882,7 +883,7 @@ 22,178,4,80,159,37,54,38,248,22,158,5,80,159,37,37,39,248,22,181,13, 80,159,37,42,39,20,18,159,11,80,158,36,53,248,80,159,37,8,25,37,249, 22,27,11,80,159,39,55,37,159,36,20,112,159,36,16,1,11,16,0,20,26, -142,2,1,2,1,29,11,11,11,11,11,10,38,80,158,36,36,20,112,159,40, +141,2,1,2,1,29,11,11,11,11,11,10,38,80,158,36,36,20,112,159,40, 16,26,2,2,2,3,30,2,5,72,112,97,116,104,45,115,116,114,105,110,103, 63,11,30,2,5,75,112,97,116,104,45,97,100,100,45,115,117,102,102,105,120, 8,30,2,7,2,8,6,30,2,7,1,23,101,120,116,101,110,100,45,112,97, @@ -892,59 +893,59 @@ 45,115,117,102,102,105,120,10,30,2,5,73,102,105,110,100,45,99,111,108,45, 102,105,108,101,3,30,2,5,76,110,111,114,109,97,108,45,99,97,115,101,45, 112,97,116,104,7,2,23,2,24,30,2,22,74,114,101,112,97,114,97,109,101, -116,101,114,105,122,101,7,16,0,16,0,36,16,0,36,16,14,2,15,2,16, +116,101,114,105,122,101,7,16,0,37,39,36,16,0,36,16,14,2,15,2,16, 2,10,2,12,2,17,2,18,2,11,2,3,2,9,2,2,2,13,2,14,2, -19,2,21,50,11,11,39,36,11,11,16,3,2,23,2,20,2,24,16,3,11, -11,11,16,3,2,23,2,20,2,24,39,39,37,11,11,16,0,16,0,16,0, -36,36,11,11,11,16,0,16,0,16,0,36,36,16,0,16,21,20,15,16,2, -88,163,36,37,45,8,128,128,9,223,0,33,32,80,159,36,8,29,39,20,15, -16,2,88,163,8,36,37,45,8,240,0,0,1,0,9,223,0,33,33,80,159, -36,8,28,39,20,15,16,2,88,163,36,37,49,8,240,0,0,16,0,72,112, -97,116,104,45,115,115,45,62,114,107,116,223,0,33,34,80,159,36,8,27,39, -20,15,16,2,88,163,36,37,49,8,240,0,192,0,0,67,103,101,116,45,100, -105,114,223,0,33,35,80,159,36,8,26,39,20,15,16,2,248,22,152,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,38,8,61,2,3,223,0,33,44,80,159,36,37,37,20,15,16,2,32, -0,88,163,8,36,37,42,11,2,9,222,192,80,159,36,42,37,20,15,16,2, -247,22,136,2,80,159,36,43,37,20,15,16,2,8,128,8,80,159,36,44,37, -20,15,16,2,249,22,156,8,8,128,8,11,80,159,36,45,37,20,15,16,2, -88,163,8,36,37,50,8,128,8,2,13,223,0,33,45,80,159,36,46,37,20, -15,16,2,88,163,8,36,38,55,8,128,8,2,14,223,0,33,46,80,159,36, -47,37,20,15,16,2,247,22,69,80,159,36,48,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,49,37,20, -15,16,2,11,80,158,36,50,20,15,16,2,11,80,158,36,51,20,15,16,2, -32,0,88,163,36,38,8,25,11,2,19,222,33,52,80,159,36,52,37,20,15, -16,2,11,80,158,36,53,20,15,16,2,27,11,20,19,158,36,90,159,37,10, -89,161,37,36,10,20,25,96,2,21,88,163,8,36,37,51,8,128,2,9,224, -2,1,33,53,88,163,36,39,49,11,9,223,0,33,54,88,163,36,40,8,38, -16,2,8,176,218,8,187,241,9,224,2,1,33,62,207,80,159,36,54,37,20, -15,16,2,88,163,36,36,45,8,240,66,0,14,2,2,23,223,0,33,63,80, -159,36,59,37,20,15,16,2,88,163,8,36,36,45,8,240,0,0,10,2,2, -24,223,0,33,64,80,159,36,8,24,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, -5,2,22,9,9,9,36,0}; - EVAL_ONE_SIZED_STR((char *)expr, 6244); +19,2,21,50,11,11,11,16,3,2,23,2,20,2,24,16,3,11,11,11,16, +3,2,23,2,20,2,24,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,21,20,15,16,2,88,163,36, +37,45,8,128,128,9,223,0,33,32,80,159,36,8,29,39,20,15,16,2,88, +163,8,36,37,45,8,240,0,0,1,0,9,223,0,33,33,80,159,36,8,28, +39,20,15,16,2,88,163,36,37,49,8,240,0,0,16,0,72,112,97,116,104, +45,115,115,45,62,114,107,116,223,0,33,34,80,159,36,8,27,39,20,15,16, +2,88,163,36,37,49,8,240,0,192,0,0,67,103,101,116,45,100,105,114,223, +0,33,35,80,159,36,8,26,39,20,15,16,2,248,22,152,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,38, +8,61,2,3,223,0,33,44,80,159,36,37,37,20,15,16,2,32,0,88,163, +8,36,37,42,11,2,9,222,192,80,159,36,42,37,20,15,16,2,247,22,136, +2,80,159,36,43,37,20,15,16,2,8,128,8,80,159,36,44,37,20,15,16, +2,249,22,156,8,8,128,8,11,80,159,36,45,37,20,15,16,2,88,163,8, +36,37,50,8,128,8,2,13,223,0,33,45,80,159,36,46,37,20,15,16,2, +88,163,8,36,38,55,8,128,8,2,14,223,0,33,46,80,159,36,47,37,20, +15,16,2,247,22,69,80,159,36,48,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,49,37,20,15,16,2, +11,80,158,36,50,20,15,16,2,11,80,158,36,51,20,15,16,2,32,0,88, +163,36,38,8,25,11,2,19,222,33,52,80,159,36,52,37,20,15,16,2,11, +80,158,36,53,20,15,16,2,27,11,20,19,158,36,90,159,37,10,89,161,37, +36,10,20,25,96,2,21,88,163,8,36,37,51,8,128,2,9,224,2,1,33, +53,88,163,36,39,49,11,9,223,0,33,54,88,163,36,40,8,38,16,2,8, +176,218,8,187,241,9,224,2,1,33,62,207,80,159,36,54,37,20,15,16,2, +88,163,36,36,45,8,240,66,0,14,2,2,23,223,0,33,63,80,159,36,59, +37,20,15,16,2,88,163,8,36,36,45,8,240,0,0,10,2,2,24,223,0, +33,64,80,159,36,8,24,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,5,2,22, +9,9,9,36,0}; + EVAL_ONE_SIZED_STR((char *)expr, 6241); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,54,0,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,49,46,51,46,55,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,97,1,0,0, +0,44,0,58,0,78,0,90,0,104,0,118,0,170,0,0,0,94,1,0,0, 69,35,37,98,117,105,108,116,105,110,65,113,117,111,116,101,29,94,2,2,67, 35,37,117,116,105,108,115,11,29,94,2,2,69,35,37,110,101,116,119,111,114, 107,11,29,94,2,2,68,35,37,112,97,114,97,109,122,11,29,94,2,2,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,56,78,0, +94,2,2,68,35,37,107,101,114,110,101,108,11,97,36,11,8,240,11,78,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,112,159,36,16,1,11,16,0,20,26,142,2,1,2,1,29, +16,0,159,36,20,112,159,36,16,1,11,16,0,20,26,141,2,1,2,1,29, 11,11,11,11,11,18,96,11,46,46,46,36,80,158,36,36,20,112,159,36,16, -0,16,0,16,0,36,16,0,36,16,0,36,11,11,39,36,11,11,16,0,16, -0,16,0,36,36,37,11,11,16,0,16,0,16,0,36,36,11,11,11,16,0, -16,0,16,0,36,36,16,0,16,0,104,2,9,2,8,29,94,2,2,69,35, -37,102,111,114,101,105,103,110,11,29,94,2,2,68,35,37,117,110,115,97,102, -101,11,29,94,2,2,69,35,37,102,108,102,120,110,117,109,11,2,7,2,6, -2,5,2,4,2,3,29,94,2,2,67,35,37,112,108,97,99,101,11,29,94, -2,2,69,35,37,102,117,116,117,114,101,115,11,9,9,9,36,0}; - EVAL_ONE_SIZED_STR((char *)expr, 416); +0,16,0,37,39,36,16,0,36,16,0,36,11,11,11,16,0,16,0,16,0, +36,36,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,0,104,2,9,2,8,29,94,2,2,69,35,37,102,111, +114,101,105,103,110,11,29,94,2,2,68,35,37,117,110,115,97,102,101,11,29, +94,2,2,69,35,37,102,108,102,120,110,117,109,11,2,7,2,6,2,5,2, +4,2,3,29,94,2,2,67,35,37,112,108,97,99,101,11,29,94,2,2,69, +35,37,102,117,116,117,114,101,115,11,9,9,9,36,0}; + EVAL_ONE_SIZED_STR((char *)expr, 413); } diff --git a/src/racket/src/env.c b/src/racket/src/env.c index 6dd71fbf8b..2a2681b85c 100644 --- a/src/racket/src/env.c +++ b/src/racket/src/env.c @@ -502,20 +502,22 @@ static Scheme_Env *place_instance_init(void *stack_base, int initial_main_os_thr return env; } +#ifdef MZ_USE_PLACES Scheme_Env *scheme_place_instance_init(void *stack_base, struct NewGC *parent_gc, intptr_t memory_limit) { Scheme_Env *env; -#if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES) +# if defined(MZ_PRECISE_GC) int *signal_fd; GC_construct_child_gc(parent_gc, memory_limit); -#endif +# endif env = place_instance_init(stack_base, 0); -#if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES) +# if defined(MZ_PRECISE_GC) signal_fd = scheme_get_signal_handle(); GC_set_put_external_event_fd(signal_fd); -#endif +# endif scheme_set_can_break(1); return env; } +#endif static void force_more_closed(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void *data) { @@ -835,6 +837,7 @@ scheme_new_module_env(Scheme_Env *env, Scheme_Module *m, int new_exp_module_tree scheme_prepare_label_env(env); menv->label_env = env->label_env; + menv->instance_env = env; if (new_exp_module_tree) { Scheme_Object *p; @@ -886,6 +889,7 @@ void scheme_prepare_exp_env(Scheme_Env *env) env->exp_env = eenv; eenv->template_env = env; eenv->label_env = env->label_env; + eenv->instance_env = env->instance_env; scheme_prepare_env_renames(env, mzMOD_RENAME_TOPLEVEL); eenv->rename_set = env->rename_set; @@ -929,6 +933,7 @@ void scheme_prepare_template_env(Scheme_Env *env) env->template_env = eenv; eenv->exp_env = env; eenv->label_env = env->label_env; + eenv->instance_env = env->instance_env; if (env->disallow_unbound) eenv->disallow_unbound = env->disallow_unbound; @@ -962,6 +967,7 @@ void scheme_prepare_label_env(Scheme_Env *env) lenv->exp_env = lenv; lenv->label_env = lenv; lenv->template_env = lenv; + lenv->instance_env = env->instance_env; } } @@ -981,7 +987,9 @@ Scheme_Env *scheme_copy_module_env(Scheme_Env *menv, Scheme_Env *ns, Scheme_Obje menv2->module_registry = ns->module_registry; menv2->insp = menv->insp; - if (menv->phase < clone_phase) + menv2->instance_env = menv2; + + if (menv->phase < clone_phase) menv2->syntax = menv->syntax; else { bucket_table = scheme_make_bucket_table(7, SCHEME_hash_ptr); @@ -992,11 +1000,21 @@ Scheme_Env *scheme_copy_module_env(Scheme_Env *menv, Scheme_Env *ns, Scheme_Obje menv2->mod_phase = menv->mod_phase; menv2->link_midx = menv->link_midx; if (menv->phase <= clone_phase) { - menv2->running = menv->running; menv2->ran = menv->ran; } - if (menv->phase < clone_phase) - menv2->et_running = menv->et_running; + if (menv->mod_phase == 0) { + char *running; + int amt; + running = (char *)scheme_malloc_atomic(menv->module->num_phases); + menv2->running = running; + memset(running, 0, menv->module->num_phases); + amt = (clone_phase - menv->phase) + 1; + if (amt > 0) { + if (amt > menv->module->num_phases) + amt = menv->module->num_phases; + memcpy(running, menv->running, amt); + } + } menv2->require_names = menv->require_names; menv2->et_require_names = menv->et_require_names; @@ -2299,18 +2317,12 @@ local_module_exports(int argc, Scheme_Object *argv[]) static Scheme_Object * local_module_definitions(int argc, Scheme_Object *argv[]) { - Scheme_Object *a[2]; - if (!scheme_current_thread->current_local_env || !scheme_current_thread->current_local_bindings) scheme_raise_exn(MZEXN_FAIL_CONTRACT, "syntax-local-module-defined-identifiers: not currently transforming module provides"); - a[0] = SCHEME_CDR(scheme_current_thread->current_local_bindings); - a[1] = SCHEME_CDR(a[0]); - a[0] = SCHEME_CAR(a[0]); - - return scheme_values(2, a); + return SCHEME_CDR(scheme_current_thread->current_local_bindings); } static Scheme_Object * diff --git a/src/racket/src/eval.c b/src/racket/src/eval.c index aa59ea2e20..7217d9b06f 100644 --- a/src/racket/src/eval.c +++ b/src/racket/src/eval.c @@ -1669,10 +1669,7 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro, save_runstack = scheme_push_prefix(dm_env->exp_env, rp, NULL, NULL, 1, 1, NULL, scheme_false); vals = scheme_eval_linked_expr_multi_with_dynamic_state(vals_expr, dyn_state); - if (defmacro == 2) - dm_env = NULL; - else - scheme_pop_prefix(save_runstack); + scheme_pop_prefix(save_runstack); } else { vals = _scheme_eval_linked_expr_multi(vals_expr); dm_env = NULL; @@ -1782,16 +1779,13 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro, } else name = NULL; - if (defmacro > 1) - scheme_pop_prefix(save_runstack); - { const char *symname; symname = (show_any ? scheme_symbol_name(name) : ""); scheme_wrong_return_arity((defmacro - ? (dm_env ? "define-syntaxes" : "define-values-for-syntax") + ? "define-syntaxes" : "define-values"), i, g, (g == 1) ? (Scheme_Object **)vals : scheme_current_thread->ku.multiple.array, @@ -2034,7 +2028,7 @@ static Scheme_Object *splice_execute(Scheme_Object *data) } } -static Scheme_Object *do_define_syntaxes_execute(Scheme_Object *expr, Scheme_Env *dm_env, int for_stx); +static Scheme_Object *do_define_syntaxes_execute(Scheme_Object *expr, Scheme_Env *dm_env); static void *define_syntaxes_execute_k(void) { @@ -2043,11 +2037,11 @@ static void *define_syntaxes_execute_k(void) Scheme_Env *dm_env = (Scheme_Env *)p->ku.k.p2; p->ku.k.p1 = NULL; p->ku.k.p2 = NULL; - return do_define_syntaxes_execute(form, dm_env, p->ku.k.i1); + return do_define_syntaxes_execute(form, dm_env); } static Scheme_Object * -do_define_syntaxes_execute(Scheme_Object *form, Scheme_Env *dm_env, int for_stx) +do_define_syntaxes_execute(Scheme_Object *form, Scheme_Env *dm_env) { Scheme_Thread *p = scheme_current_thread; Resolve_Prefix *rp; @@ -2068,7 +2062,6 @@ do_define_syntaxes_execute(Scheme_Object *form, Scheme_Env *dm_env, int for_stx) dm_env = scheme_environment_from_dummy(dummy); } p->ku.k.p2 = (Scheme_Object *)dm_env; - p->ku.k.i1 = for_stx; return (Scheme_Object *)scheme_enlarge_runstack(depth, define_syntaxes_execute_k); } @@ -2095,24 +2088,40 @@ do_define_syntaxes_execute(Scheme_Object *form, Scheme_Env *dm_env, int for_stx) scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); scheme_set_dynamic_state(&dyn_state, rhs_env, NULL, scheme_false, dm_env, dm_env->link_midx); - result = define_execute_with_dynamic_state(form, 4, for_stx ? 2 : 1, rp, dm_env, &dyn_state); + if (SAME_TYPE(SCHEME_TYPE(form), scheme_define_syntaxes_type)) { + result = define_execute_with_dynamic_state(form, 4, 1, rp, dm_env, &dyn_state); + } else { + Scheme_Object **save_runstack; + + form = SCHEME_VEC_ELS(form)[0]; + + 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); + form = SCHEME_CDR(form); + } + + scheme_pop_prefix(save_runstack); + } + scheme_pop_continuation_frame(&cframe); - return result; + return scheme_void; } } static Scheme_Object * define_syntaxes_execute(Scheme_Object *form) { - return do_define_syntaxes_execute(form, NULL, 0); + return do_define_syntaxes_execute(form, NULL); } static Scheme_Object * -define_for_syntaxes_execute(Scheme_Object *form) +begin_for_syntax_execute(Scheme_Object *form) { - return do_define_syntaxes_execute(form, NULL, 1); + return do_define_syntaxes_execute(form, NULL); } /*========================================================================*/ @@ -3444,10 +3453,10 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, v = define_syntaxes_execute(obj); break; } - case scheme_define_for_syntax_type: + case scheme_begin_for_syntax_type: { UPDATE_THREAD_RSPTR(); - v = define_for_syntaxes_execute(obj); + v = begin_for_syntax_execute(obj); break; } case scheme_set_bang_type: @@ -5179,7 +5188,7 @@ Scheme_Object *scheme_eval_clone(Scheme_Object *expr) return scheme_module_eval_clone(expr); break; case scheme_define_syntaxes_type: - case scheme_define_for_syntax_type: + case scheme_begin_for_syntax_type: return scheme_syntaxes_eval_clone(expr); default: return expr; diff --git a/src/racket/src/fun.c b/src/racket/src/fun.c index 37f6b37087..a22dd19585 100644 --- a/src/racket/src/fun.c +++ b/src/racket/src/fun.c @@ -119,7 +119,7 @@ THREAD_LOCAL_DECL(static Scheme_Object *cached_mod_stx); THREAD_LOCAL_DECL(static Scheme_Object *cached_mod_beg_stx); THREAD_LOCAL_DECL(static Scheme_Object *cached_dv_stx); THREAD_LOCAL_DECL(static Scheme_Object *cached_ds_stx); -THREAD_LOCAL_DECL(static Scheme_Object *cached_dvs_stx); +THREAD_LOCAL_DECL(static Scheme_Object *cached_bfs_stx); THREAD_LOCAL_DECL(static int cached_stx_phase); THREAD_LOCAL_DECL(static Scheme_Cont *offstack_cont); THREAD_LOCAL_DECL(static Scheme_Overflow *offstack_overflow); @@ -624,7 +624,7 @@ scheme_init_fun_places() REGISTER_SO(cached_mod_beg_stx); REGISTER_SO(cached_dv_stx); REGISTER_SO(cached_ds_stx); - REGISTER_SO(cached_dvs_stx); + REGISTER_SO(cached_bfs_stx); REGISTER_SO(offstack_cont); REGISTER_SO(offstack_overflow); } @@ -1550,7 +1550,7 @@ cert_with_specials(Scheme_Object *code, /* Arms (insp) or re-arms (old_stx) taints. */ { Scheme_Object *prop; - int next_cadr_deflt = 0; + int next_cadr_deflt = 0, phase_delta = 0; #ifdef DO_STACK_CHECK { @@ -1609,7 +1609,7 @@ cert_with_specials(Scheme_Object *code, name = scheme_stx_taint_disarm(code, NULL); name = SCHEME_STX_CAR(name); if (SCHEME_STX_SYMBOLP(name)) { - Scheme_Object *beg_stx, *mod_stx, *mod_beg_stx, *dv_stx, *ds_stx, *dvs_stx; + Scheme_Object *beg_stx, *mod_stx, *mod_beg_stx, *dv_stx, *ds_stx, *bfs_stx; if (!phase) { mod_stx = scheme_module_stx; @@ -1617,14 +1617,14 @@ cert_with_specials(Scheme_Object *code, mod_beg_stx = scheme_module_begin_stx; dv_stx = scheme_define_values_stx; ds_stx = scheme_define_syntaxes_stx; - dvs_stx = scheme_define_for_syntaxes_stx; + bfs_stx = scheme_begin_for_syntax_stx; } else if (phase == cached_stx_phase) { beg_stx = cached_beg_stx; mod_stx = cached_mod_stx; mod_beg_stx = cached_mod_beg_stx; dv_stx = cached_dv_stx; ds_stx = cached_ds_stx; - dvs_stx = cached_dvs_stx; + bfs_stx = cached_bfs_stx; } else { Scheme_Object *sr; sr = scheme_sys_wraps_phase(scheme_make_integer(phase)); @@ -1638,14 +1638,14 @@ cert_with_specials(Scheme_Object *code, sr, 0, 0); ds_stx = scheme_datum_to_syntax(SCHEME_STX_VAL(scheme_define_syntaxes_stx), scheme_false, sr, 0, 0); - dvs_stx = scheme_datum_to_syntax(SCHEME_STX_VAL(scheme_define_for_syntaxes_stx), scheme_false, + bfs_stx = scheme_datum_to_syntax(SCHEME_STX_VAL(scheme_begin_for_syntax_stx), scheme_false, sr, 0, 0); cached_beg_stx = beg_stx; cached_mod_stx = mod_stx; cached_mod_beg_stx = mod_beg_stx; cached_dv_stx = dv_stx; cached_ds_stx = ds_stx; - cached_dvs_stx = dvs_stx; + cached_bfs_stx = bfs_stx; cached_stx_phase = phase; } @@ -1654,9 +1654,12 @@ cert_with_specials(Scheme_Object *code, || scheme_stx_module_eq(mod_beg_stx, name, phase)) { trans = 1; next_cadr_deflt = 0; + } else if (scheme_stx_module_eq(bfs_stx, name, phase)) { + trans = 1; + next_cadr_deflt = 0; + phase_delta = 1; } else if (scheme_stx_module_eq(dv_stx, name, phase) - || scheme_stx_module_eq(ds_stx, name, phase) - || scheme_stx_module_eq(dvs_stx, name, phase)) { + || scheme_stx_module_eq(ds_stx, name, phase)) { trans = 1; next_cadr_deflt = 1; } @@ -1676,9 +1679,9 @@ cert_with_specials(Scheme_Object *code, Scheme_Object *a, *d, *v; a = SCHEME_STX_CAR(code); - a = cert_with_specials(a, insp, old_stx, phase, cadr_deflt, 0); + a = cert_with_specials(a, insp, old_stx, phase + phase_delta, cadr_deflt, 0); d = SCHEME_STX_CDR(code); - d = cert_with_specials(d, insp, old_stx, phase, 1, next_cadr_deflt); + d = cert_with_specials(d, insp, old_stx, phase + phase_delta, 1, next_cadr_deflt); v = scheme_make_pair(a, d); diff --git a/src/racket/src/jit.c b/src/racket/src/jit.c index 77ae9e551c..239a5f3b09 100644 --- a/src/racket/src/jit.c +++ b/src/racket/src/jit.c @@ -2364,7 +2364,7 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w case scheme_splice_sequence_type: case scheme_define_values_type: case scheme_define_syntaxes_type: - case scheme_define_for_syntax_type: + case scheme_begin_for_syntax_type: case scheme_require_form_type: case scheme_module_type: { diff --git a/src/racket/src/jitprep.c b/src/racket/src/jitprep.c index 594e6ca729..a335ae94d9 100644 --- a/src/racket/src/jitprep.c +++ b/src/racket/src/jitprep.c @@ -483,7 +483,7 @@ static Scheme_Object *define_syntaxes_jit(Scheme_Object *expr) return do_define_syntaxes_clone(expr, 1); } -static Scheme_Object *define_for_syntaxes_jit(Scheme_Object *expr) +static Scheme_Object *begin_for_syntax_jit(Scheme_Object *expr) { return do_define_syntaxes_clone(expr, 1); } @@ -583,8 +583,8 @@ Scheme_Object *scheme_jit_expr(Scheme_Object *expr) return define_values_jit(expr); case scheme_define_syntaxes_type: return define_syntaxes_jit(expr); - case scheme_define_for_syntax_type: - return define_for_syntaxes_jit(expr); + case scheme_begin_for_syntax_type: + return begin_for_syntax_jit(expr); case scheme_set_bang_type: return set_jit(expr); case scheme_boxenv_type: @@ -622,9 +622,26 @@ static Scheme_Object *do_define_syntaxes_clone(Scheme_Object *expr, int jit) rhs = SCHEME_VEC_ELS(expr)[0]; #ifdef MZ_USE_JIT - if (jit) - naya = scheme_jit_expr(rhs); - else + if (jit) { + if (SAME_TYPE(SCHEME_TYPE(expr), scheme_define_syntaxes_type)) + naya = scheme_jit_expr(rhs); + else { + int changed = 0; + Scheme_Object *a, *l = rhs; + naya = scheme_null; + while (!SCHEME_NULLP(l)) { + a = scheme_jit_expr(SCHEME_CAR(l)); + if (!SAME_OBJ(a, SCHEME_CAR(l))) + changed = 1; + naya = scheme_make_pair(a, naya); + l = SCHEME_CDR(l); + } + if (changed) + naya = scheme_reverse(naya); + else + naya = rhs; + } + } else #endif naya = rhs; diff --git a/src/racket/src/marshal.c b/src/racket/src/marshal.c index e042ffcdb9..c389cbe8d7 100644 --- a/src/racket/src/marshal.c +++ b/src/racket/src/marshal.c @@ -45,8 +45,8 @@ static Scheme_Object *read_define_values(Scheme_Object *obj); static Scheme_Object *write_define_values(Scheme_Object *obj); static Scheme_Object *read_define_syntaxes(Scheme_Object *obj); static Scheme_Object *write_define_syntaxes(Scheme_Object *obj); -static Scheme_Object *read_define_for_syntax(Scheme_Object *obj); -static Scheme_Object *write_define_for_syntax(Scheme_Object *obj); +static Scheme_Object *read_begin_for_syntax(Scheme_Object *obj); +static Scheme_Object *write_begin_for_syntax(Scheme_Object *obj); static Scheme_Object *read_set_bang(Scheme_Object *obj); static Scheme_Object *write_set_bang(Scheme_Object *obj); static Scheme_Object *read_boxenv(Scheme_Object *obj); @@ -125,8 +125,8 @@ void scheme_init_marshal(Scheme_Env *env) scheme_install_type_reader(scheme_define_values_type, read_define_values); scheme_install_type_writer(scheme_define_syntaxes_type, write_define_syntaxes); scheme_install_type_reader(scheme_define_syntaxes_type, read_define_syntaxes); - scheme_install_type_writer(scheme_define_for_syntax_type, write_define_for_syntax); - scheme_install_type_reader(scheme_define_for_syntax_type, read_define_for_syntax); + scheme_install_type_writer(scheme_begin_for_syntax_type, write_begin_for_syntax); + scheme_install_type_reader(scheme_begin_for_syntax_type, read_begin_for_syntax); scheme_install_type_writer(scheme_set_bang_type, write_set_bang); scheme_install_type_reader(scheme_set_bang_type, read_set_bang); scheme_install_type_writer(scheme_boxenv_type, write_boxenv); @@ -407,16 +407,16 @@ static Scheme_Object *write_define_syntaxes(Scheme_Object *obj) return write_define_values(obj); } -static Scheme_Object *read_define_for_syntax(Scheme_Object *obj) +static Scheme_Object *read_begin_for_syntax(Scheme_Object *obj) { if (!SCHEME_VECTORP(obj)) return NULL; obj = scheme_clone_vector(obj, 0, 0); - obj->type = scheme_define_for_syntax_type; + obj->type = scheme_begin_for_syntax_type; return obj; } -static Scheme_Object *write_define_for_syntax(Scheme_Object *obj) +static Scheme_Object *write_begin_for_syntax(Scheme_Object *obj) { return write_define_values(obj); } @@ -1125,8 +1125,8 @@ static Scheme_Object *write_module(Scheme_Object *obj) { Scheme_Module *m = (Scheme_Module *)obj; Scheme_Module_Phase_Exports *pt; - Scheme_Object *l, *v; - int i, k, count, cnt; + Scheme_Object *l, *v, *phase; + int i, j, k, count, cnt; l = scheme_null; cnt = 0; @@ -1147,22 +1147,27 @@ static Scheme_Object *write_module(Scheme_Object *obj) l = cons(m->et_requires, l); l = cons(m->requires, l); - l = cons(m->body, l); - l = cons(m->et_body, l); + for (j = 0; j < m->num_phases; j++) { + l = cons(m->bodies[j], l); + } cnt = 0; for (k = -3; k < (m->me->other_phases ? m->me->other_phases->size : 0); k++) { switch (k) { case -3: + phase = scheme_make_integer(-1); pt = m->me->dt; break; case -2: + phase = scheme_make_integer(1); pt = m->me->et; break; case -1: + phase = scheme_make_integer(0); pt = m->me->rt; break; default: + phase = m->me->other_phases->keys[k]; pt = (Scheme_Module_Phase_Exports *)m->me->other_phases->vals[k]; } @@ -1203,76 +1208,58 @@ static Scheme_Object *write_module(Scheme_Object *obj) if (pt->provide_src_phases) { v = scheme_make_vector(count, NULL); for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = (pt->provide_src_phases[i] ? scheme_true : scheme_false); + SCHEME_VEC_ELS(v)[i] = scheme_make_integer(pt->provide_src_phases[i]); } } else v = scheme_false; l = cons(v, l); + if ((SCHEME_INT_VAL(phase) >= 0) && (SCHEME_INT_VAL(phase) < m->num_phases)) { + Scheme_Module_Export_Info *exp_info = m->exp_infos[SCHEME_INT_VAL(phase)]; + + if (exp_info) { + v = scheme_false; + + if (exp_info->provide_protects) { + for (i = 0; i < count; i++) { + if (exp_info->provide_protects[i]) + break; + } + if (i < count) { + v = scheme_make_vector(count, NULL); + for (i = 0; i < count; i++) { + SCHEME_VEC_ELS(v)[i] = (exp_info->provide_protects[i] ? scheme_true : scheme_false); + } + } + } + l = cons(v, l); + + count = exp_info->num_indirect_provides; + l = cons(scheme_make_integer(count), l); + v = scheme_make_vector(count, NULL); + for (i = 0; i < count; i++) { + SCHEME_VEC_ELS(v)[i] = exp_info->indirect_provides[i]; + } + l = cons(v, l); + + count = exp_info->num_indirect_syntax_provides; + l = cons(scheme_make_integer(count), l); + v = scheme_make_vector(count, NULL); + for (i = 0; i < count; i++) { + SCHEME_VEC_ELS(v)[i] = exp_info->indirect_syntax_provides[i]; + } + l = cons(v, l); + } else + l = cons(scheme_void, l); + } else + l = cons(scheme_void, l); + l = cons(pt->phase_index, l); cnt++; } } - l = cons(scheme_make_integer(cnt), l); - - count = m->me->rt->num_provides; - if (m->provide_protects) { - for (i = 0; i < count; i++) { - if (m->provide_protects[i]) - break; - } - if (i < count) { - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = (m->provide_protects[i] ? scheme_true : scheme_false); - } - } else - v = scheme_false; - l = cons(v, l); - } else - l = cons(scheme_false, l); - - count = m->me->et->num_provides; - if (m->et_provide_protects) { - for (i = 0; i < count; i++) { - if (m->et_provide_protects[i]) - break; - } - if (i < count) { - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = (m->et_provide_protects[i] ? scheme_true : scheme_false); - } - } else - v = scheme_false; - l = cons(v, l); - } else - l = cons(scheme_false, l); - - count = m->num_indirect_provides; - l = cons(scheme_make_integer(count), l); - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = m->indirect_provides[i]; - } - l = cons(v, l); - - count = m->num_indirect_syntax_provides; - l = cons(scheme_make_integer(count), l); - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = m->indirect_syntax_provides[i]; - } - l = cons(v, l); - - count = m->num_indirect_et_provides; - l = cons(scheme_make_integer(count), l); - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = m->et_indirect_provides[i]; - } - l = cons(v, l); + l = cons(scheme_make_integer(m->num_phases), l); l = cons((Scheme_Object *)m->prefix, l); l = cons(m->dummy, l); @@ -1318,12 +1305,14 @@ static int check_requires_ok(Scheme_Object *l) static Scheme_Object *read_module(Scheme_Object *obj) { Scheme_Module *m; - Scheme_Object *ie, *nie; - Scheme_Object *eesp, *esp, *esn, *esph, *es, *esnom, *e, *nve, *ne, **v; + Scheme_Object *ie, *nie, **bodies; + Scheme_Object *esp, *esn, *esph, *es, *esnom, *e, *nve, *ne, **v; Scheme_Module_Exports *me; Scheme_Module_Phase_Exports *pt; - char *ps, *sps; - int i, count, cnt; + Scheme_Module_Export_Info **exp_infos, *exp_info; + char *ps; + int *sps; + int i, j, count, cnt; m = MALLOC_ONE_TAGGED(Scheme_Module); m->so.type = scheme_module_type; @@ -1387,67 +1376,21 @@ static Scheme_Object *read_module(Scheme_Object *obj) obj = SCHEME_CDR(obj); if (!SCHEME_PAIRP(obj)) return_NULL(); - ie = SCHEME_CAR(obj); + cnt = SCHEME_INT_VAL(SCHEME_CAR(obj)); obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return_NULL(); - nie = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - count = SCHEME_INT_VAL(nie); + if (cnt < 1) return_NULL(); - if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL(); - v = MALLOC_N(Scheme_Object *, count); - for (i = 0; i < count; i++) { - v[i] = SCHEME_VEC_ELS(ie)[i]; + m->num_phases = cnt; + exp_infos = MALLOC_N(Scheme_Module_Export_Info *, cnt); + while (cnt--) { + exp_info = MALLOC_ONE_RT(Scheme_Module_Export_Info); + SET_REQUIRED_TAG(exp_info->type = scheme_rt_export_info); + exp_infos[cnt] = exp_info; } - m->et_indirect_provides = v; - m->num_indirect_et_provides = count; - - if (!SCHEME_PAIRP(obj)) return_NULL(); - ie = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - nie = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); + m->exp_infos = exp_infos; + cnt = m->num_phases; - count = SCHEME_INT_VAL(nie); - - if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL(); - v = MALLOC_N(Scheme_Object *, count); - for (i = 0; i < count; i++) { - v[i] = SCHEME_VEC_ELS(ie)[i]; - } - m->indirect_syntax_provides = v; - m->num_indirect_syntax_provides = count; - - if (!SCHEME_PAIRP(obj)) return_NULL(); - ie = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - nie = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - count = SCHEME_INT_VAL(nie); - - if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL(); - v = MALLOC_N(Scheme_Object *, count); - for (i = 0; i < count; i++) { - v[i] = SCHEME_VEC_ELS(ie)[i]; - } - m->indirect_provides = v; - m->num_indirect_provides = count; - - if (!SCHEME_PAIRP(obj)) return_NULL(); - eesp = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - esp = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return_NULL(); cnt = SCHEME_INT_VAL(SCHEME_CAR(obj)); obj = SCHEME_CDR(obj); @@ -1482,6 +1425,67 @@ static Scheme_Object *read_module(Scheme_Object *obj) scheme_hash_set(me->other_phases, phase, (Scheme_Object *)pt); } + if (!SCHEME_PAIRP(obj)) return_NULL(); + ie = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + if (SCHEME_VOIDP(ie)) { + /* no exp_infos entry */ + count = -1; + } else { + if (!SCHEME_INTP(phase) || (SCHEME_INT_VAL(phase) < 0) + || (SCHEME_INT_VAL(phase) >= m->num_phases)) + return_NULL(); + exp_info = m->exp_infos[SCHEME_INT_VAL(phase)]; + + if (!SCHEME_PAIRP(obj)) return_NULL(); + nie = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + count = SCHEME_INT_VAL(nie); + if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL(); + v = MALLOC_N(Scheme_Object *, count); + for (i = 0; i < count; i++) { + v[i] = SCHEME_VEC_ELS(ie)[i]; + } + exp_info->indirect_syntax_provides = v; + exp_info->num_indirect_syntax_provides = count; + + if (!SCHEME_PAIRP(obj)) return_NULL(); + ie = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + nie = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + count = SCHEME_INT_VAL(nie); + + if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL(); + v = MALLOC_N(Scheme_Object *, count); + for (i = 0; i < count; i++) { + v[i] = SCHEME_VEC_ELS(ie)[i]; + } + exp_info->indirect_provides = v; + exp_info->num_indirect_provides = count; + + if (!SCHEME_PAIRP(obj)) return_NULL(); + esp = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + if (SCHEME_FALSEP(esp)) { + exp_info->provide_protects = NULL; + count = -1; + } else { + if (!SCHEME_VECTORP(esp)) return_NULL(); + count = SCHEME_VEC_SIZE(esp); + ps = MALLOC_N_ATOMIC(char, count); + for (i = 0; i < count; i++) { + ps[i] = SCHEME_TRUEP(SCHEME_VEC_ELS(esp)[i]); + } + exp_info->provide_protects = ps; + } + } + if (!SCHEME_PAIRP(obj)) return_NULL(); esph = SCHEME_CAR(obj); obj = SCHEME_CDR(obj); @@ -1510,6 +1514,8 @@ static Scheme_Object *read_module(Scheme_Object *obj) ne = SCHEME_CAR(obj); obj = SCHEME_CDR(obj); + if ((count != -1) && (SCHEME_INT_VAL(ne) != count)) return_NULL(); + count = SCHEME_INT_VAL(ne); pt->num_provides = count; pt->num_var_provides = SCHEME_INT_VAL(nve); @@ -1550,9 +1556,9 @@ static Scheme_Object *read_module(Scheme_Object *obj) sps = NULL; else { if (!SCHEME_VECTORP(esph) || (SCHEME_VEC_SIZE(esph) != count)) return_NULL(); - sps = MALLOC_N_ATOMIC(char, count); + sps = MALLOC_N_ATOMIC(int, count); for (i = 0; i < count; i++) { - sps[i] = SCHEME_TRUEP(SCHEME_VEC_ELS(esph)[i]); + sps[i] = SCHEME_INT_VAL(SCHEME_VEC_ELS(esph)[i]); } } pt->provide_src_phases = sps; @@ -1560,55 +1566,40 @@ static Scheme_Object *read_module(Scheme_Object *obj) count = me->rt->num_provides; - if (SCHEME_FALSEP(esp)) { - m->provide_protects = NULL; - } else { - if (!SCHEME_VECTORP(esp) || (SCHEME_VEC_SIZE(esp) != count)) return_NULL(); - ps = MALLOC_N_ATOMIC(char, count); - for (i = 0; i < count; i++) { - ps[i] = SCHEME_TRUEP(SCHEME_VEC_ELS(esp)[i]); - } - m->provide_protects = ps; - } - - if (SCHEME_FALSEP(eesp)) { - m->et_provide_protects = NULL; - } else { - if (!SCHEME_VECTORP(eesp) || (SCHEME_VEC_SIZE(eesp) != count)) return_NULL(); - ps = MALLOC_N_ATOMIC(char, count); - for (i = 0; i < count; i++) { - ps[i] = SCHEME_TRUEP(SCHEME_VEC_ELS(eesp)[i]); - } - m->et_provide_protects = ps; - } - - if (!SCHEME_PAIRP(obj)) return_NULL(); - e = SCHEME_CAR(obj); - if (!SCHEME_VECTORP(e)) return_NULL(); - m->et_body = e; - for (i = SCHEME_VEC_SIZE(e); i--; ) { - e = SCHEME_VEC_ELS(m->et_body)[i]; + bodies = MALLOC_N(Scheme_Object*, m->num_phases); + m->bodies = bodies; + for (j = m->num_phases; j--; ) { + if (!SCHEME_PAIRP(obj)) return_NULL(); + e = SCHEME_CAR(obj); if (!SCHEME_VECTORP(e)) return_NULL(); - /* SCHEME_VEC_ELS(e)[1] should be code */ - if (!SCHEME_INTP(SCHEME_VEC_ELS(e)[2])) return_NULL(); - if (!SAME_TYPE(SCHEME_TYPE(SCHEME_VEC_ELS(e)[3]), scheme_resolve_prefix_type)) - return_NULL(); - e = SCHEME_VEC_ELS(e)[0]; - if (!SCHEME_SYMBOLP(e)) { - while (SCHEME_PAIRP(e)) { - if (!SCHEME_SYMBOLP(SCHEME_CAR(e))) return_NULL(); - e = SCHEME_CDR(e); + if (j) { + bodies[j] = e; + for (i = SCHEME_VEC_SIZE(e); i--; ) { + e = SCHEME_VEC_ELS(bodies[j])[i]; + if (!SCHEME_VECTORP(e)) return_NULL(); + if (SCHEME_VEC_SIZE(e) != 5) return_NULL(); + /* SCHEME_VEC_ELS(e)[1] should be code */ + if (!SCHEME_INTP(SCHEME_VEC_ELS(e)[2])) return_NULL(); + if (!SAME_TYPE(SCHEME_TYPE(SCHEME_VEC_ELS(e)[3]), scheme_resolve_prefix_type)) + return_NULL(); + if (SCHEME_FALSEP(SCHEME_VEC_ELS(e)[0])) { + if (SCHEME_FALSEP(SCHEME_VEC_ELS(e)[4])) return_NULL(); + } else { + e = SCHEME_VEC_ELS(e)[0]; + if (!SCHEME_SYMBOLP(e)) { + while (SCHEME_PAIRP(e)) { + if (!SCHEME_SYMBOLP(SCHEME_CAR(e))) return_NULL(); + e = SCHEME_CDR(e); + } + if (!SCHEME_NULLP(e)) return_NULL(); + } + } } - if (!SCHEME_NULLP(e)) return_NULL(); + } else { + bodies[j] = e; } + obj = SCHEME_CDR(obj); } - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - e = SCHEME_CAR(obj); - if (!SCHEME_VECTORP(e)) return_NULL(); - m->body = e; - obj = SCHEME_CDR(obj); if (!SCHEME_PAIRP(obj)) return_NULL(); if (scheme_proper_list_length(SCHEME_CAR(obj)) < 0) return_NULL(); diff --git a/src/racket/src/module.c b/src/racket/src/module.c index e1a432fc6e..a90271aab6 100644 --- a/src/racket/src/module.c +++ b/src/racket/src/module.c @@ -90,16 +90,51 @@ static Scheme_Object *provide_expand(Scheme_Object *form, Scheme_Comp_Env *env, static Scheme_Module *module_load(Scheme_Object *modname, Scheme_Env *env, const char *who); static void run_module(Scheme_Env *menv, int set_ns); -static void run_module_exptime(Scheme_Env *menv, int set_ns); +static void run_module_exptime(Scheme_Env *menv, int phase); static void eval_exptime(Scheme_Object *names, int count, Scheme_Object *expr, Scheme_Env *genv, Scheme_Comp_Env *env, Resolve_Prefix *rp, int let_depth, int shift, - Scheme_Bucket_Table *syntax, int for_stx, + Scheme_Bucket_Table *syntax, int at_phase, Scheme_Object *free_id_rename_rn, Scheme_Object *insp); +typedef struct Module_Begin_Expand_State { + /* All pointers, because it's allocated with scheme_malloc(): */ + Scheme_Object *post_ex_rn_set; + Scheme_Hash_Table *tables; /* phase -> (vector toplevels requires syntaxes) */ + Scheme_Hash_Table *all_provided; /* phase -> table like `provided' */ + Scheme_Hash_Table *all_reprovided; /* phase -> list of (list modidx syntax except-name ...) */ + Scheme_Hash_Tree *all_defs; /* phase -> list of sxtid */ + Scheme_Hash_Table *all_defs_out; /* phase -> list of (cons protected? (stx-list except-name ...)) */ + int *all_simple_renames; + int *_num_phases; + Scheme_Object *saved_provides; /* list of (cons form phase) */ + Scheme_Hash_Table *modidx_cache; + Scheme_Object *redef_modname; +} Module_Begin_Expand_State; + +static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Compile_Expand_Info *rec, int drec, + Scheme_Compile_Expand_Info *erec, int derec, + int phase, Scheme_Object *body_lists, + Module_Begin_Expand_State *bxs); + +static Scheme_Object *expand_all_provides(Scheme_Object *form, + Scheme_Comp_Env *cenv, + Scheme_Compile_Expand_Info *rec, int drec, + Scheme_Object *self_modidx, + Module_Begin_Expand_State *bxs, + int keep_expanded); + +static Scheme_Object *fixup_expanded_provides(Scheme_Object *expanded_l, + Scheme_Object *expanded_provides, + int phase); + +static void check_formerly_unbound(Scheme_Object *unbounds, Scheme_Comp_Env *env); +static void install_stops(Scheme_Comp_Env *xenv, int phase, Scheme_Object **sv); + static Scheme_Object *scheme_sys_wraps_phase_worker(intptr_t p); #define cons scheme_make_pair @@ -153,7 +188,7 @@ READ_ONLY Scheme_Object *scheme_begin_stx; READ_ONLY Scheme_Object *scheme_define_values_stx; READ_ONLY Scheme_Object *scheme_define_syntaxes_stx; READ_ONLY Scheme_Object *scheme_top_stx; -READ_ONLY Scheme_Object *scheme_define_for_syntaxes_stx; +READ_ONLY Scheme_Object *scheme_begin_for_syntax_stx; READ_ONLY static Scheme_Object *modbeg_syntax; READ_ONLY static Scheme_Object *require_stx; READ_ONLY static Scheme_Object *provide_stx; @@ -209,7 +244,7 @@ typedef void (*Check_Func)(Scheme_Object *prnt_name, Scheme_Object *name, Scheme_Object *err_src, Scheme_Object *mark_src, Scheme_Object *to_phase, Scheme_Object *src_phase_index, Scheme_Object *nominal_export_phase); -static void parse_requires(Scheme_Object *form, +static void parse_requires(Scheme_Object *form, int at_phase, Scheme_Object *base_modidx, Scheme_Env *env, Scheme_Module *for_m, @@ -221,35 +256,37 @@ static void parse_requires(Scheme_Object *form, int *all_simple, Scheme_Hash_Table *modix_cache); static void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e, + int at_phase, Scheme_Hash_Table *all_provided, Scheme_Hash_Table *all_reprovided, Scheme_Object *self_modidx, - Scheme_Object **_all_defs_out, - Scheme_Object **_et_all_defs_out, + Scheme_Hash_Table *all_defs_out, Scheme_Hash_Table *tables, - Scheme_Object *all_defs, Scheme_Object *all_et_defs, + Scheme_Hash_Tree *all_defs, Scheme_Comp_Env *cenv, Scheme_Compile_Info *rec, int drec, - Scheme_Object **_expanded); + Scheme_Object **_expanded, + Scheme_Object *begin_stx); static int compute_reprovides(Scheme_Hash_Table *all_provided, Scheme_Hash_Table *all_reprovided, Scheme_Module *mod_for_requires, Scheme_Hash_Table *tables, Scheme_Env *genv, - Scheme_Object *all_rt_defs, Scheme_Object *all_rt_defs_out, - Scheme_Object *all_et_defs, Scheme_Object *all_et_defs_out, + int num_phases, + Scheme_Hash_Tree *all_defs, Scheme_Hash_Table *all_defs_out, const char *matching_form, Scheme_Object *all_mods, Scheme_Object *all_phases); -static char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table *tables, - Scheme_Module_Exports *me, - Scheme_Env *genv, - Scheme_Object *form, - char **_phase1_protects); +static void compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table *tables, + Scheme_Module_Exports *me, + Scheme_Env *genv, + Scheme_Object *form, + int num_phases, Scheme_Module_Export_Info **exp_infos); static Scheme_Object **compute_indirects(Scheme_Env *genv, Scheme_Module_Phase_Exports *pt, int *_count, int vars); static void start_module(Scheme_Module *m, Scheme_Env *env, int restart, Scheme_Object *syntax_idx, - int eval_exp, int eval_run, intptr_t base_phase, Scheme_Object *cycle_list); + int eval_exp, int eval_run, intptr_t base_phase, Scheme_Object *cycle_list, + int not_new); static void eval_module_body(Scheme_Env *menv, Scheme_Env *env); static Scheme_Object *do_namespace_require(Scheme_Env *env, int argc, Scheme_Object *argv[], @@ -257,7 +294,7 @@ static Scheme_Object *do_namespace_require(Scheme_Env *env, int argc, Scheme_Obj static Scheme_Object *default_module_resolver(int argc, Scheme_Object **argv); -static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Object **exss, char *exps, char *exets, +static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Object **exss, char *exps, int *exets, Scheme_Object **exsnoms, int start, int count, int do_uninterned); @@ -396,12 +433,25 @@ void scheme_init_module_resolver(void) scheme_set_param(config, MZCONFIG_CURRENT_MODULE_NAME, scheme_false); } +static void add_exp_infos(Scheme_Module *m) +{ + Scheme_Module_Export_Info **exp_infos, *exp_info; + + exp_infos = MALLOC_N(Scheme_Module_Export_Info *, 1); + exp_info = MALLOC_ONE_RT(Scheme_Module_Export_Info); + SET_REQUIRED_TAG(exp_info->type = scheme_rt_export_info); + exp_infos[0] = exp_info; + m->exp_infos = exp_infos; + m->num_phases = 1; +} + void scheme_finish_kernel(Scheme_Env *env) { /* When this function is called, the initial namespace has all the primitive bindings for syntax and procedures. This function fills in the module wrapper for #%kernel. */ Scheme_Object *w; + char *running; REGISTER_SO(kernel); @@ -424,7 +474,7 @@ void scheme_finish_kernel(Scheme_Env *env) kernel->tt_requires = scheme_null; kernel->dt_requires = scheme_null; kernel->other_requires = NULL; - + add_exp_infos(kernel); { Scheme_Bucket_Table *ht; @@ -482,8 +532,10 @@ void scheme_finish_kernel(Scheme_Env *env) kernel->me->rt->num_var_provides = syntax_start; scheme_populate_pt_ht(kernel->me->rt); - env->running = 1; - env->et_running = 1; + running = (char *)scheme_malloc_atomic(2); + running[0] = 1; + running[1] = 1; + env->running = running; env->attached = 1; /* Since this is the first module rename, it's registered as @@ -509,7 +561,7 @@ void scheme_finish_kernel(Scheme_Env *env) REGISTER_SO(scheme_begin_stx); REGISTER_SO(scheme_define_values_stx); REGISTER_SO(scheme_define_syntaxes_stx); - REGISTER_SO(scheme_define_for_syntaxes_stx); + REGISTER_SO(scheme_begin_for_syntax_stx); REGISTER_SO(require_stx); REGISTER_SO(provide_stx); REGISTER_SO(set_stx); @@ -533,7 +585,7 @@ void scheme_finish_kernel(Scheme_Env *env) scheme_begin_stx = scheme_datum_to_syntax(scheme_intern_symbol("begin"), scheme_false, w, 0, 0); scheme_define_values_stx = scheme_datum_to_syntax(scheme_intern_symbol("define-values"), scheme_false, w, 0, 0); scheme_define_syntaxes_stx = scheme_datum_to_syntax(scheme_intern_symbol("define-syntaxes"), scheme_false, w, 0, 0); - scheme_define_for_syntaxes_stx = scheme_datum_to_syntax(scheme_intern_symbol("define-values-for-syntax"), scheme_false, w, 0, 0); + scheme_begin_for_syntax_stx = scheme_datum_to_syntax(scheme_intern_symbol("begin-for-syntax"), scheme_false, w, 0, 0); require_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%require"), scheme_false, w, 0, 0); provide_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%provide"), scheme_false, w, 0, 0); set_stx = scheme_datum_to_syntax(scheme_intern_symbol("set!"), scheme_false, w, 0, 0); @@ -545,7 +597,6 @@ void scheme_finish_kernel(Scheme_Env *env) letrec_values_stx = scheme_datum_to_syntax(scheme_intern_symbol("letrec-values"), scheme_false, w, 0, 0); if_stx = scheme_datum_to_syntax(scheme_intern_symbol("if"), scheme_false, w, 0, 0); begin0_stx = scheme_datum_to_syntax(scheme_intern_symbol("begin0"), scheme_false, w, 0, 0); - set_stx = scheme_datum_to_syntax(scheme_intern_symbol("set!"), scheme_false, w, 0, 0); with_continuation_mark_stx = scheme_datum_to_syntax(scheme_intern_symbol("with-continuation-mark"), scheme_false, w, 0, 0); letrec_syntaxes_stx = scheme_datum_to_syntax(scheme_intern_symbol("letrec-syntaxes+values"), scheme_false, w, 0, 0); var_ref_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%variable-reference"), scheme_false, w, 0, 0); @@ -774,7 +825,7 @@ void scheme_install_initial_module_set(Scheme_Env *env) /* Make sure module is running: */ m = (Scheme_Module *)scheme_hash_get(initial_modules_env->module_registry->loaded, a[1]); - start_module(m, initial_modules_env, 0, a[1], 0, 1, 0, scheme_null); + start_module(m, initial_modules_env, 0, a[1], 0, 1, 0, scheme_null, 0); namespace_attach_module(3, a); } @@ -994,7 +1045,7 @@ static Scheme_Object *_dynamic_require(int argc, Scheme_Object *argv[], Scheme_Config *config; Scheme_Cont_Frame_Data cframe; - start_module(m, env, 0, modidx, 0, 1, base_phase, scheme_null); + start_module(m, env, 0, modidx, 0, 1, base_phase, scheme_null, 0); ns = scheme_make_namespace(0, NULL); a[0] = (Scheme_Object *)env; a[1] = srcm->modname; @@ -1032,8 +1083,8 @@ static Scheme_Object *_dynamic_require(int argc, Scheme_Object *argv[], } if (i < count) { - if (srcm->provide_protects) - protected = srcm->provide_protects[i]; + if (srcm->exp_infos[0]->provide_protects) + protected = srcm->exp_infos[0]->provide_protects[i]; srcmname = (srcm->me->rt->provide_srcs ? srcm->me->rt->provide_srcs[i] : scheme_false); if (SCHEME_FALSEP(srcmname)) srcmname = srcm->modname; @@ -1047,27 +1098,28 @@ static Scheme_Object *_dynamic_require(int argc, Scheme_Object *argv[], if (i == count) { if (indirect_ok) { /* Try indirect provides: */ + Scheme_Module_Export_Info *exp_info = m->exp_infos[0]; srcm = m; - count = srcm->num_indirect_provides; + count = exp_info->num_indirect_provides; if (position >= 0) { i = position; - if ((i < srcm->num_indirect_provides) - && (SCHEME_SYM_LEN(name) == SCHEME_SYM_LEN(srcm->indirect_provides[i])) - && !memcmp(SCHEME_SYM_VAL(name), SCHEME_SYM_VAL(srcm->indirect_provides[i]), SCHEME_SYM_LEN(name))) { - name = srcm->indirect_provides[i]; + if ((i < exp_info->num_indirect_provides) + && (SCHEME_SYM_LEN(name) == SCHEME_SYM_LEN(exp_info->indirect_provides[i])) + && !memcmp(SCHEME_SYM_VAL(name), SCHEME_SYM_VAL(exp_info->indirect_provides[i]), SCHEME_SYM_LEN(name))) { + name = exp_info->indirect_provides[i]; srcname = name; srcmname = srcm->modname; - if (srcm->provide_protects) - protected = srcm->provide_protects[i]; + if (exp_info->provide_protects) + protected = exp_info->provide_protects[i]; } else i = count; /* not found */ } else { for (i = 0; i < count; i++) { - if (SAME_OBJ(name, srcm->indirect_provides[i])) { + if (SAME_OBJ(name, exp_info->indirect_provides[i])) { srcname = name; srcmname = srcm->modname; - if (srcm->provide_protects) - protected = srcm->provide_protects[i]; + if (exp_info->provide_protects) + protected = exp_info->provide_protects[i]; break; } } @@ -1099,7 +1151,8 @@ static Scheme_Object *_dynamic_require(int argc, Scheme_Object *argv[], ? 0 : 1), base_phase, - scheme_null); + scheme_null, + 0); if (SCHEME_SYMBOLP(name)) { Scheme_Bucket *b; @@ -1177,7 +1230,7 @@ static Scheme_Object *do_namespace_require(Scheme_Env *env, int argc, Scheme_Obj rns = scheme_make_module_rename_set(mzMOD_RENAME_TOPLEVEL, NULL, insp); - parse_requires(form, scheme_false, env, NULL, + parse_requires(form, env->phase, scheme_false, env, NULL, rns, NULL, NULL /* ck */, NULL /* data */, NULL, @@ -1692,8 +1745,9 @@ static Scheme_Object *do_namespace_attach_module(const char *who, int argc, Sche start_module(m2, from_env->label_env, 0, main_modidx, - 0, 0, from_env->phase, - scheme_null); + 0, 0, -1, + scheme_null, + 0); scheme_pop_continuation_frame(&cframe); @@ -2373,7 +2427,7 @@ static int do_add_simple_require_renames(Scheme_Object *rn, { int i, saw_mb, numvals; Scheme_Object **exs, **exss, **exsns, *midx, *info, *vec, *nml, *mark_src; - char *exets; + int *exets; int with_shared = 1; saw_mb = 0; @@ -2422,7 +2476,7 @@ static int do_add_simple_require_renames(Scheme_Object *rn, SCHEME_VEC_ELS(vec)[5] = orig_src; SCHEME_VEC_ELS(vec)[6] = mark_src; SCHEME_VEC_ELS(vec)[7] = (can_override ? scheme_true : scheme_false); - SCHEME_VEC_ELS(vec)[8] = exets ? scheme_make_integer(exets[i]) : scheme_false; + SCHEME_VEC_ELS(vec)[8] = exets ? scheme_make_integer(exets[i]) : scheme_make_integer(0); scheme_hash_set(required, exs[i], vec); } } @@ -2531,7 +2585,7 @@ static int add_simple_require_renames(Scheme_Object *orig_src, void scheme_prep_namespace_rename(Scheme_Env *menv) { scheme_prepare_exp_env(menv); - start_module(menv->module, menv, 0, NULL, -1, 1, menv->phase, scheme_null); + start_module(menv->module, menv, 0, NULL, -1, 1, menv->phase, scheme_null, 1); if (!menv->rename_set_ready) { if (menv->module->rn_stx) { @@ -2544,7 +2598,7 @@ void scheme_prep_namespace_rename(Scheme_Env *menv) /* Reconstruct renames based on defns and requires. This case is used only when it's easy to reconstruct: no renames, no for-syntax definitions, etc. */ - int i; + int i, j; Scheme_Module *im; Scheme_Object *l, *idx, *one_rn, *shift, *name; @@ -2559,19 +2613,20 @@ void scheme_prep_namespace_rename(Scheme_Env *menv) scheme_make_integer(0), NULL, 0); } } - /* Local, not provided: */ - for (i = 0; i < m->num_indirect_provides; i++) { - name = m->indirect_provides[i]; - scheme_extend_module_rename(one_rn, m->self_modidx, name, name, m->self_modidx, name, 0, - scheme_make_integer(0), NULL, 0); - } - for (i = 0; i < m->num_indirect_syntax_provides; i++) { - name = m->indirect_syntax_provides[i]; - scheme_extend_module_rename(one_rn, m->self_modidx, name, name, m->self_modidx, name, 0, - scheme_make_integer(0), NULL, 0); - } - - one_rn = scheme_get_module_rename_from_set(rns, scheme_make_integer(1), 1); + for (j = 0; j < m->num_phases; j++) { + Scheme_Module_Export_Info *exp_info = m->exp_infos[j]; + one_rn = scheme_get_module_rename_from_set(rns, scheme_make_integer(j), 1); + for (i = 0; i < exp_info->num_indirect_provides; i++) { + name = exp_info->indirect_provides[i]; + scheme_extend_module_rename(one_rn, m->self_modidx, name, name, m->self_modidx, name, j, + scheme_make_integer(j), NULL, 0); + } + for (i = 0; i < exp_info->num_indirect_syntax_provides; i++) { + name = exp_info->indirect_syntax_provides[i]; + scheme_extend_module_rename(one_rn, m->self_modidx, name, name, m->self_modidx, name, j, + scheme_make_integer(j), NULL, 0); + } + } /* Required: */ for (i = -4; i < (menv->other_require_names ? menv->other_require_names->size : 0); i++) { @@ -3108,7 +3163,7 @@ static Scheme_Object *module_export_protected_p(int argc, Scheme_Object **argv) count = m->me->rt->num_provides; for (i = 0; i < count; i++) { if (SAME_OBJ(name, m->me->rt->provides[i])) { - if (m->provide_protects && m->provide_protects[i]) + if (m->exp_infos[0]->provide_protects && m->exp_infos[0]->provide_protects[i]) return scheme_true; else return scheme_false; @@ -3445,15 +3500,22 @@ static int is_procedure_expression(Scheme_Object *e) static void setup_accessible_table(Scheme_Module *m) { - if (!m->accessible) { + if (!m->exp_infos[0]->accessible) { Scheme_Module_Phase_Exports *pt; int j; - for (j = 0; j < 2; j++) { + for (j = 0; j < m->num_phases; j++) { if (!j) pt = m->me->rt; - else + else if (j == 1) pt = m->me->et; + else { + if (m->me->other_phases) + pt = (Scheme_Module_Phase_Exports *)scheme_hash_get(m->me->other_phases, + scheme_make_integer(j)); + else + pt = NULL; + } if (pt) { Scheme_Hash_Table *ht; @@ -3467,16 +3529,9 @@ static void setup_accessible_table(Scheme_Module *m) } } - if (j == 0) { - count = m->num_indirect_provides; - for (i = 0; i < count; i++) { - scheme_hash_set(ht, m->indirect_provides[i], scheme_make_integer(i + nvp)); - } - } else { - count = m->num_indirect_et_provides; - for (i = 0; i < count; i++) { - scheme_hash_set(ht, m->et_indirect_provides[i], scheme_make_integer(i + nvp)); - } + count = m->exp_infos[j]->num_indirect_provides; + for (i = 0; i < count; i++) { + scheme_hash_set(ht, m->exp_infos[j]->indirect_provides[i], scheme_make_integer(i + nvp)); } /* Add syntax as negative ids: */ @@ -3489,11 +3544,11 @@ static void setup_accessible_table(Scheme_Module *m) if (!j) { /* find constants: */ - int i, cnt = SCHEME_VEC_SIZE(m->body), k; + int i, cnt = SCHEME_VEC_SIZE(m->bodies[0]), k; Scheme_Object *form, *tl; for (i = 0; i < cnt; i++) { - form = SCHEME_VEC_ELS(m->body)[i]; + form = SCHEME_VEC_ELS(m->bodies[0])[i]; if (SAME_TYPE(SCHEME_TYPE(form), scheme_define_values_type)) { for (k = SCHEME_VEC_SIZE(form); k-- > 1; ) { tl = SCHEME_VEC_ELS(form)[k]; @@ -3529,10 +3584,9 @@ static void setup_accessible_table(Scheme_Module *m) } } } + } - m->accessible = ht; - } else - m->et_accessible = ht; + m->exp_infos[j]->accessible = ht; } } } @@ -3542,10 +3596,7 @@ Scheme_Env *scheme_module_access(Scheme_Object *name, Scheme_Env *env, intptr_t { Scheme_Env *menv; - if (!rev_mod_phase) - menv = get_special_modenv(name); - else - menv = NULL; + menv = get_special_modenv(name); if (!menv) { Scheme_Object *chain; @@ -3633,7 +3684,7 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object symbol = scheme_tl_id_sym(env, symbol, NULL, 0, NULL, NULL); if (scheme_is_kernel_env(env) - || ((env->module->primitive && !env->module->provide_protects))) { + || ((env->module->primitive && !env->module->exp_infos[0]->provide_protects))) { if (want_pos) return scheme_make_integer(-1); else @@ -3671,12 +3722,9 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object int num_indirect_provides; Scheme_Object **indirect_provides; - if (env->mod_phase == 0) { - num_indirect_provides = env->module->num_indirect_provides; - indirect_provides = env->module->indirect_provides; - } else if (env->mod_phase == 1) { - num_indirect_provides = env->module->num_indirect_et_provides; - indirect_provides = env->module->et_indirect_provides; + if ((env->mod_phase >= 0) && (env->mod_phase < env->module->num_phases)) { + num_indirect_provides = env->module->exp_infos[env->mod_phase]->num_indirect_provides; + indirect_provides = env->module->exp_infos[env->mod_phase]->indirect_provides; } else { num_indirect_provides = 0; indirect_provides = NULL; @@ -3699,11 +3747,9 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object if ((position < pt->num_var_provides) && scheme_module_protected_wrt(env->insp, prot_insp)) { char *provide_protects; - - if (env->mod_phase == 0) - provide_protects = env->module->provide_protects; - else if (env->mod_phase == 0) - provide_protects = env->module->et_provide_protects; + + if ((env->mod_phase >= 0) && (env->mod_phase < env->module->num_phases)) + provide_protects = env->module->exp_infos[env->mod_phase]->provide_protects; else provide_protects = NULL; @@ -3728,10 +3774,8 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object } else { Scheme_Object *pos; - if (!env->mod_phase) - pos = scheme_hash_get(env->module->accessible, symbol); - else if (env->mod_phase == 1) - pos = scheme_hash_get(env->module->et_accessible, symbol); + if (env->mod_phase < env->module->num_phases) + pos = scheme_hash_get(env->module->exp_infos[env->mod_phase]->accessible, symbol); else pos = NULL; @@ -3757,10 +3801,8 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object if (pos) { char *provide_protects; - if (env->mod_phase == 0) - provide_protects = env->module->provide_protects; - else if (env->mod_phase == 1) - provide_protects = env->module->et_provide_protects; + if ((env->mod_phase >= 0) && (env->mod_phase < env->module->num_phases)) + provide_protects = env->module->exp_infos[env->mod_phase]->provide_protects; else provide_protects = NULL; @@ -3880,7 +3922,7 @@ int scheme_module_export_position(Scheme_Object *modname, Scheme_Env *env, Schem setup_accessible_table(m); - pos = scheme_hash_get(m->accessible, varname); + pos = scheme_hash_get(m->exp_infos[0]->accessible, varname); if (pos && (SCHEME_INT_VAL(pos) >= 0)) return SCHEME_INT_VAL(pos); @@ -3888,7 +3930,8 @@ int scheme_module_export_position(Scheme_Object *modname, Scheme_Env *env, Schem return -1; } -Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env, Scheme_Object *name) +Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env, + Scheme_Object *name, int mod_phase) { if (SAME_OBJ(modname, kernel_modname)) { Scheme_Env *kenv; @@ -3904,12 +3947,23 @@ Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env, Sch } else { Scheme_Env *menv; Scheme_Object *val; + int i; + + for (i = 0; i < mod_phase; i++) { + env = env->template_env; + if (!env) return NULL; + } menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(env->modchain), modname); - + if (!menv) return NULL; + for (i = 0; i < mod_phase; i++) { + menv = menv->exp_env; + if (!menv) return NULL; + } + if (SCHEME_STXP(name)) name = scheme_tl_id_sym(menv, name, NULL, 0, NULL, NULL); @@ -4002,27 +4056,27 @@ static Scheme_Object *add_start(Scheme_Object *v, int base_phase, int eval_exp, #if 0 static int indent = 0; # define show_indent(d) (indent += d) -static void show(const char *what, Scheme_Env *menv, int v1, int v2, int base_phase) +static void show(const char *what, Scheme_Env *menv, int v1, int v2, int ph, int base_phase) { if (menv->phase > 3) return; - if (1 || SCHEME_SYMBOLP(SCHEME_PTR_VAL(menv->module->modname))) - if (1 || SCHEME_SYM_VAL(SCHEME_PTR_VAL(menv->module->modname))[0] != '#') { + if (0 || SCHEME_SYMBOLP(SCHEME_PTR_VAL(menv->module->modname))) + if (0 || SCHEME_SYM_VAL(SCHEME_PTR_VAL(menv->module->modname))[0] != '#') { int i; for (i = 0; i < indent; i++) { fprintf(stderr, " "); } - fprintf(stderr, "%s \t%s @%ld/%d [%d/%d] %p\n", + fprintf(stderr, "%s \t%s @%ld+%d/%d [%d/%d] %p\n", what, scheme_write_to_string(menv->module->modname, NULL), - menv->phase, base_phase, v1, v2, menv->modchain); + menv->phase, ph, base_phase, v1, v2, menv->modchain); } } -static void show_done(const char *what, Scheme_Env *menv, int v1, int v2, int base_phase){ - show(what, menv, v1, v2, base_phase); +static void show_done(const char *what, Scheme_Env *menv, int v1, int v2, int i, int base_phase){ + show(what, menv, v1, v2, i, base_phase); } #else # define show_indent(d) /* nothing */ -# define show(w, m, v1, v2, bp) /* nothing */ -# define show_done(w, m, v1, v2, bp) /* nothing */ +# define show(w, m, v1, v2, i, bp) /* nothing */ +# define show_done(w, m, v1, v2, i, bp) /* nothing */ #endif static void compute_require_names(Scheme_Env *menv, Scheme_Object *phase, @@ -4115,7 +4169,8 @@ static void chain_start_module(Scheme_Env *menv, Scheme_Env *env, int eval_exp, menv->label_env, 0, midx, 0, 0, base_phase, - new_cycle_list); + new_cycle_list, + 0); } } @@ -4134,7 +4189,8 @@ static void chain_start_module(Scheme_Env *menv, Scheme_Env *env, int eval_exp, menv->template_env, 0, midx, eval_exp, eval_run, base_phase, - new_cycle_list); + new_cycle_list, + 0); } } @@ -4145,7 +4201,8 @@ static void chain_start_module(Scheme_Env *menv, Scheme_Env *env, int eval_exp, im = module_load(scheme_module_resolve(midx, 1), env, NULL); - start_module(im, env, 0, midx, eval_exp, eval_run, base_phase, new_cycle_list); + start_module(im, env, 0, midx, eval_exp, eval_run, base_phase, + new_cycle_list, 0); } scheme_prepare_exp_env(menv); @@ -4159,7 +4216,8 @@ static void chain_start_module(Scheme_Env *menv, Scheme_Env *env, int eval_exp, im = module_load(scheme_module_resolve(midx, 1), env, NULL); - start_module(im, menv->exp_env, 0, midx, eval_exp, eval_run, base_phase, new_cycle_list); + start_module(im, menv->exp_env, 0, midx, eval_exp, eval_run, base_phase, + new_cycle_list, 0); } } @@ -4193,7 +4251,8 @@ static void chain_start_module(Scheme_Env *menv, Scheme_Env *env, int eval_exp, menv2, 0, midx, eval_exp, eval_run, base_phase, - new_cycle_list); + new_cycle_list, + 0); } } else { compute_require_names(menv, phase, env, syntax_idx); @@ -4214,7 +4273,8 @@ static void chain_start_module(Scheme_Env *menv, Scheme_Env *env, int eval_exp, im = module_load(scheme_module_resolve(midx, 1), env, NULL); - start_module(im, menv2, 0, midx, eval_exp, eval_run, base_phase, new_cycle_list); + start_module(im, menv2, 0, midx, eval_exp, eval_run, base_phase, + new_cycle_list, 0); } } } @@ -4260,7 +4320,8 @@ void *scheme_module_start_finish(struct Start_Module_Args *a) return NULL; } -static Scheme_Env *instantiate_module(Scheme_Module *m, Scheme_Env *env, int restart, Scheme_Object *syntax_idx) +static Scheme_Env *instantiate_module(Scheme_Module *m, Scheme_Env *env, int restart, + Scheme_Object *syntax_idx, int not_new) { Scheme_Env *menv; @@ -4290,18 +4351,27 @@ static Scheme_Env *instantiate_module(Scheme_Module *m, Scheme_Env *env, int res Scheme_Object *insp; if (!menv) { + char *running; + + if (not_new) + scheme_signal_error("internal error: shouldn't instantiate module %s now", + scheme_write_to_string(m->modname, NULL)); + /* printf("new %ld %s\n", env->phase, SCHEME_SYM_VAL(m->modname)); */ menv = scheme_new_module_env(env, m, 0); scheme_hash_set(MODCHAIN_TABLE(env->modchain), m->modname, (Scheme_Object *)menv); - + + running = (char *)scheme_malloc_atomic(menv->module->num_phases); + menv->running = running; + memset(menv->running, 0, menv->module->num_phases); + menv->phase = env->phase; menv->link_midx = syntax_idx; } else { Scheme_Env *env2; menv->module = m; - menv->running = 0; - menv->et_running = 0; + memset(menv->running, 0, menv->module->num_phases); menv->ran = 0; menv->did_starts = NULL; @@ -4343,8 +4413,8 @@ static Scheme_Env *instantiate_module(Scheme_Module *m, Scheme_Env *env, int res scheme_add_to_table(menv->toplevel, (const char *)exsns[i], NULL, 0); } - count = m->num_indirect_provides; - exsns = m->indirect_provides; + count = m->exp_infos[0]->num_indirect_provides; + exsns = m->exp_infos[0]->indirect_provides; for (i = 0; i < count; i++) { scheme_add_to_table(menv->toplevel, (const char *)exsns[i], NULL, 0); } @@ -4355,122 +4425,128 @@ static Scheme_Env *instantiate_module(Scheme_Module *m, Scheme_Env *env, int res return menv; } -static void expstart_module(Scheme_Env *menv, Scheme_Env *env, int restart) +static void expstart_module(Scheme_Env *menv, Scheme_Env *env, int phase, int restart) { if (!restart) { - if (menv && menv->et_running) + if (menv && menv->running[phase]) return; } if (menv->module->primitive) return; - menv->et_running = 1; + menv->running[phase] = 1; if (scheme_starting_up) menv->attached = 1; /* protect initial modules from redefinition, etc. */ - run_module_exptime(menv, 0); + run_module_exptime(menv, phase); return; } -static void run_module_exptime(Scheme_Env *menv, int set_ns) +static void run_module_exptime(Scheme_Env *menv, int phase) { #ifdef MZ_USE_JIT - (void)scheme_module_exprun_start(menv, set_ns, scheme_make_pair(menv->module->modname, scheme_void)); + (void)scheme_module_exprun_start(menv, phase, scheme_make_pair(menv->module->modname, scheme_void)); #else - (void)scheme_module_exprun_finish(menv, set_ns); + (void)scheme_module_exprun_finish(menv, phase); #endif } -void *scheme_module_exprun_finish(Scheme_Env *menv, int set_ns) +void *scheme_module_exprun_finish(Scheme_Env *menv, int at_phase) { int let_depth, for_stx; Scheme_Object *names, *e; Resolve_Prefix *rp; Scheme_Comp_Env *rhs_env; - int i, cnt; + int i, cnt, len; Scheme_Env *exp_env; - Scheme_Bucket_Table *syntax, *for_stx_globals; - Scheme_Cont_Frame_Data cframe; - Scheme_Config *config; - + Scheme_Bucket_Table *syntax; + if (menv->module->primitive) return NULL; - if (!SCHEME_VEC_SIZE(menv->module->et_body)) + if ((menv->module->num_phases <= at_phase) || (!SCHEME_VEC_SIZE(menv->module->bodies[at_phase]))) return NULL; - syntax = menv->syntax; - + for (i = 1; i < at_phase; i++) { + menv = menv->exp_env; + } exp_env = menv->exp_env; if (!exp_env) return NULL; - for_stx_globals = exp_env->toplevel; - - if (set_ns) { - config = scheme_extend_config(scheme_current_config(), - MZCONFIG_ENV, - (Scheme_Object *)menv); - - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - } + syntax = menv->syntax; rhs_env = scheme_new_comp_env(menv, menv->module->insp, SCHEME_TOPLEVEL_FRAME); - cnt = SCHEME_VEC_SIZE(menv->module->et_body); + cnt = SCHEME_VEC_SIZE(menv->module->bodies[at_phase]); for (i = 0; i < cnt; i++) { - e = SCHEME_VEC_ELS(menv->module->et_body)[i]; + e = SCHEME_VEC_ELS(menv->module->bodies[at_phase])[i]; names = SCHEME_VEC_ELS(e)[0]; let_depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(e)[2]); rp = (Resolve_Prefix *)SCHEME_VEC_ELS(e)[3]; for_stx = SCHEME_TRUEP(SCHEME_VEC_ELS(e)[4]); e = SCHEME_VEC_ELS(e)[1]; - - if (SCHEME_SYMBOLP(names)) - names = scheme_make_pair(names, scheme_null); + + if (for_stx) { + names = NULL; + len = 0; + } else { + if (SCHEME_SYMBOLP(names)) + names = scheme_make_pair(names, scheme_null); + len = scheme_list_length(names); + } - eval_exptime(names, scheme_list_length(names), e, exp_env, rhs_env, - rp, let_depth, 1, (for_stx ? for_stx_globals : syntax), for_stx, + eval_exptime(names, len, e, exp_env, rhs_env, + rp, let_depth, 1, (for_stx ? NULL : syntax), at_phase, scheme_false, menv->module->insp); } - if (set_ns) { - scheme_pop_continuation_frame(&cframe); - } - return NULL; } static void do_start_module(Scheme_Module *m, Scheme_Env *menv, Scheme_Env *env, int restart) { if (m->primitive) { - menv->running = 1; + menv->running[0] = 1; menv->ran = 1; return; } - if (menv->running > 0) { + if (menv->running[0] > 0) { return; } - menv->running = 1; + menv->running[0] = 1; if (menv->module->prim_body) { Scheme_Invoke_Proc ivk = menv->module->prim_body; menv->ran = 1; - ivk(menv, menv->phase, menv->link_midx, m->body); + ivk(menv, menv->phase, menv->link_midx, m->bodies[0]); } else { eval_module_body(menv, env); } } -static void should_run_for_compile(Scheme_Env *menv) +static void should_run_for_compile(Scheme_Env *menv, int phase) { + if (menv->running[phase]) return; + + while (phase > 1) { + scheme_prepare_exp_env(menv); + menv = menv->exp_env; + phase--; + } + +#if 0 + if (!scheme_hash_get(MODCHAIN_TABLE(menv->instance_env->modchain), menv->module->modname)) + scheme_signal_error("internal error: inconsistent instance_env"); +#endif + + if (!menv->available_next[0]) { menv->available_next[0] = MODCHAIN_AVAIL(menv->modchain, 0); MODCHAIN_AVAIL(menv->modchain, 0) = (Scheme_Object *)menv; @@ -4483,12 +4559,17 @@ static void should_run_for_compile(Scheme_Env *menv) static void start_module(Scheme_Module *m, Scheme_Env *env, int restart, Scheme_Object *syntax_idx, int eval_exp, int eval_run, intptr_t base_phase, - Scheme_Object *cycle_list) -/* eval_exp == -1 => make it ready, eval_exp == 1 => run exp-time, eval_exp = 0 => don't even make ready */ + Scheme_Object *cycle_list, int not_new) +/* Make an instance of module `m' in `env', which means that phase level 0 of module `m' + will be shifted to phase `env->phase'. + Let P=`base_phase'-`env->phase'. + - If `eval_run', then instantiate phase-level P of `m' (which is at `base_phase' in `env'). + - If `eval_exp' is -1, then (also) make its P+1 phase-level ready. + - If `eval_exp' is 1, then visit at phase P => run phase P+1. */ { Scheme_Env *menv; Scheme_Object *l, *new_cycle_list; - int prep_namespace = 0; + int prep_namespace = 0, i; if (is_builtin_modname(m->modname)) return; @@ -4503,16 +4584,16 @@ static void start_module(Scheme_Module *m, Scheme_Env *env, int restart, new_cycle_list = scheme_make_pair(m->modname, cycle_list); - menv = instantiate_module(m, env, restart, syntax_idx); + menv = instantiate_module(m, env, restart, syntax_idx, not_new); check_phase(menv, env, 0); - show("chck", menv, eval_exp, eval_run, base_phase); + show("chck", menv, eval_exp, eval_run, 0, base_phase); if (did_start(menv->did_starts, base_phase, eval_exp, eval_run)) return; - show("strt", menv, eval_exp, eval_run, base_phase); + show("strt", menv, eval_exp, eval_run, 0, base_phase); show_indent(+1); { @@ -4530,41 +4611,48 @@ static void start_module(Scheme_Module *m, Scheme_Env *env, int restart, } } - if (env->phase == base_phase) { - if (eval_exp) { - if (eval_exp > 0) { - show("exp=", menv, eval_exp, eval_run, base_phase); - expstart_module(menv, env, restart); + if (eval_run || eval_exp) { + for (i = menv->module->num_phases; i-- ; ) { + if (env->phase + i == base_phase) { + if (eval_exp) { + if (base_phase < menv->module->num_phases) { + if (eval_exp > 0) { + show("exp=", menv, eval_exp, eval_run, i, base_phase); + expstart_module(menv, env, i+1, restart); + } else { + should_run_for_compile(menv, i); + } + } + } + if (eval_run) { + show("run=", menv, eval_exp, eval_run, i, base_phase); + if (i == 0) + do_start_module(m, menv, env, restart); + else + expstart_module(menv, env, i, restart); + } + } else if (env->phase + i > base_phase) { + if (eval_exp) { + should_run_for_compile(menv, i); + if (eval_exp > 0) { + if (env->phase + i == base_phase + 1) { + show("run+", menv, eval_exp, eval_run, i, base_phase); + if (i == 0) + do_start_module(m, menv, env, restart); + else + expstart_module(menv, env, i, restart); + } + } + } } else { - should_run_for_compile(menv); - } - } - if (eval_run) { - show("run=", menv, eval_exp, eval_run, base_phase); - do_start_module(m, menv, env, restart); - } - } else if (env->phase < base_phase) { - if (env->phase == base_phase - 1) { - if (eval_run) { - show("run-", menv, eval_exp, eval_run, base_phase); - expstart_module(menv, env, restart); - } - } - } else { - /* env->phase > base_phase */ - if (eval_exp) { - should_run_for_compile(menv); - } - if (eval_exp > 0) { - if (env->phase == base_phase + 1) { - show("run+", menv, eval_exp, eval_run, base_phase); - do_start_module(m, menv, env, restart); + /* env->phase + i < base_phase */ } } + } show_indent(-1); - show_done("done", menv, eval_exp, eval_run, base_phase); + show_done("done", menv, eval_exp, eval_run, 0, base_phase); if (prep_namespace) scheme_prep_namespace_rename(menv); @@ -4601,9 +4689,9 @@ static void do_prepare_compile_env(Scheme_Env *env, int base_phase, int pos) menv = (Scheme_Env *)v; v = menv->available_next[pos]; menv->available_next[pos] = NULL; - start_module(menv->module, env, 0, + start_module(menv->module, menv->instance_env, 0, NULL, 1, 0, base_phase, - scheme_null); + scheme_null, 1); } if (need_lock) @@ -4711,7 +4799,7 @@ void *scheme_module_run_finish(Scheme_Env *menv, Scheme_Env *env) mz_jmp_buf newbuf, * volatile savebuf; LOG_RUN_DECLS; - menv->running = 1; + menv->running[0] = 1; menv->ran = 1; depth = m->max_let_depth + scheme_prefix_depth(m->prefix); @@ -4752,9 +4840,9 @@ void *scheme_module_run_finish(Scheme_Env *menv, Scheme_Env *env) scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); } - cnt = SCHEME_VEC_SIZE(m->body); + cnt = SCHEME_VEC_SIZE(m->bodies[0]); for (i = 0; i < cnt; i++) { - body = SCHEME_VEC_ELS(m->body)[i]; + body = SCHEME_VEC_ELS(m->bodies[0])[i]; if (needs_prompt(body)) { /* We need to push the prefix after the prompt is set, so restore the runstack and then add the prefix back. */ @@ -4826,6 +4914,7 @@ Scheme_Env *scheme_primitive_module(Scheme_Object *name, Scheme_Env *for_env) Scheme_Env *env; Scheme_Object *prefix, *insp, *src, *midx; Scheme_Config *config; + char *running; m = MALLOC_ONE_TAGGED(Scheme_Module); m->so.type = scheme_module_type; @@ -4880,6 +4969,11 @@ Scheme_Env *scheme_primitive_module(Scheme_Object *name, Scheme_Env *for_env) scheme_hash_set(for_env->module_registry->loaded, m->modname, (Scheme_Object *)m); + running = scheme_malloc_atomic(2); + running[0] = 0; + running[1] = 0; + env->running = running; + return env; } @@ -4891,6 +4985,9 @@ void scheme_finish_primitive_module(Scheme_Env *env) Scheme_Object **exs; int i, count; + if (!m->exp_infos) + add_exp_infos(m); + /* Provide all variables: */ count = 0; ht = env->toplevel; @@ -4918,7 +5015,7 @@ void scheme_finish_primitive_module(Scheme_Env *env) qsort_provides(exs, NULL, NULL, NULL, NULL, NULL, 0, count, 1); - env->running = 1; + env->running[0] = 1; } void scheme_protect_primitive_provide(Scheme_Env *env, Scheme_Object *name) @@ -4926,7 +5023,10 @@ void scheme_protect_primitive_provide(Scheme_Env *env, Scheme_Object *name) Scheme_Module *m = env->module; int i; - if (!m->provide_protects) { + if (!m->exp_infos) + add_exp_infos(m); + + if (!m->exp_infos[0]->provide_protects) { Scheme_Hash_Table *ht; char *exps; ht = scheme_make_hash_table(SCHEME_hash_ptr); @@ -4935,21 +5035,22 @@ void scheme_protect_primitive_provide(Scheme_Env *env, Scheme_Object *name) exps[i] = 0; scheme_hash_set(ht, m->me->rt->provides[i], scheme_make_integer(i)); } - m->provide_protects = exps; - m->accessible = ht; + add_exp_infos(m); + m->exp_infos[0]->provide_protects = exps; + m->exp_infos[0]->accessible = ht; } if (name) { for (i = m->me->rt->num_provides; i--; ) { if (SAME_OBJ(name, m->me->rt->provides[i])) { - m->provide_protects[i] = 1; + m->exp_infos[0]->provide_protects[i] = 1; break; } } } else { /* Protect all */ for (i = m->me->rt->num_provides; i--; ) { - m->provide_protects[i] = 1; + m->exp_infos[0]->provide_protects[i] = 1; } } } @@ -5052,7 +5153,7 @@ static void *eval_exptime_k(void) { Scheme_Thread *p = scheme_current_thread; Scheme_Object *names; - int count, for_stx; + int count, at_phase; Scheme_Object *expr; Scheme_Env *genv; Scheme_Comp_Env *comp_env; @@ -5072,7 +5173,7 @@ static void *eval_exptime_k(void) count = p->ku.k.i1; let_depth = p->ku.k.i2; shift = p->ku.k.i3; - for_stx = p->ku.k.i4; + at_phase = p->ku.k.i4; p->ku.k.p1 = NULL; p->ku.k.p2 = NULL; @@ -5080,7 +5181,7 @@ static void *eval_exptime_k(void) p->ku.k.p4 = NULL; p->ku.k.p5 = NULL; - eval_exptime(names, count, expr, genv, comp_env, rp, let_depth, shift, syntax, for_stx, + eval_exptime(names, count, expr, genv, comp_env, rp, let_depth, shift, syntax, at_phase, free_id_rename_rn, insp); return NULL; @@ -5102,7 +5203,7 @@ static void eval_exptime(Scheme_Object *names, int count, Scheme_Env *genv, Scheme_Comp_Env *comp_env, Resolve_Prefix *rp, int let_depth, int shift, Scheme_Bucket_Table *syntax, - int for_stx, + int at_phase, Scheme_Object *free_id_rename_rn, Scheme_Object *insp) { @@ -5125,7 +5226,7 @@ static void eval_exptime(Scheme_Object *names, int count, p->ku.k.i1 = count; p->ku.k.i2 = let_depth; p->ku.k.i3 = shift; - p->ku.k.i4 = for_stx; + p->ku.k.i4 = at_phase; (void)scheme_enlarge_runstack(depth, eval_exptime_k); return; } @@ -5136,7 +5237,7 @@ static void eval_exptime(Scheme_Object *names, int count, save_runstack = scheme_push_prefix(genv, rp, (shift ? genv->module->me->src_modidx : NULL), (shift ? genv->link_midx : NULL), - 1, genv->phase, + at_phase, genv->phase, NULL, insp); if (is_simple_expr(expr)) { @@ -5162,74 +5263,70 @@ static void eval_exptime(Scheme_Object *names, int count, scheme_pop_prefix(save_runstack); } - if (SAME_OBJ(vals, SCHEME_MULTIPLE_VALUES)) { - g = scheme_current_thread->ku.multiple.count; - if (count == g) { - Scheme_Object **values; + if (names) { + if (SAME_OBJ(vals, SCHEME_MULTIPLE_VALUES)) { + g = scheme_current_thread->ku.multiple.count; + if (count == g) { + Scheme_Object **values; - 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; - for (i = 0; i < g; i++, names = SCHEME_CDR(names)) { - name = SCHEME_CAR(names); - - if (!for_stx) { - macro = scheme_alloc_small_object(); - macro->type = scheme_macro_type; - SCHEME_PTR_VAL(macro) = values[i]; + 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; + for (i = 0; i < g; i++, names = SCHEME_CDR(names)) { + name = SCHEME_CAR(names); + macro = scheme_alloc_small_object(); + macro->type = scheme_macro_type; + SCHEME_PTR_VAL(macro) = values[i]; + if (SCHEME_TRUEP(free_id_rename_rn) && scheme_is_binding_rename_transformer(values[i])) scheme_install_free_id_rename(name, scheme_rename_transformer_id(values[i]), free_id_rename_rn, scheme_make_integer(0)); - } else - macro = values[i]; - scheme_add_to_table(syntax, (const char *)name, macro, 0); + scheme_add_to_table(syntax, (const char *)name, macro, 0); + } + + return; } - - return; - } - } else if (SCHEME_PAIRP(names) && SCHEME_NULLP(SCHEME_CDR(names))) { - name = SCHEME_CAR(names); + } else if (SCHEME_PAIRP(names) && SCHEME_NULLP(SCHEME_CDR(names))) { + name = SCHEME_CAR(names); - if (!for_stx) { macro = scheme_alloc_small_object(); macro->type = scheme_macro_type; SCHEME_PTR_VAL(macro) = vals; - + if (SCHEME_TRUEP(free_id_rename_rn) && scheme_is_binding_rename_transformer(vals)) scheme_install_free_id_rename(name, scheme_rename_transformer_id(vals), free_id_rename_rn, scheme_make_integer(0)); - } else - macro = vals; - - scheme_add_to_table(syntax, (const char *)name, macro, 0); - return; - } else - g = 1; + scheme_add_to_table(syntax, (const char *)name, macro, 0); + + return; + } else + g = 1; - if (count) - name = SCHEME_CAR(names); - else - name = NULL; + if (count) + name = SCHEME_CAR(names); + else + name = NULL; - { - const char *symname; + { + const char *symname; - symname = (name ? scheme_symbol_name(name) : ""); + symname = (name ? scheme_symbol_name(name) : ""); - scheme_wrong_return_arity((for_stx ? "define-values-for-syntax" : "define-syntaxes"), - count, g, - (g == 1) ? (Scheme_Object **)vals : scheme_current_thread->ku.multiple.array, - "%s%s%s", - name ? "defining \"" : "0 names", - symname, - name ? ((count == 1) ? "\"" : "\", ...") : ""); - } + scheme_wrong_return_arity("define-syntaxes", + count, g, + (g == 1) ? (Scheme_Object **)vals : scheme_current_thread->ku.multiple.array, + "%s%s%s", + name ? "defining \"" : "0 names", + symname, + name ? ((count == 1) ? "\"" : "\", ...") : ""); + } + } } /**********************************************************************/ @@ -5326,7 +5423,10 @@ static Scheme_Object *do_module_execute(Scheme_Object *data, Scheme_Env *genv, i /* Replacing an already-running or already-syntaxing module? */ if (old_menv) { - start_module(m, env, 1, NULL, old_menv->et_running, old_menv->running, env->phase, scheme_null); + start_module(m, env, 1, NULL, + ((m->num_phases > 1) ? old_menv->running[1] : 0), + old_menv->running[0], + env->phase, scheme_null, 1); } return scheme_void; @@ -5422,26 +5522,39 @@ static Scheme_Object *jit_vector(Scheme_Object *orig_l, int in_vec, int jit) static Scheme_Object *do_module_clone(Scheme_Object *data, int jit) { Scheme_Module *m = (Scheme_Module *)data; - Scheme_Object *l1, *l2; + Scheme_Object *l1, **naya = NULL; + int j, i; Resolve_Prefix *rp; rp = scheme_prefix_eval_clone(m->prefix); - if (jit) - l1 = jit_vector(m->body, 0, jit); - else - l1 = m->body; - l2 = jit_vector(m->et_body, 1, jit); + for (j = m->num_phases; j--; ) { + if (!jit && !j) { + if (naya) + naya[0] = m->bodies[0]; + break; + } + l1 = jit_vector(m->bodies[j], j > 0, jit); + if (naya) + naya[j] = l1; + else if (!SAME_OBJ(l1, m->bodies[j])) { + naya = MALLOC_N(Scheme_Object*, m->num_phases); + for (i = m->num_phases; i-- > j; ) { + naya[i] = m->bodies[i]; + } + naya[j] = l1; + } + } - if (SAME_OBJ(l1, m->body) - && SAME_OBJ(l2, m->body) - && SAME_OBJ(rp, m->prefix)) - return data; + if (!naya) { + if (SAME_OBJ(rp, m->prefix)) + return data; + naya = m->bodies; + } m = MALLOC_ONE_TAGGED(Scheme_Module); memcpy(m, data, sizeof(Scheme_Module)); - m->body = l1; - m->et_body = l2; + m->bodies = naya; m->prefix = rp; return (Scheme_Object *)m; @@ -5571,7 +5684,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, /* load the module for the initial require */ iim = module_load(_module_resolve(iidx, m->ii_src, NULL, 1), menv, NULL); - start_module(iim, menv, 0, iidx, 1, 0, menv->phase, scheme_null); + start_module(iim, menv, 0, iidx, 1, 0, menv->phase, scheme_null, 0); { Scheme_Object *ins; @@ -5839,7 +5952,7 @@ static void check_require_name(Scheme_Object *prnt_name, Scheme_Object *name, vec = scheme_hash_get(required, name); if (vec) { Scheme_Object *srcs; - char *fromsrc = NULL, *fromsrc_colon = ""; + char *fromsrc = NULL, *fromsrc_colon = "", *phase_expl; intptr_t fromsrclen = 0; if (same_resolved_modidx(SCHEME_VEC_ELS(vec)[1], modidx) @@ -5875,8 +5988,21 @@ static void check_require_name(Scheme_Object *prnt_name, Scheme_Object *name, if (err_src) srcs = scheme_make_pair(err_src, srcs); + if (SCHEME_FALSEP(phase)) + phase_expl = " for label"; + else if (!SCHEME_INT_VAL(phase)) + phase_expl = ""; + else if (SCHEME_INT_VAL(phase) == 1) + phase_expl = " for syntax"; + else { + char buf[32]; + sprintf(buf, " for phase %" PRIxPTR, SCHEME_INT_VAL(phase)); + phase_expl = scheme_strdup(buf); + } + scheme_wrong_syntax_with_more_sources("module", prnt_name, err_src, srcs, - "identifier already imported from%s %t", + "identifier already imported%s from%s %t", + phase_expl, fromsrc_colon, fromsrc, fromsrclen); } } @@ -6018,7 +6144,7 @@ Scheme_Object *scheme_parse_lifted_require(Scheme_Object *module_path, e = make_require_form(module_path, phase, mark); - parse_requires(e, base_modidx, env, for_m, + parse_requires(e, env->phase, base_modidx, env, for_m, rns, post_ex_rns, check_require_name, tables, redef_modname, @@ -6072,33 +6198,15 @@ static void flush_definitions(Scheme_Env *genv) static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Compile_Expand_Info *rec, int drec) { - Scheme_Object *form, *fm, *first, *last, *p, *rn_set, *rn, *exp_body, *et_rn, *self_modidx, *prev_p; - Scheme_Comp_Env *xenv, *cenv, *rhs_env; - Scheme_Hash_Table *et_required; /* just to avoid duplicates */ - Scheme_Hash_Table *required; /* name -> (vector nominal-modidx-list modidx srcname var? prntname) */ - /**/ /* first nominal-modidx goes with modidx, rest are for re-provides */ - Scheme_Hash_Table *provided; /* exname -> (cons locname-stx-or-sym protected?) */ - Scheme_Hash_Table *all_reprovided; /* phase -> list of (list modidx syntax except-name ...) */ - Scheme_Object *all_defs_out; /* list of (cons protected? (stx-list except-name ...)) */ - Scheme_Object *all_et_defs_out; - Scheme_Hash_Table *all_provided; /* phase -> table like `provided' */ - Scheme_Object *all_defs; /* list of stxid; this is almost redundant to the syntax and toplevel - tables, but it preserves the original name for exporting */ - Scheme_Object *all_et_defs; - Scheme_Object *post_ex_rn, *post_ex_et_rn; /* renames for ids introduced by expansion */ + int num_phases, *_num_phases, i, exicount, *all_simple_renames; + Scheme_Hash_Tree *all_defs; + Scheme_Hash_Table *tables, *all_defs_out, *all_provided, *all_reprovided, *modidx_cache; + Scheme_Module_Export_Info **exp_infos, *exp_info; + Scheme_Module_Phase_Exports *pt; Scheme_Object *post_ex_rn_set; /* phase -> post_ex_rn-like rename */ - Scheme_Hash_Table *tables; /* phase -> (vector toplevels requires syntaxes) */ - Scheme_Object *lift_data; - Scheme_Object **exis, **et_exis, **exsis; - Scheme_Object *lift_ctx; - Scheme_Object *lifted_reqs = scheme_null, *req_data, *unbounds = scheme_null; - int exicount, et_exicount, exsicount; - char *exps, *et_exps; - int *all_simple_renames; - int maybe_has_lifts = 0; - Scheme_Object *redef_modname; - Scheme_Object *observer; - Scheme_Hash_Table *modidx_cache; + Scheme_Object *form, *redef_modname, *rn_set, *observer, **exis, *body_lists; + Scheme_Env *genv; + Module_Begin_Expand_State *bxs; form = scheme_stx_taint_disarm(orig_form, NULL); @@ -6116,138 +6224,361 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env if (!scheme_hash_get(env->genv->module_registry->loaded, redef_modname)) redef_modname = NULL; - /* Expand each expression in form up to `begin', `define-values', `define-syntax', - `require', `provide', `#%app', etc. */ - xenv = scheme_new_compilation_frame(0, (SCHEME_CAPTURE_WITHOUT_RENAME - | SCHEME_MODULE_BEGIN_FRAME - | SCHEME_FOR_STOPS), - env); - { - Scheme_Object *stop; - stop = scheme_get_stop_expander(); - scheme_add_local_syntax(19, xenv); - scheme_set_local_syntax(0, scheme_begin_stx, stop, xenv); - scheme_set_local_syntax(1, scheme_define_values_stx, stop, xenv); - scheme_set_local_syntax(2, scheme_define_syntaxes_stx, stop, xenv); - scheme_set_local_syntax(3, scheme_define_for_syntaxes_stx, stop, xenv); - scheme_set_local_syntax(4, require_stx, stop, xenv); - scheme_set_local_syntax(5, provide_stx, stop, xenv); - scheme_set_local_syntax(6, set_stx, stop, xenv); - scheme_set_local_syntax(7, app_stx, stop, xenv); - scheme_set_local_syntax(8, scheme_top_stx, stop, xenv); - scheme_set_local_syntax(9, lambda_stx, stop, xenv); - scheme_set_local_syntax(10, case_lambda_stx, stop, xenv); - scheme_set_local_syntax(11, let_values_stx, stop, xenv); - scheme_set_local_syntax(12, letrec_values_stx, stop, xenv); - scheme_set_local_syntax(13, if_stx, stop, xenv); - scheme_set_local_syntax(14, begin0_stx, stop, xenv); - scheme_set_local_syntax(15, with_continuation_mark_stx, stop, xenv); - scheme_set_local_syntax(16, letrec_syntaxes_stx, stop, xenv); - scheme_set_local_syntax(17, var_ref_stx, stop, xenv); - scheme_set_local_syntax(18, expression_stx, stop, xenv); - } + tables = scheme_make_hash_table_equal(); - first = scheme_null; - last = NULL; + modidx_cache = scheme_make_hash_table_equal(); rn_set = env->genv->rename_set; - rn = scheme_get_module_rename_from_set(rn_set, scheme_make_integer(0), 1); - et_rn = scheme_get_module_rename_from_set(rn_set, scheme_make_integer(1), 1); - - required = scheme_make_hash_table(SCHEME_hash_ptr); - et_required = scheme_make_hash_table(SCHEME_hash_ptr); - - tables = scheme_make_hash_table_equal(); - { - Scheme_Object *vec; - - vec = scheme_make_vector(3, NULL); - SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)env->genv->toplevel; - SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)required; - SCHEME_VEC_ELS(vec)[2] = (Scheme_Object *)env->genv->syntax; - scheme_hash_set(tables, scheme_make_integer(0), vec); - - vec = scheme_make_vector(3, NULL); - SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)env->genv->exp_env->toplevel; - SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)et_required; - SCHEME_VEC_ELS(vec)[2] = NULL; - scheme_hash_set(tables, scheme_make_integer(1), vec); - } - - /* Put initial requires into the table: - (This is redundant for the rename set, but we need to fill - the `all_requires' table, etc.) */ - modidx_cache = scheme_make_hash_table_equal(); - { - Scheme_Module *iim; - Scheme_Object *nmidx, *orig_src; - - /* stx src of original import: */ - orig_src = env->genv->module->ii_src; - if (!orig_src) - orig_src = scheme_false; - else if (!SCHEME_STXP(orig_src)) - orig_src = scheme_false; - - nmidx = SCHEME_CAR(env->genv->module->requires); - iim = module_load(scheme_module_resolve(nmidx, 1), env->genv, NULL); - - add_simple_require_renames(orig_src, rn_set, tables, - iim, nmidx, - scheme_make_integer(0), - NULL, 1); - - scheme_hash_set(modidx_cache, ((Scheme_Modidx *)nmidx)->path, nmidx); - } - { Scheme_Object *v; v = scheme_rename_to_stx(rn_set); env->genv->module->rn_stx = v; } - provided = scheme_make_hash_table(SCHEME_hash_ptr); all_provided = scheme_make_hash_table_equal(); - scheme_hash_set(all_provided, scheme_make_integer(0), (Scheme_Object *)provided); - all_reprovided = scheme_make_hash_table_equal(); + all_defs = scheme_make_hash_tree(1); + all_defs_out = scheme_make_hash_table_equal(); - all_defs_out = scheme_null; - all_et_defs_out = scheme_null; + post_ex_rn_set = scheme_make_module_rename_set(mzMOD_RENAME_MARKED, rn_set, env->genv->module->insp); - all_defs = scheme_null; - all_et_defs = scheme_null; + /* It's possible that #%module-begin expansion introduces + marked identifiers for definitions. */ + form = scheme_add_rename(form, post_ex_rn_set); - exp_body = scheme_null; + observer = rec[drec].observer; + SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, form); + + _num_phases = MALLOC_ONE_ATOMIC(int); + *_num_phases = 0; + + all_simple_renames = (int *)scheme_malloc_atomic(sizeof(int)); + *all_simple_renames = 1; + + bxs = scheme_malloc(sizeof(Module_Begin_Expand_State)); + bxs->post_ex_rn_set = post_ex_rn_set; + bxs->tables = tables; + bxs->all_provided = all_provided; + bxs->all_reprovided = all_reprovided; + bxs->all_defs = all_defs; + bxs->all_defs_out = all_defs_out; + bxs->all_simple_renames = all_simple_renames; + bxs->_num_phases = _num_phases; + bxs->saved_provides = scheme_null; + bxs->modidx_cache = modidx_cache; + bxs->redef_modname = redef_modname; + + body_lists = do_module_begin_at_phase(form, env, + rec, drec, + rec[drec].comp ? NULL : rec, drec, + 0, + scheme_null, + bxs); + num_phases = *_num_phases; + + /* Compute provides for re-provides and all-defs-out: */ + (void)compute_reprovides(all_provided, + all_reprovided, + env->genv->module, + tables, + env->genv, + num_phases, + bxs->all_defs, all_defs_out, + "require", NULL, NULL); + + exp_infos = MALLOC_N(Scheme_Module_Export_Info*, num_phases); + for (i = 0; i < num_phases; i++) { + exp_info = MALLOC_ONE_RT(Scheme_Module_Export_Info); + SET_REQUIRED_TAG(exp_info->type = scheme_rt_export_info); + exp_infos[i] = exp_info; + } + + /* Compute provide arrays */ + compute_provide_arrays(all_provided, tables, + env->genv->module->me, + env->genv, + form, + num_phases, exp_infos); + + /* Compute indirect provides (which is everything at the top-level): */ + genv = env->genv; + for (i = 0; i < num_phases; i++) { + switch (i) { + case 0: + pt = env->genv->module->me->rt; + break; + case 1: + pt = env->genv->module->me->et; + break; + default: + if (env->genv->module->me->other_phases) + pt = (Scheme_Module_Phase_Exports *)scheme_hash_get(env->genv->module->me->other_phases, + scheme_make_integer(i)); + else + pt = NULL; + break; + } + if (pt) { + exis = compute_indirects(genv, pt, &exicount, 1); + exp_infos[i]->indirect_provides = exis; + exp_infos[i]->num_indirect_provides = exicount; + exis = compute_indirects(genv, pt, &exicount, 0); + exp_infos[i]->indirect_syntax_provides = exis; + exp_infos[i]->num_indirect_syntax_provides = exicount; + } + genv = genv->exp_env; + } + + if (rec[drec].comp || (rec[drec].depth != -2)) { + scheme_clean_dead_env(env->genv); + } + + if (!rec[drec].comp) { + Scheme_Module_Phase_Exports *rt = env->genv->module->me->rt; + int excount = rt->num_provides; + int exvcount = rt->num_var_provides; + Scheme_Object **exsns = rt->provide_src_names; + Scheme_Object **exs = rt->provides; + Scheme_Object **exss = rt->provide_srcs; + + /* Produce annotations (in the form of properties) + for module information: + 'module-variable-provides = '(item ...) + 'module-syntax-provides = '(item ...) + 'module-indirect-provides = '(id ...) + 'module-kernel-reprovide-hint = 'kernel-reexport + + item = name + | (ext-id . def-id) + | (modidx ext-id . def-id) + kernel-reexport = #f + | #t + | exclusion-id + */ + int j; + Scheme_Object *e, *a, *result; + + result = scheme_null; + + /* kernel re-export info (always #f): */ + result = scheme_make_pair(scheme_false, result); + + /* Indirect provides */ + a = scheme_null; + for (j = 0; j < exp_infos[0]->num_indirect_provides; j++) { + a = scheme_make_pair(exp_infos[0]->indirect_provides[j], a); + } + result = scheme_make_pair(a, result); + + /* add syntax and value exports: */ + for (j = 0; j < 2; j++) { + int top, i; + + e = scheme_null; + + if (!j) { + i = exvcount; + top = excount; + } else { + i = 0; + top = exvcount; + } + + for (; i < top; i++) { + if (SCHEME_FALSEP(exss[i]) + && SAME_OBJ(exs[i], exsns[i])) + a = exs[i]; + else { + a = scheme_make_pair(exs[i], exsns[i]); + if (!SCHEME_FALSEP(exss[i])) { + a = scheme_make_pair(exss[i], a); + } + } + e = scheme_make_pair(a, e); + } + result = scheme_make_pair(e, result); + } + + env->genv->module->hints = result; + } + + if (rec[drec].comp) { + Scheme_Object *a, **bodies; + + bodies = MALLOC_N(Scheme_Object*, num_phases); + for (i = 0; i < num_phases; i++) { + a = SCHEME_CAR(body_lists); + if (i > 0) a = scheme_reverse(a); + a = scheme_list_to_vector(a); + bodies[i] = a; + body_lists = SCHEME_CDR(body_lists); + } + env->genv->module->bodies = bodies; + env->genv->module->num_phases = num_phases; + + env->genv->module->exp_infos = exp_infos; + + if (!*all_simple_renames) { + /* No need to keep indirect syntax provides */ + for (i = 0; i < num_phases; i++) { + exp_infos[i]->indirect_syntax_provides = NULL; + exp_infos[i]->num_indirect_syntax_provides = 0; + } + } + + if (*all_simple_renames) { + env->genv->module->rn_stx = scheme_true; + } + + return (Scheme_Object *)env->genv->module; + } else { + Scheme_Object *p; + + if (rec[drec].depth == -2) { + /* This was a local expand. Flush definitions, because the body expand may start over. */ + flush_definitions(env->genv); + if (env->genv->exp_env) + flush_definitions(env->genv->exp_env); + } + + p = SCHEME_STX_CAR(form); + + return scheme_datum_to_syntax(cons(p, body_lists), orig_form, orig_form, 0, 2); + } +} + +#define DONE_MODFORM_KIND 0 +#define EXPR_MODFORM_KIND 1 +#define DEFN_MODFORM_KIND 2 +#define PROVIDE_MODFORM_KIND 3 +#define SAVED_MODFORM_KIND 4 + +static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Compile_Expand_Info *rec, int drec, + Scheme_Compile_Expand_Info *erec, int derec, + int phase, + Scheme_Object *body_lists, /* starts from phase + 1; null in expand mode */ + Module_Begin_Expand_State *bxs) +/* Result in expand mode is expressions in order. + Result in compile mode is a body_lists starting with `phase', + where a body_lists has each phase in order, with each list after the first in reverse order. + If both rec[drec].comp && erec, cons results. + If !rec[drec].comp, then erec is non-NULL. */ +{ + Scheme_Object *fm, *first, *last, *p, *rn_set, *rn, *exp_body, *self_modidx, *prev_p; + Scheme_Object *expanded_l; + Scheme_Comp_Env *xenv, *cenv, *rhs_env; + Scheme_Hash_Table *required; /* name -> (vector nominal-modidx-list modidx srcname var? prntname) + first nominal-modidx goes with modidx, rest are for re-provides */ + Scheme_Hash_Table *provided; /* exname -> (cons locname-stx-or-sym protected?) */ + Scheme_Object *all_rt_defs; /* list of stxid; this is almost redundant to the syntax and toplevel + tables, but it preserves the original name for exporting */ + Scheme_Hash_Tree *adt; + Scheme_Object *post_ex_rn; /* renames for ids introduced by expansion */ + Scheme_Object *lift_data; + Scheme_Object *lift_ctx; + Scheme_Object *lifted_reqs = scheme_null, *req_data, *unbounds = scheme_null; + int maybe_has_lifts = 0; + Scheme_Object *observer, *vec; + Scheme_Object *define_values_stx, *begin_stx, *define_syntaxes_stx, *begin_for_syntax_stx, *req_stx, *prov_stx, *sv[6]; + + if (*bxs->_num_phases < phase + 1) + *bxs->_num_phases = phase + 1; + + /* Expand each expression in form up to `begin', `define-values', `define-syntax', + `require', `provide', `#%app', etc. */ + xenv = scheme_new_compilation_frame(0, (SCHEME_CAPTURE_WITHOUT_RENAME + | SCHEME_MODULE_BEGIN_FRAME + | SCHEME_FOR_STOPS), + env); + + install_stops(xenv, phase, sv); + + define_values_stx = sv[0]; + begin_stx = sv[1]; + define_syntaxes_stx = sv[2]; + begin_for_syntax_stx = sv[3]; + req_stx = sv[4]; + prov_stx = sv[5]; + + first = scheme_null; + last = NULL; + + rn_set = env->genv->rename_set; + rn = scheme_get_module_rename_from_set(rn_set, scheme_make_integer(phase), 1); + + vec = scheme_hash_get(bxs->tables, scheme_make_integer(phase)); + if (!vec) { + required = scheme_make_hash_table(SCHEME_hash_ptr); + vec = scheme_make_vector(3, NULL); + SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)env->genv->toplevel; + SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)required; + SCHEME_VEC_ELS(vec)[2] = (Scheme_Object *)env->genv->syntax; + scheme_hash_set(bxs->tables, scheme_make_integer(phase), vec); + } else + required = (Scheme_Hash_Table *)SCHEME_VEC_ELS(vec)[1]; + + if (phase == 0) { + /* Put initial requires into the table: + (This is redundant for the rename set, but we need to fill + the `all_requires' table, etc.) */ + { + Scheme_Module *iim; + Scheme_Object *nmidx, *orig_src; + + /* stx src of original import: */ + orig_src = env->genv->module->ii_src; + if (!orig_src) + orig_src = scheme_false; + else if (!SCHEME_STXP(orig_src)) + orig_src = scheme_false; + + nmidx = SCHEME_CAR(env->genv->module->requires); + iim = module_load(scheme_module_resolve(nmidx, 1), env->genv, NULL); + + add_simple_require_renames(orig_src, rn_set, bxs->tables, + iim, nmidx, + scheme_make_integer(0), + NULL, 1); + + scheme_hash_set(bxs->modidx_cache, ((Scheme_Modidx *)nmidx)->path, nmidx); + } + } + + provided = (Scheme_Hash_Table *)scheme_hash_get(bxs->all_provided, scheme_make_integer(phase)); + if (!provided) { + provided = scheme_make_hash_table(SCHEME_hash_ptr); + scheme_hash_set(bxs->all_provided, scheme_make_integer(phase), (Scheme_Object *)provided); + } + + all_rt_defs = scheme_hash_tree_get(bxs->all_defs, scheme_make_integer(phase)); + if (!all_rt_defs) all_rt_defs = scheme_null; + + if (SCHEME_NULLP(body_lists)) + exp_body = scheme_null; + else { + exp_body = SCHEME_CAR(body_lists); + body_lists = SCHEME_CDR(body_lists); + } self_modidx = env->genv->module->self_modidx; - post_ex_rn_set = scheme_make_module_rename_set(mzMOD_RENAME_MARKED, rn_set, env->genv->module->insp); - post_ex_rn = scheme_get_module_rename_from_set(post_ex_rn_set, scheme_make_integer(0), 1); - post_ex_et_rn = scheme_get_module_rename_from_set(post_ex_rn_set, scheme_make_integer(1), 1); - env->genv->post_ex_rename_set = post_ex_rn_set; + post_ex_rn = scheme_get_module_rename_from_set(bxs->post_ex_rn_set, scheme_make_integer(phase), 1); + env->genv->post_ex_rename_set = bxs->post_ex_rn_set; /* For syntax-local-context, etc., in a d-s RHS: */ rhs_env = scheme_new_comp_env(env->genv, env->insp, SCHEME_TOPLEVEL_FRAME); observer = rec[drec].observer; - /* It's possible that #%module-begin expansion introduces - marked identifiers for definitions. */ - form = scheme_add_rename(form, post_ex_rn_set); - SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, form); - maybe_has_lifts = 0; lift_ctx = scheme_generate_lifts_key(); - all_simple_renames = (int *)scheme_malloc_atomic(sizeof(int)); - *all_simple_renames = 1; - req_data = package_require_data(self_modidx, env->genv, env->genv->module, - rn_set, post_ex_rn_set, - tables, - redef_modname, - all_simple_renames); + rn_set, bxs->post_ex_rn_set, + bxs->tables, + bxs->redef_modname, + bxs->all_simple_renames); /* Pass 1 */ @@ -6292,10 +6623,10 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env if (!SCHEME_NULLP(fst)) { /* Expansion lifted expressions, so add them to the front and try again. */ - *all_simple_renames = 0; + *bxs->all_simple_renames = 0; fm = SCHEME_STX_CDR(fm); - e = scheme_add_rename(e, post_ex_rn_set); - fm = scheme_named_map_1(NULL, add_a_rename, fm, post_ex_rn_set); + e = scheme_add_rename(e, bxs->post_ex_rn_set); + fm = scheme_named_map_1(NULL, add_a_rename, fm, bxs->post_ex_rn_set); fm = scheme_make_pair(e, fm); SCHEME_EXPAND_OBSERVE_RENAME_LIST(observer, fm); fm = scheme_append(fst, fm); @@ -6307,9 +6638,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env else fst = NULL; - if (fst && SCHEME_STX_SYMBOLP(fst) && scheme_stx_module_eq(scheme_begin_stx, fst, 0)) { + if (fst && SCHEME_STX_SYMBOLP(fst) && scheme_stx_module_eq(begin_stx, fst, phase)) { fm = SCHEME_STX_CDR(fm); - e = scheme_add_rename(e, post_ex_rn_set); + e = scheme_add_rename(e, bxs->post_ex_rn_set); SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, e); fm = scheme_flatten_begin(e, fm); SCHEME_EXPAND_OBSERVE_SPLICE(observer, fm); @@ -6333,7 +6664,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env } if (!e) break; /* (begin) expansion at end */ - e = scheme_add_rename(e, post_ex_rn_set); + e = scheme_add_rename(e, bxs->post_ex_rn_set); SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, e); @@ -6346,7 +6677,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env Scheme_Object *n; n = SCHEME_STX_CAR(e); - if (scheme_stx_module_eq(scheme_define_values_stx, fst, 0)) { + if (scheme_stx_module_eq(define_values_stx, fst, phase)) { /************ define-values *************/ Scheme_Object *vars, *val; @@ -6364,7 +6695,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env orig_name = name; /* Remember the original: */ - all_defs = scheme_make_pair(name, all_defs); + all_rt_defs = scheme_make_pair(name, all_rt_defs); name = scheme_tl_id_sym(env->genv, name, NULL, 2, NULL, NULL); @@ -6391,21 +6722,21 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env /* Add a renaming: */ if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name)) { - scheme_extend_module_rename(post_ex_rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, 0); - *all_simple_renames = 0; + scheme_extend_module_rename(post_ex_rn, self_modidx, name, name, self_modidx, name, phase, NULL, NULL, 0); + *bxs->all_simple_renames = 0; } else - scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, 0); + scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, phase, NULL, NULL, 0); vars = SCHEME_STX_CDR(vars); } SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e); - kind = 2; - } else if (scheme_stx_module_eq(scheme_define_syntaxes_stx, fst, 0) - || scheme_stx_module_eq(scheme_define_for_syntaxes_stx, fst, 0)) { - /************ define-syntaxes & define-values-for-syntax *************/ + kind = DEFN_MODFORM_KIND; + } else if (scheme_stx_module_eq(define_syntaxes_stx, fst, phase) + || scheme_stx_module_eq(begin_for_syntax_stx, fst, phase)) { + /************ define-syntaxes & begin-for-syntax *************/ /* Define the macro: */ - Scheme_Compile_Info mrec; + Scheme_Compile_Info mrec, erec1; Scheme_Object *names, *l, *code, *m, *vec, *boundname; Resolve_Prefix *rp; Resolve_Info *ri; @@ -6416,79 +6747,80 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env int use_post_ex = 0; int max_let_depth; - for_stx = scheme_stx_module_eq(scheme_define_for_syntaxes_stx, fst, 0); - + for_stx = scheme_stx_module_eq(begin_for_syntax_stx, fst, phase); + SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e); SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(observer); - scheme_define_parse(e, &names, &code, 1, env, 1); + if (for_stx) { + if (scheme_stx_proper_list_length(e) < 0) + scheme_wrong_syntax(NULL, NULL, e, NULL); + code = e; + } else + scheme_define_parse(e, &names, &code, 1, env, 1); - if (SCHEME_STX_PAIRP(names) && SCHEME_STX_NULLP(SCHEME_STX_CDR(names))) - boundname = SCHEME_STX_CAR(names); - else - boundname = scheme_false; + if (!for_stx && SCHEME_STX_PAIRP(names) && SCHEME_STX_NULLP(SCHEME_STX_CDR(names))) + boundname = SCHEME_STX_CAR(names); + else + boundname = scheme_false; scheme_prepare_exp_env(env->genv); scheme_prepare_compile_env(env->genv->exp_env); eenv = scheme_new_comp_env(env->genv->exp_env, env->insp, 0); - scheme_frame_captures_lifts(eenv, NULL, NULL, scheme_false, scheme_false, - req_data, scheme_false); + if (!for_stx) + scheme_frame_captures_lifts(eenv, NULL, NULL, scheme_false, scheme_false, + req_data, scheme_false); - oenv = (for_stx ? eenv : env); + oenv = env; - for (l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - Scheme_Object *name, *orig_name; - name = SCHEME_STX_CAR(l); + if (!for_stx) { + for (l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { + Scheme_Object *name, *orig_name; + name = SCHEME_STX_CAR(l); - orig_name = name; + orig_name = name; - /* Remember the original: */ - if (!for_stx) - all_defs = scheme_make_pair(name, all_defs); - else - all_et_defs = scheme_make_pair(name, all_et_defs); + /* Remember the original: */ + all_rt_defs = scheme_make_pair(name, all_rt_defs); - name = scheme_tl_id_sym(oenv->genv, name, NULL, 2, NULL, NULL); + name = scheme_tl_id_sym(oenv->genv, name, NULL, 2, NULL, NULL); - if (scheme_lookup_in_table(oenv->genv->syntax, (const char *)name)) { - scheme_wrong_syntax("module", orig_name, e, - (for_stx - ? "duplicate for-syntax definition for identifier" - : "duplicate definition for identifier")); - return NULL; - } + if (scheme_lookup_in_table(oenv->genv->syntax, (const char *)name)) { + scheme_wrong_syntax("module", orig_name, e, + "duplicate definition for identifier"); + return NULL; + } - /* Check that it's not yet defined: */ - if (scheme_lookup_in_table(oenv->genv->toplevel, (const char *)name)) { - scheme_wrong_syntax("module", orig_name, e, - (for_stx - ? "duplicate for-syntax definition for identifier" - : "duplicate definition for identifier")); - return NULL; - } + /* Check that it's not yet defined: */ + if (scheme_lookup_in_table(oenv->genv->toplevel, (const char *)name)) { + scheme_wrong_syntax("module", orig_name, e, + "duplicate definition for identifier"); + return NULL; + } - /* Not required: */ - if (check_already_required(for_stx ? et_required : required, name)) { - scheme_wrong_syntax("module", orig_name, e, - (for_stx - ? "identifier is already imported for syntax" - : "identifier is already imported")); - return NULL; - } + /* Not required: */ + if (check_already_required(required, name)) { + scheme_wrong_syntax("module", orig_name, e, "identifier is already imported"); + return NULL; + } - if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name)) { - scheme_extend_module_rename(for_stx ? post_ex_et_rn : post_ex_rn, self_modidx, name, name, self_modidx, name, - for_stx ? 1 : 0, NULL, NULL, 0); - *all_simple_renames = 0; - use_post_ex = 1; - } else - scheme_extend_module_rename(for_stx ? et_rn : rn, self_modidx, name, name, self_modidx, name, - for_stx ? 1 : 0, NULL, NULL, 0); + if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name)) { + scheme_extend_module_rename(post_ex_rn, self_modidx, name, name, self_modidx, name, + phase, NULL, NULL, 0); + *bxs->all_simple_renames = 0; + use_post_ex = 1; + } else + scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, + phase, NULL, NULL, 0); - count++; - } + count++; + } + } - names = scheme_named_map_1(NULL, stx_sym, names, (Scheme_Object *)oenv->genv); + if (for_stx) + names = NULL; + else + names = scheme_named_map_1(NULL, stx_sym, names, (Scheme_Object *)oenv->genv); mrec.comp = 1; mrec.dont_mark_local_use = 0; @@ -6499,21 +6831,50 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env mrec.env_already = 0; mrec.comp_flags = rec[drec].comp_flags; - if (!rec[drec].comp) { - Scheme_Expand_Info erec1; - erec1.comp = 0; - erec1.depth = -1; - erec1.value_name = boundname; + if (erec) { + erec1.comp = 0; + erec1.depth = -1; + erec1.value_name = boundname; erec1.observer = rec[drec].observer; erec1.pre_unwrapped = 0; erec1.env_already = 0; erec1.comp_flags = rec[drec].comp_flags; - SCHEME_EXPAND_OBSERVE_PHASE_UP(observer); - code = scheme_expand_expr_lift_to_let(code, eenv, &erec1, 0); - } - m = scheme_compile_expr_lift_to_let(code, eenv, &mrec, 0); + } - lifted_reqs = scheme_append(scheme_frame_get_require_lifts(eenv), lifted_reqs); + if (for_stx) { + adt = scheme_hash_tree_set(bxs->all_defs, scheme_make_integer(phase), all_rt_defs); + bxs->all_defs = adt; + if (erec) { + SCHEME_EXPAND_OBSERVE_PHASE_UP(observer); /* FIXME [Ryan?]? */ + /* We expand & compile the for-syntax code in one pass. */ + } + m = do_module_begin_at_phase(code, eenv, + &mrec, 0, + (erec ? &erec1 : NULL), 0, + phase + 1, body_lists, + bxs); + if (erec) { + code = SCHEME_STX_CAR(code); + code = scheme_make_pair(code, SCHEME_CAR(m)); + m = SCHEME_CDR(m); + } + if (rec[drec].comp) + body_lists = SCHEME_CDR(m); + m = SCHEME_CAR(m); + /* turn list of compiled expressions into a splice: */ + m = scheme_make_sequence_compilation(m, 0); + if (m->type == scheme_sequence_type) + m->type = scheme_splice_sequence_type; + } else { + if (erec) { + SCHEME_EXPAND_OBSERVE_PHASE_UP(observer); + code = scheme_expand_expr_lift_to_let(code, eenv, &erec1, 0); + } + m = scheme_compile_expr_lift_to_let(code, eenv, &mrec, 0); + } + + if (!for_stx) + lifted_reqs = scheme_append(scheme_frame_get_require_lifts(eenv), lifted_reqs); oi = scheme_optimize_info_create(); scheme_optimize_info_set_context(oi, (Scheme_Object *)env->genv->module); @@ -6533,9 +6894,11 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env /* Add code with names and lexical depth to exp-time body: */ vec = scheme_make_vector(5, NULL); - SCHEME_VEC_ELS(vec)[0] = ((SCHEME_PAIRP(names) && SCHEME_NULLP(SCHEME_CDR(names))) - ? SCHEME_CAR(names) - : names); + SCHEME_VEC_ELS(vec)[0] = (for_stx + ? scheme_false + : ((SCHEME_PAIRP(names) && SCHEME_NULLP(SCHEME_CDR(names))) + ? SCHEME_CAR(names) + : names)); SCHEME_VEC_ELS(vec)[1] = m; SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(max_let_depth); SCHEME_VEC_ELS(vec)[3] = (Scheme_Object *)rp; @@ -6551,52 +6914,59 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env rp = scheme_prefix_eval_clone(rp); eval_exptime(names, count, m, eenv->genv, rhs_env, rp, max_let_depth, 0, - (for_stx ? env->genv->exp_env->toplevel : env->genv->syntax), for_stx, + (for_stx ? env->genv->exp_env->toplevel : env->genv->syntax), + phase + 1, for_stx ? scheme_false : (use_post_ex ? post_ex_rn : rn), NULL); - if (rec[drec].comp) - e = NULL; - else { - m = SCHEME_STX_CDR(e); - m = SCHEME_STX_CAR(m); - m = scheme_make_pair(fst, - scheme_make_pair(m, scheme_make_pair(code, scheme_null))); + if (erec) { + if (for_stx) { + m = code; + } else { + m = SCHEME_STX_CDR(e); + m = SCHEME_STX_CAR(m); + m = scheme_make_pair(fst, + scheme_make_pair(m, scheme_make_pair(code, scheme_null))); + } e = scheme_datum_to_syntax(m, e, e, 0, 2); - } + } else + e = NULL; SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e); - kind = 0; - } else if (scheme_stx_module_eq(require_stx, fst, 0)) { + + kind = DONE_MODFORM_KIND; + } else if (scheme_stx_module_eq(req_stx, fst, phase)) { /************ require *************/ SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e); SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE(observer); /* Adds requires to renamings and required modules to requires lists: */ - parse_requires(e, self_modidx, env->genv, env->genv->module, - rn_set, post_ex_rn_set, - check_require_name, tables, - redef_modname, + parse_requires(e, phase, self_modidx, env->genv, env->genv->module, + rn_set, bxs->post_ex_rn_set, + check_require_name, bxs->tables, + bxs->redef_modname, 0, 0, 1, - 1, 0, - all_simple_renames, modidx_cache); + 1, phase ? 1 : 0, + bxs->all_simple_renames, bxs->modidx_cache); - if (rec[drec].comp) + if (!erec) e = NULL; SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e); - kind = 0; - } else if (scheme_stx_module_eq(provide_stx, fst, 0)) { + kind = DONE_MODFORM_KIND; + } else if (scheme_stx_module_eq(prov_stx, fst, phase)) { /************ provide *************/ - /* remember it for the second pass */ - kind = 3; - } else { - kind = 1; - } + /* remember it for pass 3 */ + p = scheme_make_pair(scheme_make_pair(e, scheme_make_integer(phase)), + bxs->saved_provides); + bxs->saved_provides = p; + kind = PROVIDE_MODFORM_KIND; + } else + kind = EXPR_MODFORM_KIND; } else - kind = 1; + kind = EXPR_MODFORM_KIND; } else - kind = 1; + kind = EXPR_MODFORM_KIND; if (e) { p = scheme_make_pair(scheme_make_pair(e, scheme_make_integer(kind)), scheme_null); @@ -6623,17 +6993,362 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env } /* first = a list of (cons semi-expanded-expression kind) */ - /* Bound names will not be re-bound at this point: */ - if (rec[drec].comp || (rec[drec].depth != -2)) { - scheme_seal_module_rename_set(rn_set, STX_SEAL_BOUND); - } - scheme_seal_module_rename_set(post_ex_rn_set, STX_SEAL_BOUND); + if (!phase) { + /* Bound names will not be re-bound at this point: */ + if (!erec || (erec[derec].depth != -2)) { + scheme_seal_module_rename_set(rn_set, STX_SEAL_BOUND); + } + scheme_seal_module_rename_set(bxs->post_ex_rn_set, STX_SEAL_BOUND); + + /* Check that all bindings used in phase-N expressions (for N >= 1) + were defined by now: */ + check_formerly_unbound(unbounds, env); + } + + /* Pass 2 */ + SCHEME_EXPAND_OBSERVE_NEXT_GROUP(observer); + + if (rec[drec].comp) { + /* Module and each `begin-for-syntax' group manages its own prefix: */ + cenv = scheme_new_comp_env(env->genv, env->insp, SCHEME_TOPLEVEL_FRAME); + } else + cenv = scheme_extend_as_toplevel(env); + + lift_data = scheme_make_vector(3, NULL); + SCHEME_VEC_ELS(lift_data)[0] = (Scheme_Object *)cenv; + SCHEME_VEC_ELS(lift_data)[1] = self_modidx; + SCHEME_VEC_ELS(lift_data)[2] = rn; + + maybe_has_lifts = 0; + + prev_p = NULL; + expanded_l = scheme_null; + for (p = first; !SCHEME_NULLP(p); ) { + Scheme_Object *e, *l, *ll; + int kind; + + e = SCHEME_CAR(p); + kind = SCHEME_INT_VAL(SCHEME_CDR(e)); + e = SCHEME_CAR(e); + + SCHEME_EXPAND_OBSERVE_NEXT(observer); + + if (kind == SAVED_MODFORM_KIND) { + expanded_l = scheme_make_pair(SCHEME_CDR(e), expanded_l); + SCHEME_CAR(p) = SCHEME_CAR(e); + prev_p = p; + p = SCHEME_CDR(p); + } else if (kind == PROVIDE_MODFORM_KIND) { + /* handle provides in the third pass */ + if (erec) + expanded_l = scheme_make_pair(e, expanded_l); + if (rec[drec].comp) { + if (!prev_p) + first = SCHEME_CDR(p); + else + SCHEME_CDR(prev_p) = SCHEME_CDR(p); + } + p = SCHEME_CDR(p); + } else if ((kind == EXPR_MODFORM_KIND) + || (kind == DEFN_MODFORM_KIND)) { + Scheme_Comp_Env *nenv; + + l = (maybe_has_lifts + ? scheme_frame_get_end_statement_lifts(cenv) + : scheme_null); + ll = (maybe_has_lifts + ? scheme_frame_get_provide_lifts(cenv) + : scheme_null); + scheme_frame_captures_lifts(cenv, add_lifted_defn, lift_data, l, lift_ctx, req_data, ll); + maybe_has_lifts = 1; + + if (kind == DEFN_MODFORM_KIND) + nenv = cenv; + else + nenv = scheme_new_compilation_frame(0, 0, cenv); + + if (erec) { + Scheme_Expand_Info erec1; + scheme_init_expand_recs(rec, drec, &erec1, 1); + erec1.value_name = scheme_false; + e = scheme_expand_expr(e, nenv, &erec1, 0); + expanded_l = scheme_make_pair(e, expanded_l); + } + + if (rec[drec].comp) { + Scheme_Compile_Info crec1; + scheme_init_compile_recs(rec, drec, &crec1, 1); + crec1.resolve_module_ids = 0; + e = scheme_compile_expr(e, nenv, &crec1, 0); + } + + lifted_reqs = scheme_append(scheme_frame_get_require_lifts(cenv), lifted_reqs); + + l = scheme_frame_get_lifts(cenv); + if (SCHEME_NULLP(l)) { + /* No lifts - continue normally */ + SCHEME_CAR(p) = e; + prev_p = p; + p = SCHEME_CDR(p); + } else { + /* Lifts - insert them and try again */ + *bxs->all_simple_renames = 0; + SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(observer, scheme_copy_list(l)); + if (erec) { + e = scheme_make_pair(scheme_make_pair(e, SCHEME_CAR(expanded_l)), + scheme_make_integer(4)); /* kept both expanded & maybe compiled */ + /* add back expanded at correct position later: */ + expanded_l = SCHEME_CDR(expanded_l); + } else + e = scheme_make_pair(e, scheme_make_integer(0)); /* don't re-compile/-expand */ + SCHEME_CAR(p) = e; + for (ll = l; SCHEME_PAIRP(ll); ll = SCHEME_CDR(ll)) { + e = scheme_make_pair(SCHEME_CAR(ll), scheme_make_integer(2)); + SCHEME_CAR(ll) = e; + } + p = scheme_append(l, p); + if (prev_p) { + SCHEME_CDR(prev_p) = p; + } else { + first = p; + } + } + } else { + if (erec) + expanded_l = scheme_make_pair(e, expanded_l); + SCHEME_CAR(p) = e; + prev_p = p; + p = SCHEME_CDR(p); + } + + /* If we're out of declarations, check for lifted-to-end: */ + if (SCHEME_NULLP(p) && maybe_has_lifts) { + int expr_cnt; + Scheme_Object *sp; + e = scheme_frame_get_provide_lifts(cenv); + e = scheme_reverse(e); + p = scheme_frame_get_end_statement_lifts(cenv); + p = scheme_reverse(p); + expr_cnt = scheme_list_length(p); + if (!SCHEME_NULLP(e)) + p = scheme_append(p, e); + SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, p); + for (ll = p; SCHEME_PAIRP(ll); ll = SCHEME_CDR(ll)) { + e = SCHEME_CAR(ll); + if (expr_cnt <= 0) { + sp = scheme_make_pair(scheme_make_pair(e, scheme_make_integer(phase)), + bxs->saved_provides); + bxs->saved_provides = sp; + } + e = scheme_make_pair(e, ((expr_cnt > 0) + ? scheme_make_integer(EXPR_MODFORM_KIND) + : scheme_make_integer(PROVIDE_MODFORM_KIND))); + SCHEME_CAR(ll) = e; + expr_cnt--; + } + maybe_has_lifts = 0; + if (prev_p) { + SCHEME_CDR(prev_p) = p; + } else { + first = p; + } + } + } + if (erec) expanded_l = scheme_reverse(expanded_l); + + adt = scheme_hash_tree_set(bxs->all_defs, scheme_make_integer(phase), all_rt_defs); + bxs->all_defs = adt; + + /* Pass 3 */ + /* if at phase 0, expand provides for all phases */ + if (phase == 0) { + Scheme_Object *expanded_provides; + + expanded_provides = expand_all_provides(form, cenv, rec, drec, self_modidx, + bxs, !!erec); + + if (erec) { + expanded_provides = scheme_reverse(expanded_provides); + (void)fixup_expanded_provides(expanded_l, expanded_provides, 0); + } + } + + /* first = a list of compiled expressions */ + /* expanded_l = reversed list of expanded expressions */ + + /* If compiling, drop expressions that are constants: */ + if (rec[drec].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)) { + if (prev) + SCHEME_CDR(prev) = next; + else + first = next; + } else + prev = p; + } + } + + if (phase == 0) { + if (rec[drec].comp || (rec[drec].depth != -2)) { + scheme_seal_module_rename_set(rn_set, STX_SEAL_ALL); + } + scheme_seal_module_rename_set(bxs->post_ex_rn_set, STX_SEAL_ALL); + } + + adt = scheme_hash_tree_set(bxs->all_defs, scheme_make_integer(phase), all_rt_defs); + bxs->all_defs = adt; + + if (!phase) + env->genv->module->comp_prefix = cenv->prefix; + else + env->prefix = cenv->prefix; + + if (!SCHEME_NULLP(exp_body)) { + if (*bxs->_num_phases < phase + 2) + *bxs->_num_phases = phase + 2; + } + + if (erec) { + /* Add lifted requires */ + if (!SCHEME_NULLP(lifted_reqs)) { + lifted_reqs = scheme_reverse(lifted_reqs); + expanded_l = scheme_append(lifted_reqs, expanded_l); + } + } + + if (rec[drec].comp) { + body_lists = scheme_make_pair(first, scheme_make_pair(exp_body, body_lists)); + if (erec) + return scheme_make_pair(expanded_l, body_lists); + else + return body_lists; + } else + return expanded_l; +} + +static Scheme_Object *expand_all_provides(Scheme_Object *form, + Scheme_Comp_Env *cenv, + Scheme_Compile_Expand_Info *rec, int drec, + Scheme_Object *self_modidx, + Module_Begin_Expand_State *bxs, + int keep_expanded) +/* expands `#%provide's for all phases in a module that is otherwise + fully expanded; returns a list of expanded forms in reverse order, + if requested by `keep_expanded'. */ +{ + Scheme_Object *saved_provides; + Scheme_Object *observer, *expanded_provides = scheme_null; + int provide_phase; + Scheme_Object *e, *ex, *p_begin_stx, *fst; + Scheme_Comp_Env *pcenv; + + observer = rec[drec].observer; + + saved_provides = scheme_reverse(bxs->saved_provides); + while (!SCHEME_NULLP(saved_provides)) { + e = SCHEME_CAR(saved_provides); + provide_phase = SCHEME_INT_VAL(SCHEME_CDR(e)); + e = SCHEME_CAR(e); + + fst = SCHEME_STX_CAR(e); + + /* Expand and add provides to table: */ + + SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e); + SCHEME_EXPAND_OBSERVE_PRIM_PROVIDE(observer); + + ex = e; + + if (provide_phase != 0) { + Scheme_Env *penv = cenv->genv; + int k; + for (k = 0; k < provide_phase; k++) { + penv = penv->exp_env; + } + if (rec[drec].comp) + pcenv = scheme_new_comp_env(penv, penv->insp, SCHEME_TOPLEVEL_FRAME); + else + pcenv = scheme_new_expand_env(penv, penv->insp, SCHEME_TOPLEVEL_FRAME); + p_begin_stx = scheme_datum_to_syntax(scheme_intern_symbol("begin"), + scheme_false, + scheme_sys_wraps_phase_worker(provide_phase), + 0, 0); + } else { + pcenv = cenv; + p_begin_stx = scheme_begin_stx; + } + + parse_provides(form, fst, e, provide_phase, + bxs->all_provided, bxs->all_reprovided, + self_modidx, + bxs->all_defs_out, + bxs->tables, + bxs->all_defs, + pcenv, rec, drec, + &ex, + p_begin_stx); + + if (keep_expanded) + expanded_provides = scheme_make_pair(ex, expanded_provides); + + SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e); + + saved_provides = SCHEME_CDR(saved_provides); + } + + return expanded_provides; +} + +static Scheme_Object *fixup_expanded_provides(Scheme_Object *expanded_l, + Scheme_Object *expanded_provides, + int phase) +/* mutates `expanded_l' to find `#%provide's (possibly nested in + `begin-for-syntax') and elace them with the ones in + `expanded_provides'. The provides in `expanded_l' and + `expanded_provides' are matched up by order. */ +{ + Scheme_Object *p, *e, *fst, *prov_stx, *begin_for_syntax_stx, *l; + + if (phase == 0) { + prov_stx = provide_stx; + begin_for_syntax_stx = scheme_begin_for_syntax_stx; + } else { + e = scheme_sys_wraps_phase_worker(phase); + begin_for_syntax_stx = scheme_datum_to_syntax(scheme_intern_symbol("begin-for-syntax"), scheme_false, e, 0, 0); + prov_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%provide"), scheme_false, e, 0, 0); + } + + for (p = expanded_l; !SCHEME_NULLP(p); p = SCHEME_CDR(p)) { + e = SCHEME_CAR(p); + if (SCHEME_STX_PAIRP(e)) { + fst = SCHEME_STX_CAR(e); + if (scheme_stx_module_eq(prov_stx, fst, 0)) { + SCHEME_CAR(p) = SCHEME_CAR(expanded_provides); + expanded_provides = SCHEME_CDR(expanded_provides); + } else if (scheme_stx_module_eq(begin_for_syntax_stx, fst, 0)) { + l = scheme_flatten_syntax_list(e, NULL); + expanded_provides = fixup_expanded_provides(SCHEME_CDR(l), expanded_provides, phase + 1); + e = scheme_datum_to_syntax(l, e, e, 0, 2); + SCHEME_CAR(p) = e; + } + } + } + + return expanded_provides; +} + +static void check_formerly_unbound(Scheme_Object *unbounds, + Scheme_Comp_Env *env) +{ + Scheme_Object *stack = scheme_null, *lst, *p; + Scheme_Env *uenv = env->genv->exp_env; - /* Check that all bindings used in phase-N expressions (for N >= 1) - were defined by now: */ while (!SCHEME_NULLP(unbounds)) { - Scheme_Object *stack = scheme_null, *lst; - Scheme_Env *uenv = env->genv->exp_env; + stack = scheme_null; + uenv = env->genv->exp_env; lst = SCHEME_CAR(unbounds); while(1) { @@ -6664,337 +7379,82 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env } unbounds = SCHEME_CDR(unbounds); } + /* Disallow unbound variables from now on: */ - { - Scheme_Env *uenv = env->genv->exp_env; - while (uenv) { - uenv->disallow_unbound = 1; - uenv = uenv->exp_env; - } + uenv = env->genv->exp_env; + while (uenv) { + uenv->disallow_unbound = 1; + uenv = uenv->exp_env; } +} - /* Pass 2 */ - SCHEME_EXPAND_OBSERVE_NEXT_GROUP(observer); - - if (rec[drec].comp) { - /* Module manages its own prefix. That's how we get - multiple instantiation of a module with "dynamic linking". */ - cenv = scheme_new_comp_env(env->genv, env->insp, SCHEME_TOPLEVEL_FRAME); - } else - cenv = scheme_extend_as_toplevel(env); +static void install_stops(Scheme_Comp_Env *xenv, int phase, Scheme_Object **sv) +{ + Scheme_Object *stop, *w, *s; - lift_data = scheme_make_vector(3, NULL); - SCHEME_VEC_ELS(lift_data)[0] = (Scheme_Object *)cenv; - SCHEME_VEC_ELS(lift_data)[1] = self_modidx; - SCHEME_VEC_ELS(lift_data)[2] = rn; + stop = scheme_get_stop_expander(); - maybe_has_lifts = 0; + scheme_add_local_syntax(19, xenv); - prev_p = NULL; - for (p = first; !SCHEME_NULLP(p); ) { - Scheme_Object *e, *l, *ll; - int kind; - - e = SCHEME_CAR(p); - kind = SCHEME_INT_VAL(SCHEME_CDR(e)); - e = SCHEME_CAR(e); - - SCHEME_EXPAND_OBSERVE_NEXT(observer); - - if (kind == 3) { - Scheme_Object *fst; - - fst = SCHEME_STX_CAR(e); - - if (scheme_stx_module_eq(provide_stx, fst, 0)) { - /************ provide *************/ - /* Add provides to table: */ - Scheme_Object *ex; - - SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e); - SCHEME_EXPAND_OBSERVE_PRIM_PROVIDE(observer); - - ex = e; - - parse_provides(form, fst, e, - all_provided, all_reprovided, - self_modidx, - &all_defs_out, &all_et_defs_out, - tables, - all_defs, all_et_defs, cenv, rec, drec, - &ex); - - e = ex; - - SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e); - } - if (!rec[drec].comp) { - SCHEME_CAR(p) = e; - prev_p = p; - p = SCHEME_CDR(p); - } else { - p = SCHEME_CDR(p); - if (!prev_p) - first = p; - else - SCHEME_CDR(prev_p) = p; - } - } else if (kind) { - Scheme_Comp_Env *nenv; - - l = (maybe_has_lifts - ? scheme_frame_get_end_statement_lifts(cenv) - : scheme_null); - ll = (maybe_has_lifts - ? scheme_frame_get_provide_lifts(cenv) - : scheme_null); - scheme_frame_captures_lifts(cenv, add_lifted_defn, lift_data, l, lift_ctx, req_data, ll); - maybe_has_lifts = 1; - - if (kind == 2) - nenv = cenv; - else - nenv = scheme_new_compilation_frame(0, 0, cenv); - - if (rec[drec].comp) { - Scheme_Compile_Info crec1; - scheme_init_compile_recs(rec, drec, &crec1, 1); - crec1.resolve_module_ids = 0; - e = scheme_compile_expr(e, nenv, &crec1, 0); - } else { - Scheme_Expand_Info erec1; - scheme_init_expand_recs(rec, drec, &erec1, 1); - erec1.value_name = scheme_false; - e = scheme_expand_expr(e, nenv, &erec1, 0); - } - - lifted_reqs = scheme_append(scheme_frame_get_require_lifts(cenv), lifted_reqs); - - l = scheme_frame_get_lifts(cenv); - if (SCHEME_NULLP(l)) { - /* No lifts - continue normally */ - SCHEME_CAR(p) = e; - prev_p = p; - p = SCHEME_CDR(p); - } else { - /* Lifts - insert them and try again */ - *all_simple_renames = 0; - SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(observer, scheme_copy_list(l)); - e = scheme_make_pair(e, scheme_make_integer(0)); /* don't re-compile/-expand */ - SCHEME_CAR(p) = e; - for (ll = l; SCHEME_PAIRP(ll); ll = SCHEME_CDR(ll)) { - e = scheme_make_pair(SCHEME_CAR(ll), scheme_make_integer(2)); - SCHEME_CAR(ll) = e; - } - p = scheme_append(l, p); - if (prev_p) { - SCHEME_CDR(prev_p) = p; - } else { - first = p; - } - } - } else { - SCHEME_CAR(p) = e; - prev_p = p; - p = SCHEME_CDR(p); - } - - /* If we're out of declarations, check for lifted-to-end: */ - if (SCHEME_NULLP(p) && maybe_has_lifts) { - int expr_cnt; - e = scheme_frame_get_provide_lifts(cenv); - e = scheme_reverse(e); - p = scheme_frame_get_end_statement_lifts(cenv); - p = scheme_reverse(p); - expr_cnt = scheme_list_length(p); - if (!SCHEME_NULLP(e)) - p = scheme_append(p, e); - SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, p); - for (ll = p; SCHEME_PAIRP(ll); ll = SCHEME_CDR(ll)) { - e = scheme_make_pair(SCHEME_CAR(ll), (expr_cnt > 0) ? scheme_make_integer(1) : scheme_make_integer(3)); - SCHEME_CAR(ll) = e; - expr_cnt--; - } - maybe_has_lifts = 0; - if (prev_p) { - SCHEME_CDR(prev_p) = p; - } else { - first = p; - } - } - } - /* first = a list of expanded/compiled expressions */ - - /* If compiling, drop expressions that are constants: */ - if (rec[drec].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)) { - if (prev) - SCHEME_CDR(prev) = next; - else - first = next; - } else - prev = p; - } - } - - if (rec[drec].comp || (rec[drec].depth != -2)) { - scheme_seal_module_rename_set(rn_set, STX_SEAL_ALL); - } - scheme_seal_module_rename_set(post_ex_rn_set, STX_SEAL_ALL); - - /* Compute provides for re-provides and all-defs-out: */ - (void)compute_reprovides(all_provided, - all_reprovided, - env->genv->module, - tables, - env->genv, - all_defs, all_defs_out, - all_et_defs, all_et_defs_out, - "require", NULL, NULL); - - /* Compute provide arrays */ - exps = compute_provide_arrays(all_provided, tables, - env->genv->module->me, - env->genv, - form, &et_exps); - - /* Compute indirect provides (which is everything at the top-level): */ - exis = compute_indirects(env->genv, env->genv->module->me->rt, &exicount, 1); - exsis = compute_indirects(env->genv, env->genv->module->me->rt, &exsicount, 0); - et_exis = compute_indirects(env->genv->exp_env, env->genv->module->me->et, &et_exicount, 1); - - if (rec[drec].comp || (rec[drec].depth != -2)) { - scheme_clean_dead_env(env->genv); - } - - if (!rec[drec].comp) { - Scheme_Module_Phase_Exports *rt = env->genv->module->me->rt; - int excount = rt->num_provides; - int exvcount = rt->num_var_provides; - Scheme_Object **exsns = rt->provide_src_names; - Scheme_Object **exs = rt->provides; - Scheme_Object **exss = rt->provide_srcs; - - /* Produce annotations (in the form of properties) - for module information: - 'module-variable-provides = '(item ...) - 'module-syntax-provides = '(item ...) - 'module-indirect-provides = '(id ...) - 'module-kernel-reprovide-hint = 'kernel-reexport - - item = name - | (ext-id . def-id) - | (modidx ext-id . def-id) - kernel-reexport = #f - | #t - | exclusion-id - */ - int j; - Scheme_Object *e, *a, *result; - - result = scheme_null; - - /* kernel re-export info (always #f): */ - result = scheme_make_pair(scheme_false, result); - - /* Indirect provides */ - a = scheme_null; - for (j = 0; j < exicount; j++) { - a = scheme_make_pair(exis[j], a); - } - result = scheme_make_pair(a, result); - - /* add syntax and value exports: */ - for (j = 0; j < 2; j++) { - int top, i; - - e = scheme_null; - - if (!j) { - i = exvcount; - top = excount; - } else { - i = 0; - top = exvcount; - } - - for (; i < top; i++) { - if (SCHEME_FALSEP(exss[i]) - && SAME_OBJ(exs[i], exsns[i])) - a = exs[i]; - else { - a = scheme_make_pair(exs[i], exsns[i]); - if (!SCHEME_FALSEP(exss[i])) { - a = scheme_make_pair(exss[i], a); - } - } - e = scheme_make_pair(a, e); - } - result = scheme_make_pair(e, result); - } - - env->genv->module->hints = result; - } - - if (rec[drec].comp) { - Scheme_Object *exp_body_r = scheme_null; - - /* Reverse exp_body */ - while (!SCHEME_NULLP(exp_body)) { - exp_body_r = scheme_make_pair(SCHEME_CAR(exp_body), - exp_body_r); - exp_body = SCHEME_CDR(exp_body); - } - - first = scheme_list_to_vector(first); - env->genv->module->body = first; - exp_body_r = scheme_list_to_vector(exp_body_r); - env->genv->module->et_body = exp_body_r; - - env->genv->module->provide_protects = exps; - env->genv->module->et_provide_protects = et_exps; - - env->genv->module->indirect_provides = exis; - env->genv->module->num_indirect_provides = exicount; - - if (*all_simple_renames) { - env->genv->module->indirect_syntax_provides = exsis; - env->genv->module->num_indirect_syntax_provides = exsicount; - } else { - env->genv->module->indirect_syntax_provides = NULL; - env->genv->module->num_indirect_syntax_provides = 0; - } - - env->genv->module->et_indirect_provides = et_exis; - env->genv->module->num_indirect_et_provides = et_exicount; - - env->genv->module->comp_prefix = cenv->prefix; - - if (*all_simple_renames) { - env->genv->module->rn_stx = scheme_true; - } - - return (Scheme_Object *)env->genv->module; + if (phase == 0) { + scheme_set_local_syntax(0, scheme_begin_stx, stop, xenv); + scheme_set_local_syntax(1, scheme_define_values_stx, stop, xenv); + scheme_set_local_syntax(2, scheme_define_syntaxes_stx, stop, xenv); + scheme_set_local_syntax(3, scheme_begin_for_syntax_stx, stop, xenv); + scheme_set_local_syntax(4, require_stx, stop, xenv); + scheme_set_local_syntax(5, provide_stx, stop, xenv); + scheme_set_local_syntax(6, set_stx, stop, xenv); + scheme_set_local_syntax(7, app_stx, stop, xenv); + scheme_set_local_syntax(8, scheme_top_stx, stop, xenv); + scheme_set_local_syntax(9, lambda_stx, stop, xenv); + scheme_set_local_syntax(10, case_lambda_stx, stop, xenv); + scheme_set_local_syntax(11, let_values_stx, stop, xenv); + scheme_set_local_syntax(12, letrec_values_stx, stop, xenv); + scheme_set_local_syntax(13, if_stx, stop, xenv); + scheme_set_local_syntax(14, begin0_stx, stop, xenv); + scheme_set_local_syntax(15, with_continuation_mark_stx, stop, xenv); + scheme_set_local_syntax(16, letrec_syntaxes_stx, stop, xenv); + scheme_set_local_syntax(17, var_ref_stx, stop, xenv); + scheme_set_local_syntax(18, expression_stx, stop, xenv); + sv[0] = scheme_define_values_stx; + sv[1] = scheme_begin_stx; + sv[2] = scheme_define_syntaxes_stx; + sv[3] = scheme_begin_for_syntax_stx; + sv[4] = require_stx; + sv[5] = provide_stx; } else { - if (rec[drec].depth == -2) { - /* This was a local expand. Flush definitions, because the body expand may start over. */ - flush_definitions(env->genv); - if (env->genv->exp_env) - flush_definitions(env->genv->exp_env); - } - - p = SCHEME_STX_CAR(form); - - /* Add lifted requires */ - if (!SCHEME_NULLP(lifted_reqs)) { - lifted_reqs = scheme_reverse(lifted_reqs); - first = scheme_append(lifted_reqs, first); - } - - return scheme_datum_to_syntax(cons(p, first), orig_form, orig_form, 0, 2); + w = scheme_sys_wraps_phase_worker(phase); + s = scheme_datum_to_syntax(scheme_intern_symbol("begin"), scheme_false, w, 0, 0); + sv[1] = s; + scheme_set_local_syntax(0, s, stop, xenv); + s = scheme_datum_to_syntax(scheme_intern_symbol("define-values"), scheme_false, w, 0, 0); + sv[0] = s; + scheme_set_local_syntax(1, s, stop, xenv); + s = scheme_datum_to_syntax(scheme_intern_symbol("define-syntaxes"), scheme_false, w, 0, 0); + sv[2] = s; + scheme_set_local_syntax(2, s, stop, xenv); + s = scheme_datum_to_syntax(scheme_intern_symbol("begin-for-syntax"), scheme_false, w, 0, 0); + sv[3] = s; + scheme_set_local_syntax(3, s, stop, xenv); + s = scheme_datum_to_syntax(scheme_intern_symbol("#%require"), scheme_false, w, 0, 0); + sv[4] = s; + scheme_set_local_syntax(4, s, stop, xenv); + s = scheme_datum_to_syntax(scheme_intern_symbol("#%provide"), scheme_false, w, 0, 0); + sv[5] = s; + scheme_set_local_syntax(5, s, stop, xenv); + scheme_set_local_syntax(6, scheme_datum_to_syntax(scheme_intern_symbol("set!"), scheme_false, w, 0, 0), stop, xenv); + scheme_set_local_syntax(7, scheme_datum_to_syntax(scheme_intern_symbol("#%app"), scheme_false, w, 0, 0), stop, xenv); + scheme_set_local_syntax(8, scheme_datum_to_syntax(scheme_intern_symbol("#%top"), scheme_false, w, 0, 0), stop, xenv); + scheme_set_local_syntax(9, scheme_datum_to_syntax(scheme_intern_symbol("lambda"), scheme_false, w, 0, 0), stop, xenv); + scheme_set_local_syntax(10, scheme_datum_to_syntax(scheme_intern_symbol("case-lambda"), scheme_false, w, 0, 0), stop, xenv); + scheme_set_local_syntax(11, scheme_datum_to_syntax(scheme_intern_symbol("let-values"), scheme_false, w, 0, 0), stop, xenv); + scheme_set_local_syntax(12, scheme_datum_to_syntax(scheme_intern_symbol("letrec-values"), scheme_false, w, 0, 0), stop, xenv); + scheme_set_local_syntax(13, scheme_datum_to_syntax(scheme_intern_symbol("if"), scheme_false, w, 0, 0), stop, xenv); + scheme_set_local_syntax(14, scheme_datum_to_syntax(scheme_intern_symbol("begin0"), scheme_false, w, 0, 0), stop, xenv); + scheme_set_local_syntax(15, scheme_datum_to_syntax(scheme_intern_symbol("with-continuation-mark"), scheme_false, w, 0, 0), stop, xenv); + scheme_set_local_syntax(16, scheme_datum_to_syntax(scheme_intern_symbol("letrec-syntaxes+values"), scheme_false, w, 0, 0), stop, xenv); + scheme_set_local_syntax(17, scheme_datum_to_syntax(scheme_intern_symbol("#%variable-reference"), scheme_false, w, 0, 0), stop, xenv); + scheme_set_local_syntax(18, scheme_datum_to_syntax(scheme_intern_symbol("#%expression"), scheme_false, w, 0, 0), stop, xenv); } } @@ -7033,8 +7493,8 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, Scheme_Module *mod_for_requires, Scheme_Hash_Table *tables, Scheme_Env *_genv, - Scheme_Object *all_rt_defs, Scheme_Object *all_rt_defs_out, - Scheme_Object *all_et_defs, Scheme_Object *all_et_defs_out, + int num_phases, + Scheme_Hash_Tree *all_defs, Scheme_Hash_Table *all_defs_out, const char *matching_form, Scheme_Object *all_mods, /* a phase list to use for all mods */ Scheme_Object *all_phases) /* a module-path list for all phases */ @@ -7043,7 +7503,7 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, Scheme_Object *reprovided, *tvec; int i, k, z; Scheme_Object *rx, *provided_list, *phase, *req_phase; - Scheme_Object *all_defs, *all_defs_out; + Scheme_Object *all_x_defs, *all_x_defs_out; Scheme_Env *genv; if (all_phases) { @@ -7289,27 +7749,20 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, } /* Do all-defined provides */ - for (z = 0; z < 2; z++) { - if (!z) { - all_defs = all_rt_defs; - all_defs_out = all_rt_defs_out; - provided = (Scheme_Hash_Table *)scheme_hash_get(all_provided, scheme_make_integer(0)); - phase = scheme_make_integer(0); - genv = _genv; - } else { - all_defs = all_et_defs; - all_defs_out = all_et_defs_out; - provided = (Scheme_Hash_Table *)scheme_hash_get(all_provided, scheme_make_integer(1)); - phase = scheme_make_integer(1); - genv = _genv->exp_env; - } - - if (all_defs_out) { - for (; !SCHEME_NULLP(all_defs_out); all_defs_out = SCHEME_CDR(all_defs_out)) { + genv = _genv; + for (z = 0; z < num_phases; z++) { + all_x_defs = scheme_hash_tree_get(all_defs, scheme_make_integer(z)); + if (!all_x_defs) all_x_defs = scheme_null; + all_x_defs_out = scheme_hash_get(all_defs_out, scheme_make_integer(z)); + provided = (Scheme_Hash_Table *)scheme_hash_get(all_provided, scheme_make_integer(z)); + phase = scheme_make_integer(z); + + if (all_x_defs_out) { + for (; !SCHEME_NULLP(all_x_defs_out); all_x_defs_out = SCHEME_CDR(all_x_defs_out)) { Scheme_Object *exns, *ree, *ree_kw, *exl, *name, *a, *adl, *exname, *pfx; int protected; - ree = SCHEME_CAR(all_defs_out); + ree = SCHEME_CAR(all_x_defs_out); protected = SCHEME_TRUEP(SCHEME_CDR(ree)); ree = SCHEME_CAR(ree); ree_kw = SCHEME_CAR(ree); @@ -7327,7 +7780,7 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, } } - for (adl = all_defs; SCHEME_PAIRP(adl); adl = SCHEME_CDR(adl)) { + for (adl = all_x_defs; SCHEME_PAIRP(adl); adl = SCHEME_CDR(adl)) { name = SCHEME_CAR(adl); exname = SCHEME_STX_SYM(name); name = scheme_tl_id_sym(genv, name, NULL, 0, NULL, NULL); @@ -7368,6 +7821,8 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, } } } + + genv = _genv->exp_env; } return 1; @@ -7489,7 +7944,8 @@ Scheme_Object *scheme_module_imported_list(Scheme_Env *genv, Scheme_Object *bind genv->module, tables, genv, - NULL, NULL, NULL, NULL, + 0, + NULL, NULL, NULL, all_mods, all_phases); @@ -7621,16 +8077,33 @@ static Scheme_Object *extract_free_id_name(Scheme_Object *name, return name; } -char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table *tables, - Scheme_Module_Exports *me, - Scheme_Env *genv, - Scheme_Object *form, - char **_phase1_protects) +static int lookup(Scheme_Env *genv, Scheme_Object *phase, int as_syntax, const char *name) +{ + int p; + + if (SCHEME_FALSEP(phase)) + return 0; + + p = SCHEME_INT_VAL(phase); + while (p--) { + genv = genv->exp_env; + if (!genv) return 0; + } + + return !!scheme_lookup_in_table((as_syntax ? genv->syntax : genv->toplevel), (const char *)name); +} + +void compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table *tables, + Scheme_Module_Exports *me, + Scheme_Env *genv, + Scheme_Object *form, + int num_phases, Scheme_Module_Export_Info **exp_infos) { int i, count, z, implicit; Scheme_Object **exs, **exsns, **exss, **exsnoms, *phase; Scheme_Hash_Table *provided, *required; - char *exps, *exets, *phase0_exps = NULL, *phase1_exps = NULL; + char *exps; + int *exets; int excount, exvcount; Scheme_Module_Phase_Exports *pt; Scheme_Object *implicit_src, *implicit_src_name, *implicit_mod_phase; @@ -7673,8 +8146,8 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table exss = MALLOC_N(Scheme_Object *, count); exsnoms = MALLOC_N(Scheme_Object *, count); exps = MALLOC_N_ATOMIC(char, count); - exets = MALLOC_N_ATOMIC(char, count); - memset(exets, 0, count); + exets = MALLOC_N_ATOMIC(int, count); + memset(exets, 0, count * sizeof(int)); /* Do non-syntax first. */ for (count = 0, i = provided->size; i--; ) { @@ -7693,25 +8166,18 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table if (!implicit && genv - && (SAME_OBJ(phase, scheme_make_integer(0)) - || SAME_OBJ(phase, scheme_make_integer(1))) - && scheme_lookup_in_table(SAME_OBJ(phase, scheme_make_integer(0)) - ? genv->toplevel - : genv->exp_env->toplevel, - (const char *)name)) { + && lookup(genv, phase, 0, (const char *)name)) { /* Defined locally */ exs[count] = provided->keys[i]; exsns[count] = name; exss[count] = scheme_false; /* means "self" */ exsnoms[count] = scheme_null; /* since "self" */ exps[count] = protected; - if (SAME_OBJ(phase, scheme_make_integer(1))) - exets[count] = 1; + exets[count] = SCHEME_INT_VAL(phase); count++; } else if (!implicit && genv - && SAME_OBJ(phase, scheme_make_integer(0)) - && scheme_lookup_in_table(genv->syntax, (const char *)name)) { + && lookup(genv, phase, 1, (const char *)name)) { /* Skip syntax for now. */ } else if (implicit) { /* Rename-transformer redirect; skip for now. */ @@ -7729,14 +8195,21 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table noms = adjust_for_rename(exs[count], SCHEME_VEC_ELS(v)[4], SCHEME_VEC_ELS(v)[0]); exsnoms[count] = noms; exps[count] = protected; - if (SAME_OBJ(SCHEME_VEC_ELS(v)[8], scheme_make_integer(1))) - exets[count] = 1; + exets[count] = SCHEME_INT_VAL(SCHEME_VEC_ELS(v)[8]); count++; } } else { /* Not defined! */ - scheme_wrong_syntax("module", prnt_name, form, "provided identifier not defined or imported"); + char buf[32], *phase_expl; + if (phase) { + sprintf(buf, " for phase %" PRIxPTR, SCHEME_INT_VAL(phase)); + phase_expl = scheme_strdup(buf); + } else + phase_expl = ""; + scheme_wrong_syntax("module", prnt_name, form, + "provided identifier not defined or imported%s", + phase_expl); } } } @@ -7759,14 +8232,14 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table if (!implicit && genv - && SAME_OBJ(phase, scheme_make_integer(0)) - && scheme_lookup_in_table(genv->syntax, (const char *)name)) { + && lookup(genv, phase, 1, (const char *)name)) { /* Defined locally */ exs[count] = provided->keys[i]; exsns[count] = name; exss[count] = scheme_false; /* means "self" */ exsnoms[count] = scheme_null; /* since "self" */ exps[count] = protected; + exets[count] = SCHEME_INT_VAL(phase); count++; } else if (implicit) { /* We record all free-id=?-based exports as syntax, even though they may be values. */ @@ -7828,27 +8301,38 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table pt->provide_nominal_srcs = exsnoms; pt->provide_src_phases = exets; - if (SAME_OBJ(phase, scheme_make_integer(0))) - phase0_exps = exps; - else if (SAME_OBJ(phase, scheme_make_integer(1))) - phase1_exps = exps; + /* Discard exps if all 0 */ + if (exps) { + for (i = 0; i < excount; i++) { + if (exps[i]) + break; + } + if (i >= excount) + exps = NULL; + } + + if (exps) { + if (SCHEME_TRUEP(phase)) { + if ((SCHEME_INT_VAL(phase) < 0) + || (SCHEME_INT_VAL(phase) >= num_phases)) + scheme_signal_error("internal error: bad phase for exports"); + exp_infos[SCHEME_INT_VAL(phase)]->provide_protects = exps; + } + } } } - - *_phase1_protects = phase1_exps; - - return phase0_exps; } /* Helper: */ static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Object **exss, - char *exps, char *exets, + char *exps, int *exets, Scheme_Object **exsnoms, int start, int count, int do_uninterned) { int i, j; Scheme_Object *tmp_ex, *tmp_exsn, *tmp_exs, *tmp_exsnom, *pivot; - char tmp_exp, tmp_exet; + char tmp_exp; + int tmp_exet; if (do_uninterned) { /* Look for uninterned and move to end: */ @@ -7961,9 +8445,9 @@ static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Ob } } -static Scheme_Object *expand_provide(Scheme_Object *e, +static Scheme_Object *expand_provide(Scheme_Object *e, int at_phase, Scheme_Hash_Table *tables, - Scheme_Object *all_defs, Scheme_Object *all_et_defs, + Scheme_Hash_Tree *all_defs, Scheme_Comp_Env *cenv, Scheme_Compile_Info *rec, int drec) { Scheme_Expand_Info erec1; @@ -7975,10 +8459,16 @@ static Scheme_Object *expand_provide(Scheme_Object *e, cenv); stop = scheme_get_stop_expander(); scheme_add_local_syntax(1, xenv); - scheme_set_local_syntax(0, scheme_begin_stx, stop, xenv); + if (!at_phase) + scheme_set_local_syntax(0, scheme_begin_stx, stop, xenv); + else + scheme_set_local_syntax(0, scheme_datum_to_syntax(scheme_intern_symbol("begin"), + scheme_false, + scheme_sys_wraps_phase_worker(at_phase), + 0, 0), + stop, xenv); - b = scheme_make_pair((Scheme_Object *)tables, - scheme_make_pair(all_defs, all_et_defs)); + b = scheme_make_pair((Scheme_Object *)tables, (Scheme_Object *)all_defs); scheme_current_thread->current_local_bindings = b; scheme_init_expand_recs(rec, drec, &erec1, 1); @@ -7993,20 +8483,21 @@ static Scheme_Object *expand_provide(Scheme_Object *e, } void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e, + int at_phase, Scheme_Hash_Table *all_provided, Scheme_Hash_Table *all_reprovided, Scheme_Object *self_modidx, - Scheme_Object **_all_defs_out, - Scheme_Object **_et_all_defs_out, + Scheme_Hash_Table *all_defs_out, Scheme_Hash_Table *tables, - Scheme_Object *all_defs, Scheme_Object *all_et_defs, + Scheme_Hash_Tree *all_defs, Scheme_Comp_Env *cenv, Scheme_Compile_Info *rec, int drec, - Scheme_Object **_expanded) + Scheme_Object **_expanded, + Scheme_Object *begin_stx) { Scheme_Object *l, *rebuilt = scheme_null, *protect_stx = NULL; int protect_cnt = 0, mode_cnt = 0, expanded = 0; Scheme_Object *mode = scheme_make_integer(0), *mode_stx = NULL; - Scheme_Object *all_defs_out; + Scheme_Object *all_x_defs_out, *all_x_defs; Scheme_Hash_Table *provided; Scheme_Object *phase; @@ -8085,19 +8576,19 @@ void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e, break; } - if (SAME_OBJ(mode, scheme_make_integer(0))) - all_defs_out = *_all_defs_out; - else if (SAME_OBJ(mode, scheme_make_integer(1))) - all_defs_out = *_et_all_defs_out; + if (SCHEME_FALSEP(mode)) + phase = mode; else - all_defs_out = NULL; + phase = scheme_bin_plus(mode, scheme_make_integer(at_phase)); - provided = (Scheme_Hash_Table *)scheme_hash_get(all_provided, mode); + all_x_defs_out = scheme_hash_get(all_defs_out, phase); + if (!all_x_defs_out) all_x_defs_out = scheme_null; + + provided = (Scheme_Hash_Table *)scheme_hash_get(all_provided, phase); if (!provided) { provided = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(all_provided, mode, (Scheme_Object *)provided); + scheme_hash_set(all_provided, phase, (Scheme_Object *)provided); } - phase = mode; if (SCHEME_STX_SYMBOLP(a)) { /* <id> */ @@ -8125,7 +8616,9 @@ void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e, return; } - p = expand_provide(p, tables, all_defs, all_et_defs, cenv, rec, drec); + all_x_defs = scheme_hash_tree_get(all_defs, mode); + if (!all_x_defs) all_x_defs = scheme_null; + p = expand_provide(p, at_phase, tables, all_defs, cenv, rec, drec); /* Check for '(begin datum ...) result: */ p = scheme_flatten_syntax_list(p, &islist); @@ -8136,7 +8629,7 @@ void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e, else { rest = SCHEME_CAR(p); if (!SCHEME_STX_SYMBOLP(rest) - || !scheme_stx_module_eq(scheme_begin_stx, rest, 0)) { + || !scheme_stx_module_eq(begin_stx, rest, at_phase)) { p = NULL; } } @@ -8298,16 +8791,16 @@ void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e, if (!SCHEME_STX_NULLP(rest)) scheme_wrong_syntax(NULL, a, e, "bad syntax"); - if (!all_defs_out) { + if (!all_x_defs_out) { scheme_wrong_syntax(NULL, a, e, "no definitions at phase level %V", mode); } - all_defs_out = scheme_make_pair(scheme_make_pair(scheme_make_pair(e, - scheme_make_pair(scheme_null, - scheme_false)), - protect_cnt ? scheme_true : scheme_false), - all_defs_out); + all_x_defs_out = scheme_make_pair(scheme_make_pair(scheme_make_pair(e, + scheme_make_pair(scheme_null, + scheme_false)), + protect_cnt ? scheme_true : scheme_false), + all_x_defs_out); } else if (SAME_OBJ(prefix_all_defined_symbol, SCHEME_STX_VAL(fst))) { /* (prefix-all-defined <prefix>) */ Scheme_Object *prefix; @@ -8325,16 +8818,16 @@ void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e, } prefix = SCHEME_STX_VAL(prefix); - if (!all_defs_out) { + if (!all_x_defs_out) { scheme_wrong_syntax(NULL, a, e, "no definitions at phase level %V", mode); } - all_defs_out = scheme_make_pair(scheme_make_pair(scheme_make_pair(e, - scheme_make_pair(scheme_null, - prefix)), - protect_cnt ? scheme_true : scheme_false), - all_defs_out); + all_x_defs_out = scheme_make_pair(scheme_make_pair(scheme_make_pair(e, + scheme_make_pair(scheme_null, + prefix)), + protect_cnt ? scheme_true : scheme_false), + all_x_defs_out); } else if (SAME_OBJ(all_defined_except_symbol, SCHEME_STX_VAL(fst)) || SAME_OBJ(prefix_all_defined_except_symbol, SCHEME_STX_VAL(fst))) { /* ([prefix-]all-defined-except <id> ...) */ @@ -8370,16 +8863,16 @@ void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e, } } - if (!all_defs_out) { + if (!all_x_defs_out) { scheme_wrong_syntax(NULL, a, e, "no definitions at phase level %V", mode); } - all_defs_out = scheme_make_pair(scheme_make_pair(scheme_make_pair(e, - scheme_make_pair(exns, - prefix)), - protect_cnt ? scheme_true : scheme_false), - all_defs_out); + all_x_defs_out = scheme_make_pair(scheme_make_pair(scheme_make_pair(e, + scheme_make_pair(exns, + prefix)), + protect_cnt ? scheme_true : scheme_false), + all_x_defs_out); } else { scheme_wrong_syntax(NULL, a, e, NULL); } @@ -8409,10 +8902,8 @@ void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e, if (protect_cnt) --protect_cnt; - if (SAME_OBJ(mode, scheme_make_integer(0))) - *_all_defs_out = all_defs_out; - else if (SAME_OBJ(mode, scheme_make_integer(1))) - *_et_all_defs_out = all_defs_out; + if (all_x_defs_out) + scheme_hash_set(all_defs_out, mode, all_x_defs_out); if (mode_cnt) { --mode_cnt; @@ -8501,7 +8992,7 @@ Scheme_Object *scheme_module_exported_list(Scheme_Object *modpath, Scheme_Env *g void add_single_require(Scheme_Module_Exports *me, /* from module */ Scheme_Object *only_phase, - Scheme_Object *src_phase_index, + Scheme_Object *src_phase_index, /* import from pahse 0 to src_phase_index */ Scheme_Object *idx, /* from module's idx; may be saved for unmarshalling */ Scheme_Env *orig_env, /* env for mark_src or copy_vars */ Scheme_Object *rn_set, /* add requires to renames in this set when no mark_src */ @@ -8524,12 +9015,12 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ int j, var_count; Scheme_Object *orig_idx = idx, *to_phase; Scheme_Object **exs, **exsns, **exss, *context_marks = scheme_null; - char *exets; + int *exets; int has_context, save_marshal_info = 0; Scheme_Object *nominal_modidx, *one_exn, *prnt_iname, *name, *rn, *ename = orig_ename; Scheme_Hash_Table *orig_onlys; int k, skip_rename, do_copy_vars; - + if (mark_src) { /* Check whether there's context for this import (which leads to generated local names). */ @@ -8886,7 +9377,7 @@ Scheme_Object *scheme_get_kernel_modidx(void) return kernel_modidx; } -void parse_requires(Scheme_Object *form, +void parse_requires(Scheme_Object *form, int at_phase, Scheme_Object *base_modidx, Scheme_Env *main_env, Scheme_Module *for_m, @@ -8961,9 +9452,12 @@ void parse_requires(Scheme_Object *form, && !SCHEME_BIGNUMP(a_mode)) scheme_wrong_syntax(NULL, i, form, "bad `%s-meta' level specification", (SAME_OBJ(for_meta_symbol, aav) ? "for" : "just")); - if (SAME_OBJ(for_meta_symbol, aav)) - mode = a_mode; - else + if (SAME_OBJ(for_meta_symbol, aav)) { + if (SCHEME_FALSEP(a_mode)) + mode = a_mode; + else + mode = scheme_bin_plus(a_mode, scheme_make_integer(0)); + } else just_mode = a_mode; } else { if (SAME_OBJ(for_syntax_symbol, aav)) @@ -9202,7 +9696,7 @@ void parse_requires(Scheme_Object *form, start_module(m, env, 0, idx, start ? eval_exp : 0, start ? eval_run : 0, - main_env->phase, scheme_null); + main_env->phase, scheme_null, 0); /* Add name to require list, if it's not there: */ if (main_env->module) { @@ -9236,16 +9730,14 @@ void parse_requires(Scheme_Object *form, x_just_mode = just_mode; x_mode = mode; - if (main_env->phase) { - /* We get here only via `eval' or `namespace-require'. */ - if (x_just_mode && SCHEME_TRUEP(x_just_mode)) { - x_just_mode = scheme_bin_plus(x_just_mode, scheme_make_integer(main_env->phase)); - } + if (at_phase) { if (x_mode && SCHEME_TRUEP(x_mode)) { - x_mode = scheme_bin_plus(x_mode, scheme_make_integer(main_env->phase)); + x_mode = scheme_bin_plus(x_mode, scheme_make_integer(at_phase)); } + /* x_just_mode refers to the mode at export, which doesn't shift + by phase context at import */ } - + add_single_require(m->me, x_just_mode, x_mode, idx, rename_env, rn_set, post_ex_rn_set, NULL, exns, onlys, prefix, iname, ename, @@ -9344,7 +9836,7 @@ do_require_execute(Scheme_Env *env, Scheme_Object *form) ht = NULL; } - parse_requires(form, modidx, env, NULL, + parse_requires(form, env->phase, modidx, env, NULL, rn_set, rn_set, check_dup_require, ht, NULL, @@ -9399,7 +9891,7 @@ static Scheme_Object *do_require(Scheme_Object *form, Scheme_Comp_Env *env, else modidx = scheme_false; - parse_requires(form, modidx, genv, NULL, + parse_requires(form, genv->phase, modidx, genv, NULL, rn_set, rn_set, check_dup_require, ht, NULL, diff --git a/src/racket/src/mzmark_type.inc b/src/racket/src/mzmark_type.inc index 3ab370bf96..94d5c422c6 100644 --- a/src/racket/src/mzmark_type.inc +++ b/src/racket/src/mzmark_type.inc @@ -2167,6 +2167,7 @@ static int namespace_val_MARK(void *p, struct NewGC *gc) { gcMARK2(e->exp_env, gc); gcMARK2(e->template_env, gc); gcMARK2(e->label_env, gc); + gcMARK2(e->instance_env, gc); gcMARK2(e->shadowed_syntax, gc); @@ -2176,6 +2177,7 @@ static int namespace_val_MARK(void *p, struct NewGC *gc) { gcMARK2(e->tt_require_names, gc); gcMARK2(e->dt_require_names, gc); gcMARK2(e->other_require_names, gc); + gcMARK2(e->running, gc); gcMARK2(e->did_starts, gc); gcMARK2(e->available_next[0], gc); gcMARK2(e->available_next[1], gc); @@ -2206,6 +2208,7 @@ static int namespace_val_FIXUP(void *p, struct NewGC *gc) { gcFIXUP2(e->exp_env, gc); gcFIXUP2(e->template_env, gc); gcFIXUP2(e->label_env, gc); + gcFIXUP2(e->instance_env, gc); gcFIXUP2(e->shadowed_syntax, gc); @@ -2215,6 +2218,7 @@ static int namespace_val_FIXUP(void *p, struct NewGC *gc) { gcFIXUP2(e->tt_require_names, gc); gcFIXUP2(e->dt_require_names, gc); gcFIXUP2(e->other_require_names, gc); + gcFIXUP2(e->running, gc); gcFIXUP2(e->did_starts, gc); gcFIXUP2(e->available_next[0], gc); gcFIXUP2(e->available_next[1], gc); @@ -2508,24 +2512,14 @@ static int module_val_MARK(void *p, struct NewGC *gc) { gcMARK2(m->dt_requires, gc); gcMARK2(m->other_requires, gc); - gcMARK2(m->body, gc); - gcMARK2(m->et_body, gc); + gcMARK2(m->bodies, gc); gcMARK2(m->me, gc); - gcMARK2(m->provide_protects, gc); - gcMARK2(m->indirect_provides, gc); - - gcMARK2(m->indirect_syntax_provides, gc); - - gcMARK2(m->et_provide_protects, gc); - gcMARK2(m->et_indirect_provides, gc); + gcMARK2(m->exp_infos, gc); gcMARK2(m->self_modidx, gc); - gcMARK2(m->accessible, gc); - gcMARK2(m->et_accessible, gc); - gcMARK2(m->insp, gc); gcMARK2(m->lang_info, gc); @@ -2558,24 +2552,14 @@ static int module_val_FIXUP(void *p, struct NewGC *gc) { gcFIXUP2(m->dt_requires, gc); gcFIXUP2(m->other_requires, gc); - gcFIXUP2(m->body, gc); - gcFIXUP2(m->et_body, gc); + gcFIXUP2(m->bodies, gc); gcFIXUP2(m->me, gc); - gcFIXUP2(m->provide_protects, gc); - gcFIXUP2(m->indirect_provides, gc); - - gcFIXUP2(m->indirect_syntax_provides, gc); - - gcFIXUP2(m->et_provide_protects, gc); - gcFIXUP2(m->et_indirect_provides, gc); + gcFIXUP2(m->exp_infos, gc); gcFIXUP2(m->self_modidx, gc); - gcFIXUP2(m->accessible, gc); - gcFIXUP2(m->et_accessible, gc); - gcFIXUP2(m->insp, gc); gcFIXUP2(m->lang_info, gc); @@ -2598,6 +2582,41 @@ static int module_val_FIXUP(void *p, struct NewGC *gc) { #define module_val_IS_CONST_SIZE 1 +static int exp_info_val_SIZE(void *p, struct NewGC *gc) { + return + gcBYTES_TO_WORDS(sizeof(Scheme_Module_Export_Info)); +} + +static int exp_info_val_MARK(void *p, struct NewGC *gc) { + Scheme_Module_Export_Info *m = (Scheme_Module_Export_Info *)p; + + gcMARK2(m->provide_protects, gc); + gcMARK2(m->indirect_provides, gc); + + gcMARK2(m->indirect_syntax_provides, gc); + + gcMARK2(m->accessible, gc); + return + gcBYTES_TO_WORDS(sizeof(Scheme_Module_Export_Info)); +} + +static int exp_info_val_FIXUP(void *p, struct NewGC *gc) { + Scheme_Module_Export_Info *m = (Scheme_Module_Export_Info *)p; + + gcFIXUP2(m->provide_protects, gc); + gcFIXUP2(m->indirect_provides, gc); + + gcFIXUP2(m->indirect_syntax_provides, gc); + + gcFIXUP2(m->accessible, gc); + return + gcBYTES_TO_WORDS(sizeof(Scheme_Module_Export_Info)); +} + +#define exp_info_val_IS_ATOMIC 0 +#define exp_info_val_IS_CONST_SIZE 1 + + static int module_phase_exports_val_SIZE(void *p, struct NewGC *gc) { return gcBYTES_TO_WORDS(sizeof(Scheme_Module_Phase_Exports)); diff --git a/src/racket/src/mzmarksrc.c b/src/racket/src/mzmarksrc.c index 250c6818ed..cb7fa8e498 100644 --- a/src/racket/src/mzmarksrc.c +++ b/src/racket/src/mzmarksrc.c @@ -876,6 +876,7 @@ namespace_val { gcMARK2(e->exp_env, gc); gcMARK2(e->template_env, gc); gcMARK2(e->label_env, gc); + gcMARK2(e->instance_env, gc); gcMARK2(e->shadowed_syntax, gc); @@ -885,6 +886,7 @@ namespace_val { gcMARK2(e->tt_require_names, gc); gcMARK2(e->dt_require_names, gc); gcMARK2(e->other_require_names, gc); + gcMARK2(e->running, gc); gcMARK2(e->did_starts, gc); gcMARK2(e->available_next[0], gc); gcMARK2(e->available_next[1], gc); @@ -1009,24 +1011,14 @@ module_val { gcMARK2(m->dt_requires, gc); gcMARK2(m->other_requires, gc); - gcMARK2(m->body, gc); - gcMARK2(m->et_body, gc); + gcMARK2(m->bodies, gc); gcMARK2(m->me, gc); - gcMARK2(m->provide_protects, gc); - gcMARK2(m->indirect_provides, gc); - - gcMARK2(m->indirect_syntax_provides, gc); - - gcMARK2(m->et_provide_protects, gc); - gcMARK2(m->et_indirect_provides, gc); + gcMARK2(m->exp_infos, gc); gcMARK2(m->self_modidx, gc); - gcMARK2(m->accessible, gc); - gcMARK2(m->et_accessible, gc); - gcMARK2(m->insp, gc); gcMARK2(m->lang_info, gc); @@ -1045,6 +1037,20 @@ module_val { gcBYTES_TO_WORDS(sizeof(Scheme_Module)); } +exp_info_val { + mark: + Scheme_Module_Export_Info *m = (Scheme_Module_Export_Info *)p; + + gcMARK2(m->provide_protects, gc); + gcMARK2(m->indirect_provides, gc); + + gcMARK2(m->indirect_syntax_provides, gc); + + gcMARK2(m->accessible, gc); + size: + gcBYTES_TO_WORDS(sizeof(Scheme_Module_Export_Info)); +} + module_phase_exports_val { mark: Scheme_Module_Phase_Exports *m = (Scheme_Module_Phase_Exports *)p; diff --git a/src/racket/src/optimize.c b/src/racket/src/optimize.c index 28094ffb70..b15d5a49de 100644 --- a/src/racket/src/optimize.c +++ b/src/racket/src/optimize.c @@ -2996,7 +2996,7 @@ begin0_optimize(Scheme_Object *obj, Optimize_Info *info, int context) return obj; } -static Scheme_Object *do_define_syntaxes_optimize(Scheme_Object *data, Optimize_Info *info, int for_stx) +static Scheme_Object *do_define_syntaxes_optimize(Scheme_Object *data, Optimize_Info *info) { Scheme_Object *val; Optimize_Info *einfo; @@ -3016,12 +3016,29 @@ static Scheme_Object *do_define_syntaxes_optimize(Scheme_Object *data, Optimize_ static Scheme_Object *define_syntaxes_optimize(Scheme_Object *data, Optimize_Info *info, int context) { - return do_define_syntaxes_optimize(data, info, 0); + return do_define_syntaxes_optimize(data, info); } -static Scheme_Object *define_for_syntaxes_optimize(Scheme_Object *data, Optimize_Info *info, int context) +static Scheme_Object *begin_for_syntax_optimize(Scheme_Object *data, Optimize_Info *info, int context) { - return do_define_syntaxes_optimize(data, info, 1); + Scheme_Object *l, *a; + Optimize_Info *einfo; + + l = SCHEME_VEC_ELS(data)[2]; + + while (!SCHEME_NULLP(l)) { + einfo = scheme_optimize_info_create(); + if (info->inline_fuel < 0) + einfo->inline_fuel = -1; + + a = SCHEME_CAR(l); + a = scheme_optimize_expr(a, einfo, 0); + SCHEME_CAR(l) = a; + + l = SCHEME_CDR(l); + } + + return data; } /*========================================================================*/ @@ -4517,7 +4534,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) old_context = info->context; info->context = (Scheme_Object *)m; - cnt = SCHEME_VEC_SIZE(m->body); + cnt = SCHEME_VEC_SIZE(m->bodies[0]); if (OPT_ESTIMATE_FUTURE_SIZES) { if (info->enforce_const) { @@ -4525,7 +4542,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) size estimate, which is used to discourage early loop unrolling at the expense of later inlining. */ for (i_m = 0; i_m < cnt; i_m++) { - e = SCHEME_VEC_ELS(m->body)[i_m]; + e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { int n; @@ -4562,7 +4579,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->body)[i_m]; + e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; is_proc_def = 0; if (OPT_DISCOURAGE_EARLY_INLINE && info->enforce_const) { @@ -4587,7 +4604,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) info->use_psize = 0; info->inline_fuel = inline_fuel; } - SCHEME_VEC_ELS(m->body)[i_m] = e; + SCHEME_VEC_ELS(m->bodies[0])[i_m] = e; if (info->enforce_const) { /* If this expression/definition can't have any side effect @@ -4717,7 +4734,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) shift-cloning, since there are no local variables in scope. */ int old_sz, new_sz; - e = SCHEME_VEC_ELS(m->body)[start_simltaneous]; + e = SCHEME_VEC_ELS(m->bodies[0])[start_simltaneous]; if (OPT_DELAY_GROUP_PROPAGATE || OPT_LIMIT_FUNCTION_RESIZE) { if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { @@ -4730,7 +4747,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) old_sz = 0; e = scheme_optimize_expr(e, info, 0); - SCHEME_VEC_ELS(m->body)[start_simltaneous] = e; + SCHEME_VEC_ELS(m->bodies[0])[start_simltaneous] = e; if (re_consts) { /* Install optimized closures into constant table --- @@ -4809,7 +4826,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) int can_omit = 0; for (i_m = 0; i_m < cnt; i_m++) { /* Optimize this expression: */ - e = SCHEME_VEC_ELS(m->body)[i_m]; + e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; if (scheme_omittable_expr(e, -1, -1, 0, NULL, -1)) { can_omit++; } @@ -4820,12 +4837,12 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) vec = scheme_make_vector(cnt - can_omit, NULL); for (i_m = 0; i_m < cnt; i_m++) { /* Optimize this expression: */ - e = SCHEME_VEC_ELS(m->body)[i_m]; + e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; if (!scheme_omittable_expr(e, -1, -1, 0, NULL, -1)) { SCHEME_VEC_ELS(vec)[j++] = e; } } - m->body = vec; + m->bodies[0] = vec; } } @@ -5007,8 +5024,8 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info, in return set_optimize(expr, info, context); case scheme_define_syntaxes_type: return define_syntaxes_optimize(expr, info, context); - case scheme_define_for_syntax_type: - return define_for_syntaxes_optimize(expr, info, context); + case scheme_begin_for_syntax_type: + return begin_for_syntax_optimize(expr, info, context); case scheme_case_lambda_sequence_type: return case_lambda_optimize(expr, info, context); case scheme_begin0_sequence_type: @@ -5225,7 +5242,7 @@ Scheme_Object *scheme_optimize_clone(int dup_ok, Scheme_Object *expr, Optimize_I return expr; case scheme_define_values_type: case scheme_define_syntaxes_type: - case scheme_define_for_syntax_type: + case scheme_begin_for_syntax_type: case scheme_boxenv_type: return NULL; case scheme_require_form_type: @@ -5396,7 +5413,7 @@ Scheme_Object *scheme_optimize_shift(Scheme_Object *expr, int delta, int after_d case scheme_boxenv_type: case scheme_define_values_type: case scheme_define_syntaxes_type: - case scheme_define_for_syntax_type: + case scheme_begin_for_syntax_type: case scheme_require_form_type: case scheme_module_type: scheme_signal_error("scheme_optimize_shift: no shift available for %d", SCHEME_TYPE(expr)); diff --git a/src/racket/src/resolve.c b/src/racket/src/resolve.c index 644912cc5d..6f2571fcc5 100644 --- a/src/racket/src/resolve.c +++ b/src/racket/src/resolve.c @@ -729,7 +729,7 @@ case_lambda_resolve(Scheme_Object *expr, Resolve_Info *rslv) return expr; } -static Scheme_Object *do_define_syntaxes_resolve(Scheme_Object *data, Resolve_Info *info, int for_stx) +static Scheme_Object *do_define_syntaxes_resolve(Scheme_Object *data, Resolve_Info *info) { Comp_Prefix *cp; Resolve_Prefix *rp; @@ -748,8 +748,6 @@ static Scheme_Object *do_define_syntaxes_resolve(Scheme_Object *data, Resolve_In einfo = scheme_resolve_info_create(rp); - if (for_stx) - names = scheme_resolve_list(names, einfo); val = scheme_resolve_expr(val, einfo); rp = scheme_remap_prefix(rp, einfo); @@ -770,19 +768,54 @@ static Scheme_Object *do_define_syntaxes_resolve(Scheme_Object *data, Resolve_In names = SCHEME_CDR(names); } - vec->type = (for_stx ? scheme_define_for_syntax_type : scheme_define_syntaxes_type); + vec->type = scheme_define_syntaxes_type; return vec; } static Scheme_Object *define_syntaxes_resolve(Scheme_Object *data, Resolve_Info *info) { - return do_define_syntaxes_resolve(data, info, 0); + return do_define_syntaxes_resolve(data, info); } -static Scheme_Object *define_for_syntaxes_resolve(Scheme_Object *data, Resolve_Info *info) +static Scheme_Object *begin_for_syntax_resolve(Scheme_Object *data, Resolve_Info *info) { - return do_define_syntaxes_resolve(data, info, 1); + Comp_Prefix *cp; + Resolve_Prefix *rp; + Scheme_Object *l, *p, *a, *base_stack_depth, *dummy, *vec; + Resolve_Info *einfo; + + cp = (Comp_Prefix *)SCHEME_VEC_ELS(data)[0]; + dummy = SCHEME_VEC_ELS(data)[1]; + l = SCHEME_VEC_ELS(data)[2]; + + rp = scheme_resolve_prefix(1, cp, 1); + + dummy = scheme_resolve_expr(dummy, info); + + einfo = scheme_resolve_info_create(rp); + + p = scheme_null; + while (!SCHEME_NULLP(l)) { + a = SCHEME_CAR(l); + a = scheme_resolve_expr(a, einfo); + p = scheme_make_pair(a, p); + l = SCHEME_CDR(l); + } + l = scheme_reverse(p); + + rp = scheme_remap_prefix(rp, einfo); + + base_stack_depth = scheme_make_integer(einfo->max_let_depth); + + vec = scheme_make_vector(4, NULL); + SCHEME_VEC_ELS(vec)[0] = l; + SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)rp; + SCHEME_VEC_ELS(vec)[2] = base_stack_depth; + SCHEME_VEC_ELS(vec)[3] = dummy; + vec->type = scheme_begin_for_syntax_type; + + return vec; } /*========================================================================*/ @@ -2152,20 +2185,20 @@ module_expr_resolve(Scheme_Object *data, Resolve_Info *old_rslv) rslv->in_module = 1; scheme_enable_expression_resolve_lifts(rslv); - cnt = SCHEME_VEC_SIZE(m->body); + cnt = SCHEME_VEC_SIZE(m->bodies[0]); for (i = 0; i < cnt; i++) { Scheme_Object *e; - e = scheme_resolve_expr(SCHEME_VEC_ELS(m->body)[i], rslv); - SCHEME_VEC_ELS(m->body)[i] = e; + e = scheme_resolve_expr(SCHEME_VEC_ELS(m->bodies[0])[i], rslv); + SCHEME_VEC_ELS(m->bodies[0])[i] = e; } m->max_let_depth = rslv->max_let_depth; lift_vec = rslv->lifts; if (!SCHEME_NULLP(SCHEME_VEC_ELS(lift_vec)[0])) { - b = scheme_append(SCHEME_VEC_ELS(lift_vec)[0], scheme_vector_to_list(m->body)); + b = scheme_append(SCHEME_VEC_ELS(lift_vec)[0], scheme_vector_to_list(m->bodies[0])); b = scheme_list_to_vector(b); - m->body = b; + m->bodies[0] = b; } rp->num_lifts = SCHEME_INT_VAL(SCHEME_VEC_ELS(lift_vec)[1]); @@ -2288,8 +2321,8 @@ Scheme_Object *scheme_resolve_expr(Scheme_Object *expr, Resolve_Info *info) return define_values_resolve(expr, info); case scheme_define_syntaxes_type: return define_syntaxes_resolve(expr, info); - case scheme_define_for_syntax_type: - return define_for_syntaxes_resolve(expr, info); + case scheme_begin_for_syntax_type: + return begin_for_syntax_resolve(expr, info); case scheme_set_bang_type: return set_resolve(expr, info); case scheme_require_form_type: diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index 97c9382887..48ca03b7f1 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -398,7 +398,7 @@ extern Scheme_Object *scheme_begin_stx; extern Scheme_Object *scheme_module_begin_stx; extern Scheme_Object *scheme_define_values_stx; extern Scheme_Object *scheme_define_syntaxes_stx; -extern Scheme_Object *scheme_define_for_syntaxes_stx; +extern Scheme_Object *scheme_begin_for_syntax_stx; extern Scheme_Object *scheme_top_stx; extern Scheme_Object *scheme_recur_symbol, *scheme_display_symbol, *scheme_write_special_symbol; @@ -2672,7 +2672,7 @@ struct Start_Module_Args; #ifdef MZ_USE_JIT void *scheme_module_run_start(Scheme_Env *menv, Scheme_Env *env, Scheme_Object *name); -void *scheme_module_exprun_start(Scheme_Env *menv, int set_ns, Scheme_Object *name); +void *scheme_module_exprun_start(Scheme_Env *menv, int phase_plus_set_ns, Scheme_Object *name); void *scheme_module_start_start(struct Start_Module_Args *a, Scheme_Object *name); #endif void *scheme_module_run_finish(Scheme_Env *menv, Scheme_Env *env); @@ -2931,6 +2931,7 @@ struct Scheme_Env { struct Scheme_Env *exp_env; struct Scheme_Env *template_env; struct Scheme_Env *label_env; + struct Scheme_Env *instance_env; /* shortcut to env where module is instantiated */ Scheme_Hash_Table *shadowed_syntax; /* top level only */ @@ -2939,7 +2940,8 @@ struct Scheme_Env { Scheme_Object *link_midx; Scheme_Object *require_names, *et_require_names, *tt_require_names, *dt_require_names; /* resolved */ Scheme_Hash_Table *other_require_names; - char running, et_running, attached, ran; + char *running; /* array of size `num_phases' if `module' and `mod_phase==0' */ + char attached, ran; Scheme_Object *did_starts; Scheme_Object *available_next[2]; @@ -2964,6 +2966,19 @@ struct Scheme_Env { /* A Scheme_Module corresponds to a module declaration. A module instantiation is reprsented by a Scheme_Env */ +typedef struct Scheme_Module_Export_Info { + MZTAG_IF_REQUIRED + char *provide_protects; /* 1 => protected, 0 => not */ + Scheme_Object **indirect_provides; /* symbols (internal names) */ + int num_indirect_provides; + + /* Only if needed to reconstruct the renaming: */ + Scheme_Object **indirect_syntax_provides; /* symbols (internal names) */ + int num_indirect_syntax_provides; + + Scheme_Hash_Table *accessible; /* (symbol -> ...) */ +} Scheme_Module_Export_Info; + typedef struct Scheme_Module { Scheme_Object so; /* scheme_module_type */ @@ -2982,29 +2997,17 @@ typedef struct Scheme_Module Scheme_Invoke_Proc prim_body; Scheme_Invoke_Proc prim_et_body; - Scheme_Object *body; /* or data, if prim_body */ - Scheme_Object *et_body; /* list of (vector list-of-names expr depth-int resolve-prefix) */ + Scheme_Object **bodies; /* array `num_phases' long */ char no_cert; struct Scheme_Module_Exports *me; - char *provide_protects; /* 1 => protected, 0 => not */ - Scheme_Object **indirect_provides; /* symbols (internal names) */ - int num_indirect_provides; - - /* Only if needed to reconstruct the renaming: */ - Scheme_Object **indirect_syntax_provides; /* symbols (internal names) */ - int num_indirect_syntax_provides; - - char *et_provide_protects; /* 1 => protected, 0 => not */ - Scheme_Object **et_indirect_provides; /* symbols (internal names) */ - int num_indirect_et_provides; + int num_phases; + Scheme_Module_Export_Info **exp_infos; /* array `num_phases' long */ Scheme_Object *self_modidx; - Scheme_Hash_Table *accessible; /* (symbol -> ...) */ - Scheme_Hash_Table *et_accessible; /* phase -> (symbol -> ...) */ Scheme_Object *insp; /* declaration-time inspector, for module instantiation and enabling access to protected imports */ @@ -3036,7 +3039,7 @@ typedef struct Scheme_Module_Phase_Exports Scheme_Object **provide_srcs; /* module access paths, #f for self */ Scheme_Object **provide_src_names; /* symbols (original internal names) */ Scheme_Object **provide_nominal_srcs; /* import source if re-exported; NULL or array of lists */ - char *provide_src_phases; /* NULL, or src phase for for-syntax import */ + int *provide_src_phases; /* NULL, or src phase for for-syntax import */ int num_provides; int num_var_provides; /* non-syntax listed first in provides */ @@ -3142,7 +3145,7 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object Scheme_Env *from_env, int *_would_complain, Scheme_Object **_is_constant); void scheme_check_unsafe_accessible(Scheme_Object *insp, Scheme_Env *from_env); -Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env, Scheme_Object *name); +Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env, Scheme_Object *name, int mod_phase); Scheme_Object *scheme_modidx_shift(Scheme_Object *modidx, Scheme_Object *shift_from_modidx, diff --git a/src/racket/src/schvers.h b/src/racket/src/schvers.h index cf41c1d243..9a4c0809ba 100644 --- a/src/racket/src/schvers.h +++ b/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "5.1.3.6" +#define MZSCHEME_VERSION "5.1.3.7" #define MZSCHEME_VERSION_X 5 #define MZSCHEME_VERSION_Y 1 #define MZSCHEME_VERSION_Z 3 -#define MZSCHEME_VERSION_W 6 +#define MZSCHEME_VERSION_W 7 #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/sfs.c b/src/racket/src/sfs.c index 494c65a29a..cc62b7c9d4 100644 --- a/src/racket/src/sfs.c +++ b/src/racket/src/sfs.c @@ -937,9 +937,23 @@ static Scheme_Object *define_syntaxes_sfs(Scheme_Object *data, SFS_Info *info) return do_define_syntaxes_sfs(data, info); } -static Scheme_Object *define_for_syntaxes_sfs(Scheme_Object *data, SFS_Info *info) +static Scheme_Object *begin_for_syntax_sfs(Scheme_Object *data, SFS_Info *info) { - return do_define_syntaxes_sfs(data, info); + Scheme_Object *l, *a; + + if (!info->pass) { + int depth; + depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[2]); + + for (l = SCHEME_VEC_ELS(data)[0]; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { + a = SCHEME_CAR(l); + info = scheme_new_sfs_info(depth); + a = scheme_sfs(a, info, depth); + SCHEME_CAR(l) = a; + } + } + + return data; } /*========================================================================*/ @@ -1051,7 +1065,7 @@ module_sfs(Scheme_Object *data, SFS_Info *old_info) Scheme_Module *m = (Scheme_Module *)data; Scheme_Object *e, *ex; SFS_Info *info; - int i, cnt, let_depth; + int i, j, cnt, let_depth; if (!old_info->for_mod) { if (old_info->pass) @@ -1065,25 +1079,27 @@ module_sfs(Scheme_Object *data, SFS_Info *old_info) info = old_info; - cnt = SCHEME_VEC_SIZE(m->body); + cnt = SCHEME_VEC_SIZE(m->bodies[0]); scheme_sfs_start_sequence(info, cnt, 0); for (i = 0; i < cnt; i++) { - e = scheme_sfs_expr(SCHEME_VEC_ELS(m->body)[i], info, -1); - SCHEME_VEC_ELS(m->body)[i] = e; + e = scheme_sfs_expr(SCHEME_VEC_ELS(m->bodies[0])[i], info, -1); + SCHEME_VEC_ELS(m->bodies[0])[i] = e; } if (!info->pass) { - cnt = SCHEME_VEC_SIZE(m->et_body); - for (i = 0; i < cnt; i++) { - e = SCHEME_VEC_ELS(m->et_body)[i]; - - let_depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(e)[2]); - ex = SCHEME_VEC_ELS(e)[1]; - - info = scheme_new_sfs_info(let_depth); - ex = scheme_sfs(ex, info, let_depth); - SCHEME_VEC_ELS(e)[1] = ex; + for (j = m->num_phases; j-- > 1; ) { + cnt = SCHEME_VEC_SIZE(m->bodies[j]); + for (i = 0; i < cnt; i++) { + e = SCHEME_VEC_ELS(m->bodies[j])[i]; + + let_depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(e)[2]); + ex = SCHEME_VEC_ELS(e)[1]; + + info = scheme_new_sfs_info(let_depth); + ex = scheme_sfs(ex, info, let_depth); + SCHEME_VEC_ELS(e)[1] = ex; + } } } @@ -1205,11 +1221,11 @@ Scheme_Object *scheme_sfs_expr(Scheme_Object *expr, SFS_Info *info, int closure_ expr = define_values_sfs(expr, info); break; case scheme_define_syntaxes_type: - expr = define_for_syntaxes_sfs(expr, info); - break; - case scheme_define_for_syntax_type: expr = define_syntaxes_sfs(expr, info); break; + case scheme_begin_for_syntax_type: + expr = begin_for_syntax_sfs(expr, info); + break; case scheme_set_bang_type: expr = set_sfs(expr, info); break; diff --git a/src/racket/src/startup.inc b/src/racket/src/startup.inc index 39623b781f..6f6969481a 100644 --- a/src/racket/src/startup.inc +++ b/src/racket/src/startup.inc @@ -8,8 +8,8 @@ " let let* letrec" " parameterize" " define)" -"(define-values-for-syntax(here-stx)" -"(quote-syntax here))" +"(begin-for-syntax " +"(define-values(here-stx)(quote-syntax here)))" "(define-syntaxes(unless)" "(lambda(stx)" "(let-values(((s)(syntax->list stx)))" diff --git a/src/racket/src/startup.rktl b/src/racket/src/startup.rktl index 95598ea0c1..8c5b451f3d 100644 --- a/src/racket/src/startup.rktl +++ b/src/racket/src/startup.rktl @@ -41,8 +41,8 @@ parameterize define) - (define-values-for-syntax (here-stx) - (quote-syntax here)) + (begin-for-syntax + (define-values (here-stx) (quote-syntax here))) (define-syntaxes (unless) (lambda (stx) diff --git a/src/racket/src/stypes.h b/src/racket/src/stypes.h index 4f8413527a..ecc7a0818f 100644 --- a/src/racket/src/stypes.h +++ b/src/racket/src/stypes.h @@ -20,7 +20,7 @@ enum { scheme_define_values_type, /* 15 */ scheme_define_syntaxes_type, /* 16 */ - scheme_define_for_syntax_type, /* 17 */ + scheme_begin_for_syntax_type, /* 17 */ scheme_set_bang_type, /* 18 */ scheme_boxenv_type, /* 19 */ scheme_begin0_sequence_type, /* 20 */ @@ -270,6 +270,7 @@ enum { scheme_rt_validate_clearing, /* 246 */ scheme_rt_rb_node, /* 247 */ scheme_rt_lightweight_cont, /* 248 */ + scheme_rt_export_info, /* 249 */ #endif _scheme_last_type_ diff --git a/src/racket/src/syntax.c b/src/racket/src/syntax.c index fd59520c95..4a81f7ed24 100644 --- a/src/racket/src/syntax.c +++ b/src/racket/src/syntax.c @@ -4355,8 +4355,11 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ result = glob_id; } else { result = SCHEME_CDR(rename); - if (SCHEME_PAIRP(result)) + if (SCHEME_PAIRP(result)) { + if (SCHEME_INTP(SCHEME_CAR(result))) /* phase? */ + result = SCHEME_CDR(result); result = SCHEME_CAR(result); + } } } else result = glob_id; diff --git a/src/racket/src/type.c b/src/racket/src/type.c index 2c4d588850..5d6c3700a4 100644 --- a/src/racket/src/type.c +++ b/src/racket/src/type.c @@ -125,7 +125,7 @@ scheme_init_type () set_name(scheme_define_values_type, "<define-values-code>"); set_name(scheme_define_syntaxes_type, "<define-syntaxes-code>"); - set_name(scheme_define_for_syntax_type, "<define-for-syntax-code>"); + set_name(scheme_begin_for_syntax_type, "<begin-for-syntax-code>"); set_name(scheme_begin0_sequence_type, "<begin0-code>"); set_name(scheme_splice_sequence_type, "<splicing-begin-code>"); set_name(scheme_module_type, "<module-code>"); @@ -540,7 +540,7 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_define_values_type, vector_obj); GC_REG_TRAV(scheme_define_syntaxes_type, vector_obj); - GC_REG_TRAV(scheme_define_for_syntax_type, vector_obj); + GC_REG_TRAV(scheme_begin_for_syntax_type, vector_obj); GC_REG_TRAV(scheme_varref_form_type, twoptr_obj); GC_REG_TRAV(scheme_apply_values_type, twoptr_obj); GC_REG_TRAV(scheme_boxenv_type, twoptr_obj); @@ -549,6 +549,7 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_splice_sequence_type, seq_rec); GC_REG_TRAV(scheme_set_bang_type, set_bang); GC_REG_TRAV(scheme_module_type, module_val); + GC_REG_TRAV(scheme_rt_export_info, exp_info_val); GC_REG_TRAV(scheme_require_form_type, twoptr_obj); GC_REG_TRAV(_scheme_values_types_, bad_trav); diff --git a/src/racket/src/validate.c b/src/racket/src/validate.c index 0c162d7dcb..d1e7ecb1db 100644 --- a/src/racket/src/validate.c +++ b/src/racket/src/validate.c @@ -430,7 +430,7 @@ static void do_define_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, Scheme_Object *name, *val, *base_stack_depth, *dummy; int sdepth; - if (!SAME_TYPE(SCHEME_TYPE(data), (for_stx ? scheme_define_for_syntax_type : scheme_define_syntaxes_type)) + if (!SAME_TYPE(SCHEME_TYPE(data), (for_stx ? scheme_begin_for_syntax_type : scheme_define_syntaxes_type)) || (SCHEME_VEC_SIZE(data) < 4)) scheme_ill_formed_code(port); @@ -462,10 +462,13 @@ static void do_define_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, if (!for_stx) { scheme_validate_code(port, SCHEME_VEC_ELS(data)[0], sdepth, rp->num_toplevels, rp->num_stxes, rp->num_lifts, NULL, 0); } else { - /* Make a fake `define-values' to check with respect to the exp-time stack */ - val = scheme_clone_vector(data, 3, 1); - SCHEME_VEC_ELS(val)[0] = SCHEME_VEC_ELS(data)[0]; - scheme_validate_code(port, val, sdepth, rp->num_toplevels, rp->num_stxes, rp->num_lifts, NULL, 0); + val = SCHEME_VEC_ELS(data)[0]; + while (SCHEME_PAIRP(val)) { + scheme_validate_code(port, SCHEME_CAR(val), sdepth, rp->num_toplevels, rp->num_stxes, rp->num_lifts, NULL, 0); + val = SCHEME_CDR(val); + } + if (!SCHEME_NULLP(val)) + scheme_ill_formed_code(port); } } @@ -481,13 +484,13 @@ static void define_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, num_toplevels, num_stxes, num_lifts, tl_use_map, 0); } -static void define_for_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs) +static void begin_for_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, + char *stack, Validate_TLS tls, + int depth, int letlimit, int delta, + int num_toplevels, int num_stxes, int num_lifts, + void *tl_use_map, int result_ignored, + struct Validate_Clearing *vc, int tailpos, + Scheme_Hash_Tree *procs) { do_define_syntaxes_validate(data, port, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, 1); @@ -849,7 +852,7 @@ static void module_validate(Scheme_Object *data, Mz_CPort *port, Scheme_Hash_Tree *procs) { Scheme_Module *m; - int i, cnt, let_depth; + int i, j, cnt, let_depth; Resolve_Prefix *rp; Scheme_Object *e; @@ -859,23 +862,25 @@ static void module_validate(Scheme_Object *data, Mz_CPort *port, if (!SCHEME_MODNAMEP(m->modname)) scheme_ill_formed_code(port); - scheme_validate_code(port, m->body, m->max_let_depth, + scheme_validate_code(port, m->bodies[0], m->max_let_depth, m->prefix->num_toplevels, m->prefix->num_stxes, m->prefix->num_lifts, NULL, 1); /* validate exp-time code */ - cnt = SCHEME_VEC_SIZE(m->et_body); - for (i = 0; i < cnt; i++) { - e = SCHEME_VEC_ELS(m->et_body)[i]; + for (j = m->num_phases; j-- > 1; ) { + cnt = SCHEME_VEC_SIZE(m->bodies[j]); + for (i = 0; i < cnt; i++) { + e = SCHEME_VEC_ELS(m->bodies[j])[i]; - let_depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(e)[2]); - rp = (Resolve_Prefix *)SCHEME_VEC_ELS(e)[3]; - e = SCHEME_VEC_ELS(e)[1]; + let_depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(e)[2]); + rp = (Resolve_Prefix *)SCHEME_VEC_ELS(e)[3]; + e = SCHEME_VEC_ELS(e)[1]; - scheme_validate_code(port, e, let_depth, - rp->num_toplevels, rp->num_stxes, rp->num_lifts, NULL, - 0); + scheme_validate_code(port, e, let_depth, + rp->num_toplevels, rp->num_stxes, rp->num_lifts, NULL, + 0); + } } } @@ -1442,11 +1447,11 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr, num_toplevels, num_stxes, num_lifts, tl_use_map, result_ignored, vc, tailpos, procs); break; - case scheme_define_for_syntax_type: + case scheme_begin_for_syntax_type: no_flo(need_flonum, port); - define_for_syntaxes_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - result_ignored, vc, tailpos, procs); + begin_for_syntaxes_validate(expr, port, stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + result_ignored, vc, tailpos, procs); break; case scheme_set_bang_type: no_flo(need_flonum, port); From bb62ca4c2b6a933dc2c465e7420b50b90e1d30cc Mon Sep 17 00:00:00 2001 From: Vincent St-Amour <stamourv@racket-lang.org> Date: Wed, 7 Sep 2011 17:05:42 -0400 Subject: [PATCH 228/235] Fix Performance Report message in the absence of irritants. --- collects/typed-racket/optimizer/float.rkt | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/collects/typed-racket/optimizer/float.rkt b/collects/typed-racket/optimizer/float.rkt index b6620a224e..66022808f3 100644 --- a/collects/typed-racket/optimizer/float.rkt +++ b/collects/typed-racket/optimizer/float.rkt @@ -79,7 +79,11 @@ (define (log-float-real-missed-opt stx irritants) (log-missed-optimization "all args float-arg-expr, result not Float" - "This expression has a Real type. It would be better optimized if it had a Float type. To fix this, change the highlighted expression(s) to have Float type(s)." + (string-append + "This expression has a Real type. It would be better optimized if it had a Float type." + (if (null? irritants) + "" + "To fix this, change the highlighted expression(s) to have Float type(s).")) stx irritants)) (define float-opt-msg "Float arithmetic specialization.") From 7e9bf9361d3460cb0b412bc70ce8cb3465d4b362 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour <stamourv@racket-lang.org> Date: Wed, 7 Sep 2011 18:01:41 -0400 Subject: [PATCH 229/235] Make Performance Report highlighting high priority. --- collects/typed-racket/optimizer/tool/tool.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-racket/optimizer/tool/tool.rkt b/collects/typed-racket/optimizer/tool/tool.rkt index 39a5adbcc9..926aa31aac 100644 --- a/collects/typed-racket/optimizer/tool/tool.rkt +++ b/collects/typed-racket/optimizer/tool/tool.rkt @@ -42,7 +42,7 @@ (let ([color (if (= badness 0) "lightgreen" (vector-ref color-table badness))]) - (send this highlight-range start end color) + (send this highlight-range start end color #f 'high) (send this set-clickback start end (popup-callback l)) ;; record highlight to undo it later (list start end color))])) From 68aad051e9ee3bd3a516eaa8048c82ec4a980365 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour <stamourv@racket-lang.org> Date: Wed, 7 Sep 2011 18:08:07 -0400 Subject: [PATCH 230/235] Reduce priority of paren matching highlighting. --- collects/framework/private/color.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/framework/private/color.rkt b/collects/framework/private/color.rkt index b850d9b69a..91e8ac8b7f 100644 --- a/collects/framework/private/color.rkt +++ b/collects/framework/private/color.rkt @@ -638,7 +638,8 @@ added get-regions (if (is-a? color color%) color (if color mismatch-color (get-match-color))) - (= caret-pos (+ start-pos start)))]) + (= caret-pos (+ start-pos start)) + 'low)]) (set! clear-old-locations (let ([old clear-old-locations]) (λ () From 0229e762bc7836465043f0bc30c5180e578c5021 Mon Sep 17 00:00:00 2001 From: Matthew Flatt <mflatt@racket-lang.org> Date: Thu, 8 Sep 2011 18:26:25 -0600 Subject: [PATCH 231/235] fix place-unfriendly static in ffi Lazy initialization of statics shared across places doesn't work. Also, each static must be registered with the GC exactly once; I'm not sure why regstering on every callback didn't cause more problems. --- src/foreign/foreign.c | 9 +++++---- src/foreign/foreign.rktc | 9 +++++---- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index 53692af8ae..80f4ad7a13 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -2796,12 +2796,13 @@ void free_fficall_data(void *ignored, void *p) free(p); } +static Scheme_Object *ffi_name_prefix = NULL; + /* (ffi-call ffi-obj in-types out-type [abi save-errno? orig-place?]) -> (in-types -> out-value) */ /* the real work is done by ffi_do_call above */ #define MYNAME "ffi-call" static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[]) { - static Scheme_Object *ffi_name_prefix = NULL; Scheme_Object *itypes = argv[1]; Scheme_Object *otype = argv[2]; Scheme_Object *obj, *data, *p, *base; @@ -2816,9 +2817,6 @@ static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[]) #else # define FFI_CALL_VEC_SIZE 7 #endif - MZ_REGISTER_STATIC(ffi_name_prefix); - if (!ffi_name_prefix) - ffi_name_prefix = scheme_make_byte_string_without_copying("ffi:"); if (!SCHEME_FFIANYPTRP(argv[0])) scheme_wrong_type(MYNAME, "ffi-obj-or-cpointer", 0, argc, argv); obj = SCHEME_FFIANYPTR_VAL(argv[0]); @@ -3403,6 +3401,9 @@ void scheme_init_foreign_globals() fail_ok_sym = scheme_intern_symbol("fail-ok"); MZ_REGISTER_STATIC(abs_sym); abs_sym = scheme_intern_symbol("abs"); + + MZ_REGISTER_STATIC(ffi_name_prefix); + ffi_name_prefix = scheme_make_byte_string_without_copying("ffi:"); } void scheme_init_foreign_places() { diff --git a/src/foreign/foreign.rktc b/src/foreign/foreign.rktc index 0944b08e46..f59704d55c 100755 --- a/src/foreign/foreign.rktc +++ b/src/foreign/foreign.rktc @@ -2151,10 +2151,11 @@ void free_fficall_data(void *ignored, void *p) free(p); } +static Scheme_Object *ffi_name_prefix = NULL; + /* (ffi-call ffi-obj in-types out-type [abi save-errno? orig-place?]) -> (in-types -> out-value) */ /* the real work is done by ffi_do_call above */ @cdefine[ffi-call 3 6]{ - static Scheme_Object *ffi_name_prefix = NULL; Scheme_Object *itypes = argv[1]; Scheme_Object *otype = argv[2]; Scheme_Object *obj, *data, *p, *base; @@ -2169,9 +2170,6 @@ void free_fficall_data(void *ignored, void *p) #else # define FFI_CALL_VEC_SIZE 7 #endif - MZ_REGISTER_STATIC(ffi_name_prefix); - if (!ffi_name_prefix) - ffi_name_prefix = scheme_make_byte_string_without_copying("ffi:"); if (!SCHEME_FFIANYPTRP(argv[0])) scheme_wrong_type(MYNAME, "ffi-obj-or-cpointer", 0, argc, argv); obj = SCHEME_FFIANYPTR_VAL(argv[0]); @@ -2717,6 +2715,9 @@ void scheme_init_foreign_globals() @list{MZ_REGISTER_STATIC(@(cadr sym)); @(cadr sym) = scheme_intern_symbol("@(car sym)")}) (reverse (symbols))) + + MZ_REGISTER_STATIC(ffi_name_prefix); + ffi_name_prefix = scheme_make_byte_string_without_copying("ffi:"); } void scheme_init_foreign_places() { From 41bdb139d46fe966981a03a3ca555212915f4055 Mon Sep 17 00:00:00 2001 From: Matthew Flatt <mflatt@racket-lang.org> Date: Thu, 8 Sep 2011 19:03:54 -0600 Subject: [PATCH 232/235] fix a formerly overlooked `kernel-syntax-case' Caught by the Check Syntax tests that use Pretty Big --- collects/syntax/toplevel.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/syntax/toplevel.rkt b/collects/syntax/toplevel.rkt index dd278e6e41..7602e52dfe 100644 --- a/collects/syntax/toplevel.rkt +++ b/collects/syntax/toplevel.rkt @@ -68,7 +68,7 @@ (eval/compile stx)] [(define-syntaxes . _) (eval/compile stx)] - [(define-values-for-syntax . _) + [(begin-for-syntax . _) (eval/compile stx)] [(define-values (id ...) . _) (begin0 From a274a7fd724a7628c229d2ec5621168f73499db2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt <mflatt@racket-lang.org> Date: Thu, 8 Sep 2011 19:12:46 -0600 Subject: [PATCH 233/235] partially fix Check Syntax for `begin-for-syntax' --- collects/drracket/private/syncheck/traversals.rkt | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/collects/drracket/private/syncheck/traversals.rkt b/collects/drracket/private/syncheck/traversals.rkt index e156fd40da..e986f7f0e3 100644 --- a/collects/drracket/private/syncheck/traversals.rkt +++ b/collects/drracket/private/syncheck/traversals.rkt @@ -185,7 +185,7 @@ (syntax-case* sexp (#%plain-lambda case-lambda if begin begin0 let-values letrec-values set! quote quote-syntax with-continuation-mark #%plain-app #%top #%plain-module-begin - define-values define-syntaxes define-values-for-syntax module + define-values define-syntaxes begin-for-syntax module #%require #%provide #%expression) (if high-level? free-transformer-identifier=? free-identifier=?) [(#%plain-lambda args bodies ...) @@ -317,12 +317,10 @@ (add-binders (syntax names) binders binding-inits #'exp) (maybe-jump (syntax names)) (level-loop (syntax exp) #t))] - [(define-values-for-syntax names exp) + [(begin-for-syntax exp ...) (begin (annotate-raw-keyword sexp varrefs) - (add-binders (syntax names) high-binders binding-inits #'exp) - (maybe-jump (syntax names)) - (level-loop (syntax exp) #t))] + (for-each (lambda (e) (level-loop e #t)) (syntax->list (syntax (exp ...)))))] [(module m-name lang (#%plain-module-begin bodies ...)) (begin (annotate-raw-keyword sexp varrefs) From b1eab296f4e0f48152f82efed382f4674310f2ef Mon Sep 17 00:00:00 2001 From: Matthew Flatt <mflatt@racket-lang.org> Date: Thu, 8 Sep 2011 19:19:14 -0600 Subject: [PATCH 234/235] fix demod for `begin-for-syntax' changes --- collects/compiler/demodularizer/module.rkt | 2 +- collects/compiler/demodularizer/nodep.rkt | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/compiler/demodularizer/module.rkt b/collects/compiler/demodularizer/module.rkt index 48253dd7e2..0bf82da22c 100644 --- a/collects/compiler/demodularizer/module.rkt +++ b/collects/compiler/demodularizer/module.rkt @@ -24,7 +24,7 @@ (list (cons 0 requires)) new-forms empty ; syntax-body - (list empty empty empty) ; unexported + (list) ; unexported max-let-depth (make-toplevel 0 0 #f #f) ; dummy lang-info diff --git a/collects/compiler/demodularizer/nodep.rkt b/collects/compiler/demodularizer/nodep.rkt index c37f82ceea..68cc899241 100644 --- a/collects/compiler/demodularizer/nodep.rkt +++ b/collects/compiler/demodularizer/nodep.rkt @@ -128,7 +128,7 @@ (append (requires->modlist requires phase) (if (and phase (zero? phase)) (begin (log-debug (format "[~S] lang-info : ~S" name lang-info)) ; XXX Seems to always be #f now - (list (make-mod name srcname self-modidx new-prefix provides requires body syntax-bodies empty + (list (make-mod name srcname self-modidx new-prefix provides requires body empty unexported max-let-depth dummy lang-info internal-context))) (begin (log-debug (format "[~S] Dropping module @ ~S" name phase)) empty))))] From db2e3ab3b6525807c42cf8b370511d800d081610 Mon Sep 17 00:00:00 2001 From: Robby Findler <robby@racket-lang.org> Date: Thu, 8 Sep 2011 22:44:57 -0500 Subject: [PATCH 235/235] adjust the error display to highlight in the margin instead of on top of the text --- collects/drracket/private/module-language.rkt | 108 ++++++++++++++---- 1 file changed, 84 insertions(+), 24 deletions(-) diff --git a/collects/drracket/private/module-language.rkt b/collects/drracket/private/module-language.rkt index 3eb7812097..54d8863071 100644 --- a/collects/drracket/private/module-language.rkt +++ b/collects/drracket/private/module-language.rkt @@ -9,7 +9,7 @@ racket/sandbox racket/runtime-path racket/math - mred + racket/gui/base compiler/embed compiler/cm launcher @@ -533,7 +533,9 @@ new-parent #:case-sensitive #t - #:get-debugging-radio-box (λ (rb-l rb-r) (set! left-debugging-radio-box rb-l) (set! right-debugging-radio-box rb-r)) + #:get-debugging-radio-box (λ (rb-l rb-r) + (set! left-debugging-radio-box rb-l) + (set! right-debugging-radio-box rb-r)) #:debugging-radio-box-callback (λ (debugging-radio-box evt) @@ -659,7 +661,8 @@ (define (get-lb-vector) (list->vector (for/list ([n (in-range (send collection-paths-lb get-number))]) - (cons (send collection-paths-lb get-string n) (send collection-paths-lb get-data n))))) + (cons (send collection-paths-lb get-string n) + (send collection-paths-lb get-data n))))) (define (set-lb-vector vec) (send collection-paths-lb clear) @@ -830,7 +833,9 @@ [stretchable-height #f] [parent expand-error-parent-panel])) - (set! expand-error-message (new error-message% [parent expand-error-panel] [stretchable-width #t] [msg "hi"])) + (set! expand-error-message (new error-message% [parent expand-error-panel] + [stretchable-width #t] + [msg "hi"])) (set! expand-error-button-parent-panel (new vertical-panel% [stretchable-width #f] @@ -1086,10 +1091,11 @@ (unless place-initialized? (set! place-initialized? #t) (place-channel-put expanding-place module-language-compile-lock) - (place-channel-put expanding-place - (for/list ([o-e-h (in-list (drracket:module-language-tools:get-online-expansion-handlers))]) - (list (drracket:module-language-tools:online-expansion-handler-mod-path o-e-h) - (drracket:module-language-tools:online-expansion-handler-id o-e-h))))) + (place-channel-put + expanding-place + (for/list ([o-e-h (in-list (drracket:module-language-tools:get-online-expansion-handlers))]) + (list (drracket:module-language-tools:online-expansion-handler-mod-path o-e-h) + (drracket:module-language-tools:online-expansion-handler-id o-e-h))))) (set! pending-thread (thread (λ () (define-values (pc-in pc-out) (place-channel)) @@ -1119,7 +1125,7 @@ drracket:unit:definitions-text<%> drracket:module-language-tools:definitions-text<%>) () (inherit last-position find-first-snip get-top-level-window get-filename - get-tab highlight-range get-canvas + get-tab get-canvas invalidate-bitmap-cache set-position get-start-position get-end-position) (define compilation-out-of-date? #f) @@ -1133,7 +1139,6 @@ (define/private (buffer-modified) (clear-old-error) - (set! clear-old-error void) (reset-frame-expand-error) (let ([tlw (get-top-level-window)]) (when expanding-place @@ -1166,7 +1171,6 @@ (λ (res) (show-results res))) (when status-line-open? (clear-old-error) - (set! clear-old-error void) (reset-frame-expand-error)) (send (get-tab) show-bkg-running 'running sc-online-expansion-running))))) @@ -1191,7 +1195,6 @@ (values str fn))) (define status-line-open? #f) - (define clear-old-error void) (define error-message-str #f) (define error-message-srclocs '()) @@ -1243,40 +1246,35 @@ [(exn) (define tlw (send (get-tab) get-frame)) (send (get-tab) show-bkg-running 'nothing #f) - (clear-old-error) (set! error-message-str (vector-ref res 1)) (set! error-message-srclocs (vector-ref res 2)) - (set! clear-old-error - (for/fold ([clear void]) - ([range (in-list (vector-ref res 2))]) + (set! error-ranges + (for/list ([range (in-list (vector-ref res 2))]) (define pos (vector-ref range 0)) (define span (vector-ref range 1)) - (define clear-next (highlight-range (- pos 1) (+ pos span -1) "Gold" #f 'high)) - (lambda () (clear) (clear-next)))) + (list (- pos 1) (+ pos span -1)))) + ;; should really only invalidate the appropriate region here (and in clear-error-ranges) + (invalidate-bitmap-cache 0 0 'display-end 'display-end) (update-frame-expand-error)] [(access-violation) (send (get-tab) show-bkg-running 'failed (gui-utils:format-literal-label "~a" (vector-ref res 1))) (clear-old-error) - (set! clear-old-error void) (reset-frame-expand-error)] [(reader-in-defs-error) - (send (get-tab) show-bkg-running 'reader-in-defs-error (gui-utils:format-literal-label "~a" (vector-ref res 1))) + (send (get-tab) show-bkg-running 'reader-in-defs-error + (gui-utils:format-literal-label "~a" (vector-ref res 1))) (clear-old-error) - (set! clear-old-error void) (reset-frame-expand-error)] [(abnormal-termination) (send (get-tab) show-bkg-running 'failed sc-abnormal-termination) (clear-old-error) - (set! clear-old-error void) (reset-frame-expand-error)] [(no-errors) (send (get-tab) show-bkg-running 'nothing #f) (clear-old-error) - (set! clear-old-error void) (reset-frame-expand-error)] [(handler-results) (clear-old-error) - (set! clear-old-error void) (reset-frame-expand-error) ;; inform the installed handlers that something has come back (for ([key-val (in-list (vector-ref res 1))]) @@ -1291,6 +1289,68 @@ [else (error 'module-language.rkt "unknown response from the expanding place: ~s\n" res)])) + + (define error-ranges '()) + (define/private (clear-old-error) + (set! error-ranges '()) + (invalidate-bitmap-cache 0 0 'display-end 'display-end)) + + (define byt (box 0.0)) + (define byb (box 0.0)) + (define vbx (box 0.0)) + (define vby (box 0.0)) + (define vbw (box 0.0)) + (define vbh (box 0.0)) + + (inherit position-location get-admin) + (define/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) + (unless before? + (define pen-width 8) + (define saved-brush (send dc get-brush)) + (define saved-pen (send dc get-pen)) + (define smoothing (send dc get-smoothing)) + (send dc set-smoothing 'smoothed) + + (define path (new dc-path%)) + (send dc set-brush "black" 'transparent) + (send dc set-pen (send the-pen-list find-or-create-pen "red" pen-width 'solid 'butt 'miter)) + (send dc set-alpha .4) + + (for ([error-range (in-list error-ranges)]) + (define start-pos (list-ref error-range 0)) + (define end-pos (list-ref error-range 1)) + (position-location start-pos #f byt) + (position-location end-pos #f byb #f) + (send (get-admin) get-view vbx vby vbw vbh) + + (define x2 (+ dx (unbox vbx) (unbox vbw) (- (/ pen-width 2)) (- (/ pen-width 1)))) + (define y2 (+ dy (unbox byt))) + + (define x1 (+ x2 (- (/ pen-width 1)))) + (define y1 y2) + + (define x3 x2) + (define y3 (+ dy (unbox byb))) + + (define x4 x1) + (define y4 y3) + + (send path move-to x1 y1) + (send path line-to x2 y2) + (send path line-to x3 y3) + (send path line-to x4 y4) + (send path line-to x3 y3) + (send path line-to x2 y2) + (send path move-to x1 y1) + (send path close)) + + (send dc draw-path path) + (send dc set-alpha 1) + (send dc set-brush saved-brush) + (send dc set-pen saved-pen) + (send dc set-smoothing smoothing))) + (define/override (move-to-new-language) ;; this is here to get things running for the initital tab in a new frame (super move-to-new-language)