From 546e09e0d92be957e892d7f25f5151d3c795d990 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 25 Jul 2010 10:51:19 -0500 Subject: [PATCH 01/21] add collection-file-path and splace collection trees at the file level original commit: 5f1aa418f30f4df086c85ed18dfc5395468b1638 --- collects/mzlib/file.rkt | 8 +------- collects/mzlib/include.rkt | 9 +++++---- collects/mzlib/runtime-path.rkt | 13 +++++++------ 3 files changed, 13 insertions(+), 17 deletions(-) diff --git a/collects/mzlib/file.rkt b/collects/mzlib/file.rkt index 2a6aa56..944e1b0 100644 --- a/collects/mzlib/file.rkt +++ b/collects/mzlib/file.rkt @@ -39,13 +39,7 @@ (apply build-path p args))) (define (find-library name . cp) - (let ([dir (with-handlers ([exn:fail:filesystem? (lambda (exn) #f)]) - (if (null? cp) - (collection-path "mzlib") - (apply collection-path cp)))]) - (and dir - (let ([file (build-path dir name)]) - (and (file-exists? file) file))))) + (apply collection-file-path name cp)) (define (-call-with-input-file* file thunk . flags) (let ([p (apply mz:open-input-file file flags)]) diff --git a/collects/mzlib/include.rkt b/collects/mzlib/include.rkt index 8050a00..356f326 100644 --- a/collects/mzlib/include.rkt +++ b/collects/mzlib/include.rkt @@ -38,10 +38,11 @@ "`lib' keyword is not followed by a sequence of string datums" stx fn)) - (build-path (if (null? (cdr l)) - (collection-path "mzlib") - (apply collection-path (cdr l))) - (car l)))] + (apply collection-file-path + (car l) + (if (null? (cdr l)) + (list "mzlib") + (cdr l))))] [else (raise-syntax-error #f diff --git a/collects/mzlib/runtime-path.rkt b/collects/mzlib/runtime-path.rkt index 82b87f4..e1ec2f8 100644 --- a/collects/mzlib/runtime-path.rkt +++ b/collects/mzlib/runtime-path.rkt @@ -78,12 +78,13 @@ (let ([s (cadr p)]) (if (regexp-match? #rx"[./]" s) s - (string-append s "/main.rkt"))))] - [dir (if (and (null? (cddr p)) - (null? (cdr strs))) - (collection-path "mzlib") - (apply collection-path (append (cddr p) (drop-right strs 1))))]) - (build-path dir (last strs)))] + (string-append s "/main.rkt"))))]) + (apply collection-file-path + (last strs) + (if (and (null? (cddr p)) + (null? (cdr strs))) + (list "mzlib") + (append (cddr p) (drop-right strs 1)))))] [else (error 'runtime-path "unknown form: ~e" p)]))) paths))) From 8258184a9afffa34d005922c69a4c7fde156bc6b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 10 Aug 2010 22:20:33 -0500 Subject: [PATCH 02/21] added contract-struct (like define-contract-struct, but with a maker whose name does not begin with 'make-') original commit: 367779fd27ba98422d288dd3b0c0db70f31bb4ca --- collects/mzlib/contract.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/mzlib/contract.rkt b/collects/mzlib/contract.rkt index e9a8146..462ff7c 100644 --- a/collects/mzlib/contract.rkt +++ b/collects/mzlib/contract.rkt @@ -40,7 +40,8 @@ (provide opt/c define-opt/c ;(all-from "private/contract-opt.rkt") (except-out (all-from-out racket/contract/private/ds) - lazy-depth-to-look) + lazy-depth-to-look + contract-struct) (all-from-out racket/contract/private/base) (all-from-out racket/contract/private/provide) From bfeb87cacdee9a83139e4fa471db847e8e280f14 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 25 Aug 2010 16:10:55 -0400 Subject: [PATCH 03/21] Lots of "~e" to "~.s" changes. original commit: 606b7f60dc597a6870efc11364e1dd3e1a8b4a1b --- collects/mzlib/kw.rkt | 12 ++++++------ collects/mzlib/runtime-path.rkt | 2 +- collects/mzlib/unit.rkt | 4 ++-- 3 files changed, 9 insertions(+), 9 deletions(-) diff --git a/collects/mzlib/kw.rkt b/collects/mzlib/kw.rkt index 105cc80..6645627 100644 --- a/collects/mzlib/kw.rkt +++ b/collects/mzlib/kw.rkt @@ -331,7 +331,7 @@ #`((if (and in-seen? in-keys?) #,(if allow-duplicate-keys? #`seen-keys - #`(error* 'name "duplicate keyword: ~e" + #`(error* 'name "duplicate keyword: ~.s" (car body*))) (cons (car body*) seen-keys))) '()))]) @@ -343,12 +343,12 @@ nl #`(if in-keys? #,nl - (error* 'name "unknown keyword: ~e" + (error* 'name "unknown keyword: ~.s" (car body*)))))] [(not allow-other-keys?) #`(if (memq (car body*) 'keywords) #,nl - (error* 'name "unknown keyword: ~e" + (error* 'name "unknown keyword: ~.s" (car body*)))] [else nl]))] [expr @@ -381,7 +381,7 @@ #'next-loop #'(if (pair? (cdr body*)) next-loop - (error* 'name "keyword list not balanced: ~e" rest*))) + (error* 'name "keyword list not balanced: ~.s" rest*))) #,(if allow-body? (if (and body (not (identifier? body))) (with-syntax ([name (string->symbol @@ -395,7 +395,7 @@ #'expr) #'(if (null? body*) expr - (error* 'name "expecting a ~s keyword got: ~e" + (error* 'name "expecting a ~s keyword got: ~.s" 'keywords (car body*)))))))))) ;; ------------------------------------------------------------------------ ;; generates the loop that turns flags to #t's @@ -456,7 +456,7 @@ (syntax/loc stx (lambda vars (if (and (pair? body) (keyword? (car body))) - (error* 'name "unknown keyword: ~e" (car body)) + (error* 'name "unknown keyword: ~.s" (car body)) expr)))))] ;; no keys => make a case-lambda for optionals [(and (null? keys) (not (or body allow-other-keys?))) diff --git a/collects/mzlib/runtime-path.rkt b/collects/mzlib/runtime-path.rkt index e1ec2f8..a8c2891 100644 --- a/collects/mzlib/runtime-path.rkt +++ b/collects/mzlib/runtime-path.rkt @@ -85,7 +85,7 @@ (null? (cdr strs))) (list "mzlib") (append (cddr p) (drop-right strs 1)))))] - [else (error 'runtime-path "unknown form: ~e" p)]))) + [else (error 'runtime-path "unknown form: ~.s" p)]))) paths))) (define-for-syntax (register-ext-files tag-stx paths) diff --git a/collects/mzlib/unit.rkt b/collects/mzlib/unit.rkt index b4438f1..22b3c67 100644 --- a/collects/mzlib/unit.rkt +++ b/collects/mzlib/unit.rkt @@ -843,7 +843,7 @@ (names (apply append nameses)) (dup (check-duplicate-identifier names))) (when dup - (raise-stx-err (format "duplicate binding for ~e" (syntax-e dup)))) + (raise-stx-err (format "duplicate binding for ~.s" (syntax-e dup)))) (quasisyntax/loc stx (provide #,@names)))))) @@ -1652,7 +1652,7 @@ (tmp-bindings (map (λ (s) (map tmarker (map car (car s)))) out-sigs)) (def-table (make-bound-identifier-mapping))) (when dup - (raise-stx-err (format "duplicate binding for ~e" (syntax-e dup)))) + (raise-stx-err (format "duplicate binding for ~.s" (syntax-e dup)))) (for-each (λ (sig new-xs) (for-each From cd4dbaad6acd90d275579572f635e639320a7d7e Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 26 Aug 2010 12:10:48 -0400 Subject: [PATCH 04/21] More "~n" -> "\n" changes original commit: 8e0f8dd39c3744472b450021f003f9cbe8cbcb62 --- collects/mzlib/date.rkt | 4 ++-- collects/mzlib/integer-set.rkt | 2 +- collects/mzlib/thread.rkt | 16 ++++++++-------- collects/mzlib/traceld.rkt | 4 ++-- collects/tests/racket/macrolib.rktl | 4 ++-- collects/tests/racket/pconvert.rktl | 4 ++-- 6 files changed, 17 insertions(+), 17 deletions(-) diff --git a/collects/mzlib/date.rkt b/collects/mzlib/date.rkt index 8e78a0c..13ec0e0 100644 --- a/collects/mzlib/date.rkt +++ b/collects/mzlib/date.rkt @@ -289,7 +289,7 @@ (if (<= input test) 'input-smaller 'test-smaller)))]))]) - ; (printf "~a ~a ~a~n" compare secs (date->string date)) + ; (printf "~a ~a ~a\n" compare secs (date->string date)) (cond [(eq? compare 'equal) secs] [(or (= secs below-secs) (= secs above-secs)) @@ -362,4 +362,4 @@ (caddr reversed-digits) (cadr reversed-digits) (car reversed-digits))) - (loop (cdr (cdr (cdr reversed-digits)))))))))))) \ No newline at end of file + (loop (cdr (cdr (cdr reversed-digits)))))))))))) diff --git a/collects/mzlib/integer-set.rkt b/collects/mzlib/integer-set.rkt index ac7bcce..10e8b69 100644 --- a/collects/mzlib/integer-set.rkt +++ b/collects/mzlib/integer-set.rkt @@ -8,7 +8,7 @@ (let* defs (let ((real-ans code)) (unless (equal? real-ans right-ans) - (printf "Test failed: ~e gave ~e. Expected ~e~n" + (printf "Test failed: ~e gave ~e. Expected ~e\n" 'code real-ans 'right-ans))) ...)))) (define-syntax test-block diff --git a/collects/mzlib/thread.rkt b/collects/mzlib/thread.rkt index 5ce3aa4..4c4d005 100644 --- a/collects/mzlib/thread.rkt +++ b/collects/mzlib/thread.rkt @@ -115,7 +115,7 @@ ;; coroutine : ((bool ->) -> X) -> X-coroutine-object (define (coroutine f) - ;;(printf "2. new coroutine~n") + ;;(printf "2. new coroutine\n") (let* ([can-stop-lock (make-semaphore 1)] [done-ch (make-channel)] [ex-ch (make-channel)] @@ -123,7 +123,7 @@ [stop-enabled? #t] [enable-stop (lambda (enable?) - ;;(printf "3. enabling ~a~n" enable?) + ;;(printf "3. enabling ~a\n" enable?) (cond [(and enable? (not stop-enabled?)) (semaphore-post can-stop-lock) @@ -131,11 +131,11 @@ [(and (not enable?) stop-enabled?) (semaphore-wait can-stop-lock) (set! stop-enabled? #f)]) - ;;(printf "3. finished enabling~n") + ;;(printf "3. finished enabling\n") )] [tid (thread (lambda () (semaphore-wait proceed-sema) - ;;(printf "3. creating coroutine thread~n") + ;;(printf "3. creating coroutine thread\n") (with-handlers ([(lambda (exn) #t) (lambda (exn) (enable-stop #t) @@ -152,7 +152,7 @@ (if (coroutine-object-worker w) (let ([can-stop-lock (coroutine-object-can-stop-lock w)] [worker (coroutine-object-worker w)]) - #;(printf "2. starting coroutine~n") + #;(printf "2. starting coroutine\n") (thread-resume worker) (dynamic-wind void @@ -162,20 +162,20 @@ timeout (alarm-evt (+ timeout (current-inexact-milliseconds)))) (lambda (x) - #;(printf "2. alarm-evt~n") + #;(printf "2. alarm-evt\n") (semaphore-wait can-stop-lock) (thread-suspend worker) (semaphore-post can-stop-lock) #f)) (wrap-evt (coroutine-object-done-ch w) (lambda (res) - #;(printf "2. coroutine-done-evt~n") + #;(printf "2. coroutine-done-evt\n") (set-coroutine-object-result! w res) (coroutine-kill w) #t)) (wrap-evt (coroutine-object-ex-ch w) (lambda (exn) - #;(printf "2. ex-evt~n") + #;(printf "2. ex-evt\n") (coroutine-kill w) (raise exn)))))) ;; In case we escape through a break: diff --git a/collects/mzlib/traceld.rkt b/collects/mzlib/traceld.rkt index f4a3f20..4d929fa 100644 --- a/collects/mzlib/traceld.rkt +++ b/collects/mzlib/traceld.rkt @@ -8,7 +8,7 @@ (lambda (load) (lambda (filename expected-module) (fprintf ep - "~aloading ~a at ~a~n" + "~aloading ~a at ~a\n" tab filename (current-process-milliseconds)) (begin0 (let ([s tab]) @@ -18,7 +18,7 @@ (load filename expected-module)) (lambda () (set! tab s)))) (fprintf ep - "~adone ~a at ~a~n" + "~adone ~a at ~a\n" tab filename (current-process-milliseconds)))))]) (current-load (mk-chain load)) (current-load-extension (mk-chain load-extension)))) diff --git a/collects/tests/racket/macrolib.rktl b/collects/tests/racket/macrolib.rktl index 23eb8b0..2f1ab25 100644 --- a/collects/tests/racket/macrolib.rktl +++ b/collects/tests/racket/macrolib.rktl @@ -97,7 +97,7 @@ (define (opt-lam-test exp expected) (let ([got (eval exp)]) (unless (equal? got expected) - (printf "FAILED test: ~a~n expected: ~s~n got: ~s~n" + (printf "FAILED test: ~a\n expected: ~s\n got: ~s\n" exp expected got)))) (define (opt-lam-test/bad exp expected) @@ -105,7 +105,7 @@ (lambda (exn) (exn-message exn))]) (cons 'got-result (eval exp)))]) (unless (regexp-match expected got) - (printf "FAILED test: ~a~n expected: ~s~n got: ~s~n" + (printf "FAILED test: ~a\n expected: ~s\n got: ~s\n" exp expected got)))) (test 1 (opt-lambda (start) start) 1) diff --git a/collects/tests/racket/pconvert.rktl b/collects/tests/racket/pconvert.rktl index 534ec11..484ee47 100644 --- a/collects/tests/racket/pconvert.rktl +++ b/collects/tests/racket/pconvert.rktl @@ -51,11 +51,11 @@ [whole/fractional-exact-numbers whole/fractional-numbers?]) (test (selector test-case) print-convert before)) (printf - ">> (constructor-style-printing ~a) (quasi-read-style-printing ~a) (show-sharing ~a) (abbreviate-cons-as-list ~a) (whole/fractional-exact-numbers ~a)~n" + ">> (constructor-style-printing ~a) (quasi-read-style-printing ~a) (show-sharing ~a) (abbreviate-cons-as-list ~a) (whole/fractional-exact-numbers ~a)\n" constructor-style? quasi-read? sharing? cons-as-list? whole/fractional-numbers?)))]) - ;(printf "testing: ~s~n" before) + ;(printf "testing: ~s\n" before) ;(printf ".") (flush-output (current-output-port)) (cond [(pctest? test-case) From cffcd4f2d78d561732f930fdbcdfdb15980e8462 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 12 Sep 2010 23:25:56 -0400 Subject: [PATCH 05/21] * Use #lang & reformat * Remove no longer relevant references to `macos' * Fix some type errors (that weren't reachable) * Make streamify-* always return the thread (`get-thread?' was always #t) original commit: a69d7c00c138b2efd8e298e1cc4e060917672a8c --- collects/mzlib/process.rkt | 349 ++++++++++++++++--------------------- 1 file changed, 155 insertions(+), 194 deletions(-) diff --git a/collects/mzlib/process.rkt b/collects/mzlib/process.rkt index 24775a3..67cbc64 100644 --- a/collects/mzlib/process.rkt +++ b/collects/mzlib/process.rkt @@ -1,210 +1,171 @@ +#lang mzscheme +(provide process + process* + process/ports + process*/ports + system + system* + system/exit-code + system*/exit-code) -(module process mzscheme - (provide process - process* - process/ports - process*/ports - system - system* - system/exit-code - system*/exit-code) +(require mzlib/port) - (require mzlib/port) +;; Helpers: ---------------------------------------- - ;; Helpers: ---------------------------------------- +(define (shell-path/args who argstr) + (case (system-type) + [(unix macosx) (append '("/bin/sh" "-c") (list argstr))] + [(windows) (let ([cmd + (let ([d (find-system-path 'sys-dir)]) + (let ([cmd (build-path d "cmd.exe")]) + (if (file-exists? cmd) + cmd + (let ([cmd (build-path d "command.com")]) + (if (file-exists? cmd) + cmd + ;; One last try: up a dir + (build-path d 'up "command.com"))))))]) + (list cmd + 'exact + (format "~a /c \"~a\"" (path->string cmd) argstr)))] + [else (raise-mismatch-error + who + (format "~a: don't know what shell to use for platform: " who) + (system-type))])) - (define (shell-path/args who argstr) - (case (system-type) - ((unix macosx) (append '("/bin/sh" "-c") (list argstr))) - ((windows) (let ([cmd - (let ([d (find-system-path 'sys-dir)]) - (let ([cmd (build-path d "cmd.exe")]) - (if (file-exists? cmd) - cmd - (let ([cmd (build-path d "command.com")]) - (if (file-exists? cmd) - cmd - ;; One last try: up a dir - (build-path d 'up "command.com"))))))]) - (list cmd - 'exact - (format "~a /c \"~a\"" (path->string cmd) argstr)))) - (else (raise-mismatch-error - who - (format "~a: don't know what shell to use for platform: " who) - (system-type))))) +(define (if-stream-out p) + (cond [(or (not p) (file-stream-port? p)) p] + [(output-port? p) #f] + [else (raise-type-error 'subprocess "output port" p)])) - (define (if-stream-out p) - (if (or (not p) (file-stream-port? p)) - p - (if (output-port? p) - #f - (raise-type-error - 'subprocess - "output port" - p)))) +(define (if-stream-in p) + (cond [(or (not p) (file-stream-port? p)) p] + [(input-port? p) #f] + [else (raise-type-error 'subprocess "input port" p)])) - (define (if-stream-in p) - (if (or (not p) (file-stream-port? p)) - p - (if (input-port? p) - #f - (raise-type-error - 'subprocess - "input port" - p)))) +(define (streamify-in cin in ready-for-break) + (if (and cin (not (file-stream-port? cin))) + (thread (lambda () + (dynamic-wind + void + (lambda () + (with-handlers ([exn:break? void]) + (ready-for-break #t) + (copy-port cin in) + (ready-for-break #f))) + (lambda () (close-output-port in))) + (ready-for-break #t))) + in)) - (define (streamify-in cin in get-thread? ready-for-break) - (if (and cin (not (file-stream-port? cin))) - (let ([t (thread (lambda () - (dynamic-wind - void - (lambda () - (with-handlers ([exn:break? void]) - (ready-for-break #t) - (copy-port cin in) - (ready-for-break #f))) - (lambda () (close-output-port in))) - (ready-for-break #t)))]) - (and get-thread? t)) - in)) +(define (streamify-out cout out) + (if (and cout (not (file-stream-port? cout))) + (thread (lambda () + (dynamic-wind + void + (lambda () (copy-port out cout)) + (lambda () (close-input-port out))))) + out)) - (define (streamify-out cout out get-thread?) - (if (and cout (not (file-stream-port? cout))) - (let ([t (thread (lambda () - (dynamic-wind - void - (lambda () (copy-port out cout)) - (lambda () (close-input-port out)))))]) - (and get-thread? t)) - out)) +;; Old-style functions: ---------------------------------------- - ;; Old-style functions: ---------------------------------------- +(define (process*/ports cout cin cerr exe . args) + (let-values ([(subp out in err) (apply subprocess + (if-stream-out cout) + (if-stream-in cin) + (if-stream-out cerr) + exe args)] + [(it-ready) (make-semaphore)]) + (let ([so (streamify-out cout out)] + [si (streamify-in cin in (lambda (ok?) + (if ok? + (semaphore-post it-ready) + (semaphore-wait it-ready))))] + [se (streamify-out cerr err)] + [aport (lambda (x) (and (port? x) x))]) + (when (thread? si) + ;; Wait for process to end, then stop copying input: + (thread (lambda () + (sync subp si) + (semaphore-wait it-ready) + (break-thread si)))) + (let ([threads-still-going? + (lambda () + (ormap (lambda (s) (and (thread? s) (thread-running? s))) + (list so si se)))]) + (define (control m) + (case m + [(status) + (let ([s (subprocess-status subp)]) + (cond [(or (not (integer? s)) (threads-still-going?)) + 'running] + [(zero? s) 'done-ok] + [else 'done-error]))] + [(exit-code) + (if (threads-still-going?) + #f + (let ([s (subprocess-status subp)]) (and (integer? s) s)))] + [(wait) + (subprocess-wait subp) + (let ([twait (lambda (t) (when (thread? t) (thread-wait t)))]) + (twait so) + (twait si) + (twait se))] + [(interrupt) (subprocess-kill subp #f)] + [(kill) (subprocess-kill subp #t)] + [else (raise-type-error + 'control-process + "'status, 'exit-code, 'wait, 'interrupt, or 'kill" m)])) + (list (aport so) + (aport si) + (subprocess-pid subp) + (aport se) + control))))) - (define (process*/ports cout cin cerr exe . args) - (let-values ([(subp out in err) (apply subprocess - (if-stream-out cout) - (if-stream-in cin) - (if-stream-out cerr) - exe args)] - [(it-ready) (make-semaphore)]) - (let ([so (streamify-out cout out #t)] - [si (streamify-in cin in #t (lambda (ok?) - (if ok? - (semaphore-post it-ready) - (semaphore-wait it-ready))))] - [se (streamify-out cerr err #t)] - [aport (lambda (x) - (and (port? x) x))]) - (when (thread? si) - ;; Wait for process to end, then stop copying input: - (thread (lambda () - (sync subp si) - (semaphore-wait it-ready) - (break-thread si)))) - (let ([threads-still-going? - (lambda () - (ormap (lambda (s) - (and (thread? s) - (thread-running? s))) - (list so si se)))]) - (list (aport so) - (aport si) - (subprocess-pid subp) - (aport se) - (letrec ((control - (lambda (m) - (case m - ((status) (let ((s (subprocess-status subp))) - (cond ((or (not (integer? s)) - (threads-still-going?)) - 'running) - ((zero? s) 'done-ok) - (else 'done-error)))) - ((exit-code) (if (threads-still-going?) - #f - (let ((s (subprocess-status subp))) - (and (integer? s) s)))) - ((wait) - (subprocess-wait subp) - (let ([twait (lambda (t) - (when (thread? t) - (thread-wait t)))]) - (twait so) - (twait si) - (twait se))) - ((interrupt) (subprocess-kill subp #f)) - ((kill) (subprocess-kill subp #t)) - (else - (raise-type-error 'control-process - "'status, 'exit-code, 'wait, 'interrupt, or 'kill" m)))))) - control)))))) +(define (process/ports out in err str) + (apply process*/ports out in err (shell-path/args 'process/ports str))) - (define (process/ports out in err str) - (apply process*/ports out in err (shell-path/args "process/ports" str))) +(define (process* exe . args) + (apply process*/ports #f #f #f exe args)) - (define (process* exe . args) - (apply process*/ports #f #f #f exe args)) +(define (process str) + (apply process* (shell-path/args 'process str))) - (define (process str) - (apply process* (shell-path/args "process" str))) +;; Note: these always use current ports +(define (system*/exit-code exe . args) + (let ([cout (current-output-port)] + [cin (current-input-port)] + [cerr (current-error-port)] + [it-ready (make-semaphore)]) + (let-values ([(subp out in err) + (apply subprocess + (if-stream-out cout) + (if-stream-in cin) + (if-stream-out cerr) + exe args)]) + (let ([ot (streamify-out cout out)] + [it (streamify-in cin in (lambda (ok?) + (if ok? + (semaphore-post it-ready) + (semaphore-wait it-ready))))] + [et (streamify-out cerr err)]) + (subprocess-wait subp) + (when it + ;; stop piping output to subprocess + (semaphore-wait it-ready) + (break-thread it)) + ;; wait for other pipes to run dry: + (when (thread? ot) (thread-wait ot)) + (when (thread? et) (thread-wait et)) + (when err (close-input-port err)) + (when out (close-input-port out)) + (when in (close-output-port in))) + (subprocess-status subp)))) - ;; Note: these always use current ports - (define (system*/exit-code exe . args) - (if (eq? (system-type) 'macos) - (if (null? args) - (raise-mismatch-error - 'system*/exit-code "command-line arguments not supported for MacOS" args) - (subprocess #f #f #f exe)) - (let ([cout (current-output-port)] - [cin (current-input-port)] - [cerr (current-error-port)] - [it-ready (make-semaphore)]) - (let-values ([(subp out in err) - (apply - subprocess - (if-stream-out cout) - (if-stream-in cin) - (if-stream-out cerr) - exe args)]) - (let ([ot (streamify-out cout out #t)] - [it (streamify-in cin in #t (lambda (ok?) - (if ok? - (semaphore-post it-ready) - (semaphore-wait it-ready))))] - [et (streamify-out cerr err #t)]) - (subprocess-wait subp) - (when it - ;; stop piping output to subprocess - (semaphore-wait it-ready) - (break-thread it)) - ;; wait for other pipes to run dry: - (when (thread? ot) - (thread-wait ot)) - (when (thread? et) - (thread-wait et)) - (when err - (close-input-port err)) - (when out - (close-input-port out)) - (when in - (close-output-port in))) - (subprocess-status subp))))) +(define (system* exe . args) + (zero? (apply system*/exit-code exe args))) - (define (system* exe . args) - (if (eq? (system-type) 'macos) - (if (null? args) - (raise-mismatch-error - 'system* "command-line arguments not supported for MacOS" args) - (subprocess #f #f #f exe)) - (zero? (apply system*/exit-code exe args)))) +(define (system str) + (apply system* (shell-path/args 'system str))) - (define (system str) - (if (eq? (system-type) 'macos) - (subprocess #f #f #f "by-id" str) - (apply system* (shell-path/args "system" str)))) - - (define (system/exit-code str) - (if (eq? (system-type) 'macos) - (subprocess #f #f #f "by-id" str) - (apply system*/exit-code (shell-path/args "system" str))))) +(define (system/exit-code str) + (apply system*/exit-code (shell-path/args 'system/exit-code str))) From 561af43eda7758380cbb63c4fb1a465b773df360 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Wed, 12 May 2010 12:43:45 -0400 Subject: [PATCH 06/21] Separate out hash/c code into a separate module. original commit: f5b62ececdef53f18bde3ab140351f10313f94a2 --- collects/mzlib/contract.rkt | 2 ++ 1 file changed, 2 insertions(+) diff --git a/collects/mzlib/contract.rkt b/collects/mzlib/contract.rkt index 462ff7c..e4101c8 100644 --- a/collects/mzlib/contract.rkt +++ b/collects/mzlib/contract.rkt @@ -30,6 +30,7 @@ ;; (require racket/contract/private/base + racket/contract/private/hash racket/contract/private/misc racket/contract/private/provide racket/contract/private/guts @@ -44,6 +45,7 @@ contract-struct) (all-from-out racket/contract/private/base) + (all-from-out racket/contract/private/hash) (all-from-out racket/contract/private/provide) (except-out (all-from-out racket/contract/private/misc) check-between/c From 71d6d2f101e6a2c752abbc94ba667edf4d88fe73 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 13 May 2010 14:20:39 -0400 Subject: [PATCH 07/21] Initially just move the box-related combinators to a new location. original commit: b8fb6dae9a54d89389ebf282f4f15011dbef36b0 --- collects/mzlib/contract.rkt | 2 ++ 1 file changed, 2 insertions(+) diff --git a/collects/mzlib/contract.rkt b/collects/mzlib/contract.rkt index e4101c8..187db73 100644 --- a/collects/mzlib/contract.rkt +++ b/collects/mzlib/contract.rkt @@ -30,6 +30,7 @@ ;; (require racket/contract/private/base + racket/contract/private/box racket/contract/private/hash racket/contract/private/misc racket/contract/private/provide @@ -45,6 +46,7 @@ contract-struct) (all-from-out racket/contract/private/base) + (all-from-out racket/contract/private/box) (all-from-out racket/contract/private/hash) (all-from-out racket/contract/private/provide) (except-out (all-from-out racket/contract/private/misc) From 7271481c49aef7caa933c441b766fdbfe9a0abc2 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 13 May 2010 15:43:52 -0400 Subject: [PATCH 08/21] Now change box/c to use proxies or chaperones appropriately. Create a mzlib/contract compatible version of the old box/c and use that for mzlib/contract. Change the docs so that the docs for mzlib/contract contain the right information. Fix the typed-scheme implementation to only force flat box (or hash) contracts when it already is required to be flat. Otherwise, allow non-flat contracts for the element contract (or domain/range contracts). original commit: 994ad6d10fc817a5ceca2f9f4874dac5c14c0aab --- collects/mzlib/contract.rkt | 11 ++++++---- collects/mzlib/private/contract-mutable.rkt | 24 +++++++++++++++++++++ 2 files changed, 31 insertions(+), 4 deletions(-) create mode 100644 collects/mzlib/private/contract-mutable.rkt diff --git a/collects/mzlib/contract.rkt b/collects/mzlib/contract.rkt index 187db73..1ced3d7 100644 --- a/collects/mzlib/contract.rkt +++ b/collects/mzlib/contract.rkt @@ -23,6 +23,13 @@ (require "private/contract-define.rkt") (provide (all-from-out "private/contract-define.rkt")) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; old-style flat mutable contracts +;; +(require "private/contract-mutable.rkt") +(provide (all-from-out "private/contract-mutable.rkt")) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; provide everything from the racket/ implementation @@ -30,8 +37,6 @@ ;; (require racket/contract/private/base - racket/contract/private/box - racket/contract/private/hash racket/contract/private/misc racket/contract/private/provide racket/contract/private/guts @@ -46,8 +51,6 @@ contract-struct) (all-from-out racket/contract/private/base) - (all-from-out racket/contract/private/box) - (all-from-out racket/contract/private/hash) (all-from-out racket/contract/private/provide) (except-out (all-from-out racket/contract/private/misc) check-between/c diff --git a/collects/mzlib/private/contract-mutable.rkt b/collects/mzlib/private/contract-mutable.rkt new file mode 100644 index 0000000..69f4617 --- /dev/null +++ b/collects/mzlib/private/contract-mutable.rkt @@ -0,0 +1,24 @@ +#lang racket/base + +(require (only-in racket/contract/private/box box-immutable/c) + racket/contract/private/blame + racket/contract/private/guts) + +(provide box/c box-immutable/c) + +(define/subexpression-pos-prop (box/c ctc) + (let ([ctc (coerce-flat-contract 'box/c ctc)]) + (make-flat-contract + #:name (build-compound-type-name 'box/c ctc) + #:first-order + (λ (val) + (and (box? val) + (contract-first-order-passes? ctc (unbox val)))) + #:projection + (λ (blame) + (λ (val) + (let ([proj ((contract-projection ctc) blame)]) + (unless (box? val) + (raise-blame-error blame val "not a box")) + (proj (unbox val)) + val)))))) From d41ec9e0511f220cea0f4ff31a08576e7fe610f8 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 14 May 2010 18:34:53 -0400 Subject: [PATCH 09/21] Separate out vector-related contract combinators into a new file. original commit: c8737d5615db678b93784794ec6f55109b9d46d5 --- collects/mzlib/contract.rkt | 2 ++ 1 file changed, 2 insertions(+) diff --git a/collects/mzlib/contract.rkt b/collects/mzlib/contract.rkt index 1ced3d7..68296b6 100644 --- a/collects/mzlib/contract.rkt +++ b/collects/mzlib/contract.rkt @@ -37,6 +37,7 @@ ;; (require racket/contract/private/base + racket/contract/private/vector racket/contract/private/misc racket/contract/private/provide racket/contract/private/guts @@ -51,6 +52,7 @@ contract-struct) (all-from-out racket/contract/private/base) + (all-from-out racket/contract/private/vector) (all-from-out racket/contract/private/provide) (except-out (all-from-out racket/contract/private/misc) check-between/c From a4087991e3ff1650b2c6d73c0f3d9b37f737a30a Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 17 May 2010 13:11:10 -0400 Subject: [PATCH 10/21] Convert vectorof/vector-immutableof to the new regime. Also add old-style vectorof to mzlib/contract. original commit: 3028f2d1424123d076a95572a7564b8fb069a86e --- collects/mzlib/contract.rkt | 2 -- collects/mzlib/private/contract-mutable.rkt | 24 ++++++++++++++++++++- 2 files changed, 23 insertions(+), 3 deletions(-) diff --git a/collects/mzlib/contract.rkt b/collects/mzlib/contract.rkt index 68296b6..1ced3d7 100644 --- a/collects/mzlib/contract.rkt +++ b/collects/mzlib/contract.rkt @@ -37,7 +37,6 @@ ;; (require racket/contract/private/base - racket/contract/private/vector racket/contract/private/misc racket/contract/private/provide racket/contract/private/guts @@ -52,7 +51,6 @@ contract-struct) (all-from-out racket/contract/private/base) - (all-from-out racket/contract/private/vector) (all-from-out racket/contract/private/provide) (except-out (all-from-out racket/contract/private/misc) check-between/c diff --git a/collects/mzlib/private/contract-mutable.rkt b/collects/mzlib/private/contract-mutable.rkt index 69f4617..0e09536 100644 --- a/collects/mzlib/private/contract-mutable.rkt +++ b/collects/mzlib/private/contract-mutable.rkt @@ -1,10 +1,13 @@ #lang racket/base (require (only-in racket/contract/private/box box-immutable/c) + (only-in racket/contract/private/vector + vector/c vector-immutableof vector-immutable/c) racket/contract/private/blame racket/contract/private/guts) -(provide box/c box-immutable/c) +(provide box/c box-immutable/c + vector/c vectorof vector-immutableof vector-immutable/c) (define/subexpression-pos-prop (box/c ctc) (let ([ctc (coerce-flat-contract 'box/c ctc)]) @@ -22,3 +25,22 @@ (raise-blame-error blame val "not a box")) (proj (unbox val)) val)))))) + +(define/subexpression-pos-prop (vectorof ctc) + (let ([ctc (coerce-flat-contract 'vectorof ctc)]) + (make-flat-contract + #:name (build-compound-type-name 'vectorof ctc) + #:first-order + (λ (val) + (and (vector? val) + (for/and ([v (in-vector val)]) + (contract-first-order-passes? ctc v)))) + #:projection + (λ (blame) + (λ (val) + (let ([proj ((contract-projection ctc) blame)]) + (unless (vector? val) + (raise-blame-error blame val "not a vector")) + (for ([v (in-vector val)]) + (proj v)) + val)))))) From f3f84db4947d2c87e8347dbf4d58126421d89372 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 17 May 2010 13:52:01 -0400 Subject: [PATCH 11/21] Now migrate vector/c and vector-immutable/c. Also add old-style vector/c to mzlib/contract. original commit: b416b7e5bbac1c75dba6611cc96d7f821d0ec4f2 --- collects/mzlib/private/contract-mutable.rkt | 29 ++++++++++++++++++++- 1 file changed, 28 insertions(+), 1 deletion(-) diff --git a/collects/mzlib/private/contract-mutable.rkt b/collects/mzlib/private/contract-mutable.rkt index 0e09536..4e884a4 100644 --- a/collects/mzlib/private/contract-mutable.rkt +++ b/collects/mzlib/private/contract-mutable.rkt @@ -2,7 +2,7 @@ (require (only-in racket/contract/private/box box-immutable/c) (only-in racket/contract/private/vector - vector/c vector-immutableof vector-immutable/c) + vector-immutableof vector-immutable/c) racket/contract/private/blame racket/contract/private/guts) @@ -44,3 +44,30 @@ (for ([v (in-vector val)]) (proj v)) val)))))) + +(define/subexpression-pos-prop (vector/c . ctcs) + (let ([ctcs (for/list ([ctc (in-list ctcs)]) + (coerce-flat-contract 'vector/c ctc))]) + (make-flat-contract + #:name (apply build-compound-type-name 'vector/c ctcs) + #:first-order + (λ (val) + (and (vector? val) + (= (vector-length val) (length ctcs)) + (for/and ([v (in-vector val)] + [c (in-list ctcs)]) + (contract-first-order-passes? c v)))) + #:projection + (λ (blame) + (λ (val) + (let ([projs (for/list ([ctc (in-list ctcs)]) + ((contract-projection ctc) blame))]) + (unless (vector? val) + (raise-blame-error blame val "not a vector")) + (unless (= (vector-length val) (length ctcs)) + (raise-blame-error blame val "expected vector of length ~a, got length ~a" + (length ctcs) (vector-length val))) + (for ([v (in-vector val)] + [p (in-list projs)]) + (p v)) + val)))))) From 0ddfa81da3423d03b56c1a784d3b00be02fae14e Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 11 Jun 2010 17:28:59 -0400 Subject: [PATCH 12/21] Convert unconstrained-domain-> to chaperones. original commit: 05e714881d95f2347bd71899acc20f95d726e7cc --- collects/mzlib/private/contract-arrow.rkt | 41 ++++++++++++++--------- 1 file changed, 26 insertions(+), 15 deletions(-) diff --git a/collects/mzlib/private/contract-arrow.rkt b/collects/mzlib/private/contract-arrow.rkt index 74af99a..dd62436 100644 --- a/collects/mzlib/private/contract-arrow.rkt +++ b/collects/mzlib/private/contract-arrow.rkt @@ -35,22 +35,33 @@ [(res-x ...) (generate-temporaries #'(rngs ...))]) #'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...) (let ([proj-x (contract-projection rngs-x)] ...) - (define ctc - (make-contract - #:name - (build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...) - #:projection - (λ (blame) - (let ([p-app-x (proj-x blame)] ...) - (λ (val) - (if (procedure? val) - (make-contracted-function + (define name + (build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...)) + (define (proj wrapper) + (λ (blame) + (let* ([p-app-x (proj-x blame)] ... + [res-checker (λ (res-x ...) (values (p-app-x res-x) ...))]) + (λ (val) + (if (procedure? val) + (wrapper + val + (make-keyword-procedure + (λ (kwds kwd-vals . args) + (apply values res-checker kwd-vals args)) (λ args - (let-values ([(res-x ...) (apply val args)]) - (values (p-app-x res-x) ...))) - ctc) - (raise-blame-error blame val "expected a procedure"))))) - #:first-order procedure?)) + (apply values res-checker args))) + proxy-prop:contracted ctc) + (raise-blame-error blame val "expected a procedure")))))) + (define ctc + (if (and (chaperone-contract? rngs-x) ...) + (make-chaperone-contract + #:name name + #:projection (proj chaperone-procedure) + #:first-order procedure?) + (make-contract + #:name name + #:projection (proj proxy-procedure) + #:first-order procedure?))) ctc)))])) (define (build--> name doms doms-rest rngs kwds quoted-kwds rng-any? func) From 27f087f38fd020d99bcb0716c0ab1b9018070cc9 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 18 Sep 2010 03:55:30 -0400 Subject: [PATCH 13/21] Some repeated "and and"s and "the the"s, and two more typos. Closes PR 11229. original commit: ee138cf2cba3ee32cd755a7b242ec10051180adf --- collects/mzlib/private/contract-arr-checks.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mzlib/private/contract-arr-checks.rkt b/collects/mzlib/private/contract-arr-checks.rkt index 9bbb341..19c887a 100644 --- a/collects/mzlib/private/contract-arr-checks.rkt +++ b/collects/mzlib/private/contract-arr-checks.rkt @@ -161,7 +161,7 @@ (raise-blame-error blame val - "expected a procedure that accepts ~a arguments and and arbitrarily more~a, given: ~e" + "expected a procedure that accepts ~a arguments and arbitrarily more~a, given: ~e" dom-length (keyword-error-text mandatory-kwds) val))) From cb9880c410699b5e50c49521b7cba28833d0591e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 22 Oct 2010 19:01:27 -0600 Subject: [PATCH 14/21] improve runtime-path support for building stand-alone gui exes original commit: 75a6bfe119d97ef81a28626bebe2b33799d41c06 --- collects/mzlib/runtime-path.rkt | 88 ++++++++++++++++++--------------- 1 file changed, 49 insertions(+), 39 deletions(-) diff --git a/collects/mzlib/runtime-path.rkt b/collects/mzlib/runtime-path.rkt index a8c2891..2be5f33 100644 --- a/collects/mzlib/runtime-path.rkt +++ b/collects/mzlib/runtime-path.rkt @@ -11,24 +11,23 @@ (provide define-runtime-path define-runtime-paths define-runtime-path-list + define-runtime-module-path runtime-paths) (define-for-syntax ext-file-table (make-hasheq)) - (define (lookup-in-table tag-stx p) + (define (lookup-in-table var-ref p) ;; This function is designed to cooperate with a table embedded ;; in an executable by create-embedding-executable. - (let ([mpi (syntax-source-module tag-stx)]) + (let ([modname (variable-reference->resolved-module-path var-ref)]) (let ([p (hash-ref table - (cons (cond - [(module-path-index? mpi) - (resolved-module-path-name (module-path-index-resolve mpi))] - [(symbol? mpi) mpi] - [else #f]) + (cons (resolved-module-path-name modname) (if (path? p) (path->bytes p) - p)) + (if (and (pair? p) (eq? 'module (car p))) + (list 'module (cadr p)) + p))) #f)]) (and p (car p) @@ -36,11 +35,13 @@ [p (if (bytes? p) (bytes->path p) p)]) - (if (absolute-path? p) - p - (parameterize ([current-directory (find-system-path 'orig-dir)]) - (or (find-executable-path (find-system-path 'exec-file) p #t) - (build-path (current-directory) p))))))))) + (if (symbol? p) + (module-path-index-join (list 'quote p) #f) ; make it a module path index + (if (absolute-path? p) + p + (parameterize ([current-directory (find-system-path 'orig-dir)]) + (or (find-executable-path (find-system-path 'exec-file) p #t) + (build-path (current-directory) p)))))))))) (define (resolve-paths tag-stx get-base paths) (let ([base #f]) @@ -85,18 +86,24 @@ (null? (cdr strs))) (list "mzlib") (append (cddr p) (drop-right strs 1)))))] + [(and (list? p) + ((length p) . = . 3) + (eq? 'module (car p)) + (or (not (caddr p)) + (variable-reference? (caddr p)))) + (let ([p (cadr p)] + [vr (caddr p)]) + (unless (module-path? p) + (error 'runtime-path "not a module path: ~.s" p)) + (module-path-index-join p (and vr + (variable-reference->resolved-module-path vr))))] [else (error 'runtime-path "unknown form: ~.s" p)]))) paths))) - (define-for-syntax (register-ext-files tag-stx paths) - (let ([mpi (syntax-source-module tag-stx)]) - (let ([modname (cond - [(module-path-index? mpi) (module-path-index-resolve mpi)] - [(symbol? mpi) mpi] - [else (error 'register-ext-files - "cannot determine source")])]) - (let ([files (hash-ref ext-file-table modname null)]) - (hash-set! ext-file-table modname (append paths files)))))) + (define-for-syntax (register-ext-files var-ref paths) + (let ([modname (variable-reference->resolved-module-path var-ref)]) + (let ([files (hash-ref ext-file-table modname null)]) + (hash-set! ext-file-table modname (append paths files))))) (define-syntax (-define-runtime-path stx) (syntax-case stx () @@ -111,23 +118,22 @@ #'orig-stx id))) ids) - (let ([tag (datum->syntax #'orig-stx 'tag #'orig-stx)]) - #`(begin - (define-values (id ...) - (let-values ([(id ...) expr]) - (let ([get-dir (lambda () - #,(datum->syntax - tag - `(,#'this-expression-source-directory) - tag))]) - (apply to-values (resolve-paths (quote-syntax #,tag) - get-dir - (to-list id ...)))))) - (begin-for-syntax - (register-ext-files - (quote-syntax #,tag) - (let-values ([(id ...) expr]) - (to-list id ...)))))))])) + #`(begin + (define-values (id ...) + (let-values ([(id ...) expr]) + (let ([get-dir (lambda () + #,(datum->syntax + #'orig-stx + `(,#'this-expression-source-directory) + #'orig-stx))]) + (apply to-values (resolve-paths (#%variable-reference) + get-dir + (to-list id ...)))))) + (begin-for-syntax + (register-ext-files + (#%variable-reference) + (let-values ([(id ...) expr]) + (to-list id ...))))))])) (define-syntax (define-runtime-path stx) (syntax-case stx () @@ -141,6 +147,10 @@ (syntax-case stx () [(_ id expr) #`(-define-runtime-path #,stx (id) expr values list)])) + (define-syntax (define-runtime-module-path stx) + (syntax-case stx () + [(_ id expr) #`(-define-runtime-path #,stx (id) `(module ,expr ,(#%variable-reference)) list values)])) + (define-syntax (runtime-paths stx) (syntax-case stx () [(_ mp) From ea1269a0c267cf2c81d78f58e1cae7f8511d1c8f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 24 Oct 2010 14:39:13 -0600 Subject: [PATCH 15/21] define-runtime-module-path-index and racket/gui/dynamic fixes original commit: dee93e625984f3f92cb699a4e131eb34aee94874 --- collects/mzlib/runtime-path.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/mzlib/runtime-path.rkt b/collects/mzlib/runtime-path.rkt index 2be5f33..2c96054 100644 --- a/collects/mzlib/runtime-path.rkt +++ b/collects/mzlib/runtime-path.rkt @@ -11,7 +11,7 @@ (provide define-runtime-path define-runtime-paths define-runtime-path-list - define-runtime-module-path + define-runtime-module-path-index runtime-paths) (define-for-syntax ext-file-table (make-hasheq)) @@ -147,7 +147,7 @@ (syntax-case stx () [(_ id expr) #`(-define-runtime-path #,stx (id) expr values list)])) - (define-syntax (define-runtime-module-path stx) + (define-syntax (define-runtime-module-path-index stx) (syntax-case stx () [(_ id expr) #`(-define-runtime-path #,stx (id) `(module ,expr ,(#%variable-reference)) list values)])) From f5c7a9f7a54e67e31970f7e9283dff8c115db3f2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 8 Nov 2010 06:23:16 -0700 Subject: [PATCH 16/21] v5.0.99.2: `proxy' -> `impersonator' original commit: 7f67b6569c780f554bfeb8b9641ec59005c775c4 --- collects/mzlib/private/contract-arrow.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/mzlib/private/contract-arrow.rkt b/collects/mzlib/private/contract-arrow.rkt index dd62436..34f4d26 100644 --- a/collects/mzlib/private/contract-arrow.rkt +++ b/collects/mzlib/private/contract-arrow.rkt @@ -50,7 +50,7 @@ (apply values res-checker kwd-vals args)) (λ args (apply values res-checker args))) - proxy-prop:contracted ctc) + impersonator-prop:contracted ctc) (raise-blame-error blame val "expected a procedure")))))) (define ctc (if (and (chaperone-contract? rngs-x) ...) @@ -60,7 +60,7 @@ #:first-order procedure?) (make-contract #:name name - #:projection (proj proxy-procedure) + #:projection (proj impersonate-procedure) #:first-order procedure?))) ctc)))])) From 866da10d6ec409744167e179609756d22ede213c Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 19 Nov 2010 17:10:55 -0500 Subject: [PATCH 17/21] Improved `get-bindings' using regexps etc. (But note that it looks like it reimplements `form-urlencoded->alist'.) original commit: 76c07dd594160bd37b49aff654055aa28ed2fe93 --- collects/net/cgi-unit.rkt | 102 ++++++++++++++++---------------------- 1 file changed, 42 insertions(+), 60 deletions(-) diff --git a/collects/net/cgi-unit.rkt b/collects/net/cgi-unit.rkt index 24a1ba3..00c916e 100644 --- a/collects/net/cgi-unit.rkt +++ b/collects/net/cgi-unit.rkt @@ -24,16 +24,15 @@ ;; -------------------------------------------------------------------- -;; query-chars->string : list (char) -> string +;; query-string->string : string -> string -;; -- The input is the characters post-processed as per Web specs, which +;; -- The input is the string post-processed as per Web specs, which ;; is as follows: ;; spaces are turned into "+"es and lots of things are turned into %XX, where ;; XX are hex digits, eg, %E7 for ~. The output is a regular Scheme string ;; with all the characters converted back. -(define (query-chars->string chars) - (form-urlencoded-decode (list->string chars))) +(define query-string->string form-urlencoded-decode) ;; string->html : string -> string ;; -- the input is raw text, the output is HTML appropriately quoted @@ -92,70 +91,53 @@ (define (output-http-headers) (printf "Content-type: text/html\r\n\r\n")) -;; read-until-char : iport x char -> list (char) x bool -;; -- operates on the default input port; the second value indicates whether -;; reading stopped because an EOF was hit (as opposed to the delimiter being -;; seen); the delimiter is not part of the result -(define (read-until-char ip delimiter?) - (let loop ([chars '()]) - (let ([c (read-char ip)]) - (cond [(eof-object? c) (values (reverse chars) #t)] - [(delimiter? c) (values (reverse chars) #f)] - [else (loop (cons c chars))])))) - -;; delimiter->predicate : -;; symbol -> (char -> bool) -;; returns a predicates to pass to read-until-char -(define (delimiter->predicate delimiter) +;; delimiter->predicate : symbol -> regexp +;; returns a regexp to read a chunk of text up to a delimiter (excluding it) +(define (delimiter->rx delimiter) (case delimiter - [(eq) (lambda (c) (char=? c #\=))] - [(amp) (lambda (c) (char=? c #\&))] - [(semi) (lambda (c) (char=? c #\;))] - [(amp-or-semi) (lambda (c) (or (char=? c #\&) (char=? c #\;)))])) + [(amp) #rx#"^[^&]*"] + [(semi) #rx#"^[^;]*"] + [(amp-or-semi) #rx#"^[^&;]*"] + [else (error 'delimiter->rx + "internal-error, unknown delimiter: ~e" delimiter)])) -;; read-name+value : iport -> (symbol + bool) x (string + bool) x bool -;; -- If the first value is false, so is the second, and the third is true, -;; indicating EOF was reached without any input seen. Otherwise, the first -;; and second values contain strings and the third is either true or false -;; depending on whether the EOF has been reached. The strings are processed -;; to remove the CGI spec "escape"s. This code is _slightly_ lax: it allows -;; an input to end in (current-alist-separator-mode). -;; It's not clear this is legal by the CGI spec, -;; which suggests that the last value binding must end in an EOF. It doesn't -;; look like this matters. It would also introduce needless modality and -;; reduce flexibility. -(define (read-name+value ip) - (let-values ([(name eof?) (read-until-char ip (delimiter->predicate 'eq))]) - (cond [(and eof? (null? name)) (values #f #f #t)] - [eof? - (generate-error-output - (list "Server generated malformed input for POST method:" - (string-append - "No binding for `" (list->string name) "' field.")))] - [else (let-values ([(value eof?) - (read-until-char - ip - (delimiter->predicate - (current-alist-separator-mode)))]) - (values (string->symbol (query-chars->string name)) - (query-chars->string value) - eof?))]))) +;; get-bindings* : iport -> (listof (cons symbol string)) +;; Reads all bindings from the input port. The strings are processed to +;; remove the CGI spec "escape"s. +;; This code is _slightly_ lax: it allows an input to end in +;; (current-alist-separator-mode). It's not clear this is legal by the +;; CGI spec, which suggests that the last value binding must end in an +;; EOF. It doesn't look like this matters. +;; ELI: * Keeping this behavior for now, maybe better to remove it? +;; * Looks like `form-urlencoded->alist' is doing almost exactly +;; the same job this code does. +(define (get-bindings* method ip) + (define (err fmt . xs) + (generate-error-output + (list (format "Server generated malformed input for ~a method:" method) + (apply format fmt xs)))) + (define value-rx (delimiter->rx (current-alist-separator-mode))) + (define (process str) (query-string->string (bytes->string/utf-8 str))) + (let loop ([bindings '()]) + (if (eof-object? (peek-char ip)) + (reverse bindings) + (let () + (define name (car (or (regexp-match #rx"^[^=]+" ip) + (err "Missing field name before `='")))) + (unless (eq? #\= (read-char ip)) + (err "No binding for `~a' field." name)) + (define value (car (regexp-match value-rx ip))) + (read-char ip) ; consume the delimiter, possibly eof (retested above) + (loop (cons (cons (string->symbol (process name)) (process value)) + bindings)))))) ;; get-bindings/post : () -> bindings (define (get-bindings/post) - (let-values ([(name value eof?) (read-name+value (current-input-port))]) - (cond [(and eof? (not name)) null] - [(and eof? name) (list (cons name value))] - [else (cons (cons name value) (get-bindings/post))]))) + (get-bindings* "POST" (current-input-port))) ;; get-bindings/get : () -> bindings (define (get-bindings/get) - (let ([p (open-input-string (getenv "QUERY_STRING"))]) - (let loop () - (let-values ([(name value eof?) (read-name+value p)]) - (cond [(and eof? (not name)) null] - [(and eof? name) (list (cons name value))] - [else (cons (cons name value) (loop))]))))) + (get-bindings* "GET" (open-input-string (getenv "QUERY_STRING")))) ;; get-bindings : () -> bindings (define (get-bindings) From d0a35ce51a981bae2eac0caeceb2a06768c921f5 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 15 Nov 2010 16:06:43 -0500 Subject: [PATCH 18/21] Conversion of object/c and object-contract to use impersonators. original commit: 2bd7760412ec9c8e4af8936193cb3a6cb95518b0 --- collects/mzlib/private/contract-object.rkt | 28 ++++++++++++---------- 1 file changed, 15 insertions(+), 13 deletions(-) diff --git a/collects/mzlib/private/contract-object.rkt b/collects/mzlib/private/contract-object.rkt index d877bac..8daded9 100644 --- a/collects/mzlib/private/contract-object.rkt +++ b/collects/mzlib/private/contract-object.rkt @@ -281,20 +281,22 @@ ... [field-ctc-var (coerce-contract 'object-contract field-ctc-stx)] ...) - (make-contract - #:name - `(object-contract - ,(build-compound-type-name 'method-name method-ctc-var) ... - ,(build-compound-type-name 'field 'field-name field-ctc-var) ...) - #:projection - (lambda (blame) + (define ctc + (make-contract + #:name + `(object-contract + ,(build-compound-type-name 'method-name method-ctc-var) ... + ,(build-compound-type-name 'field 'field-name field-ctc-var) ...) + #:projection + (lambda (blame) + (lambda (val) + (make-wrapper-object ctc val blame + (list 'method-name ...) (list method-ctc-var ...) + (list 'field-name ...) (list field-ctc-var ...)))) + #:first-order (lambda (val) - (make-wrapper-object val blame - (list 'method-name ...) (list method-ctc-var ...) - (list 'field-name ...) (list field-ctc-var ...)))) - #:first-order - (lambda (val) - (check-object-contract val #f (list 'method-name ...) (list 'field-name ...))))))))])))) + (check-object-contract val #f (list 'method-name ...) (list 'field-name ...)))) + ctc)))))])))) (define (check-object val blame) From 615c94f72f70ac4346f3f1cb5f67089943fb0b48 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 16 Nov 2010 19:12:22 -0500 Subject: [PATCH 19/21] Clean up first-order checking in object/c and object-contract. Use let/ec only when needed (i.e. when raise-blame-error is not used). Also remove some of the old checking functions from mzlib's object-contract code that are no longer needed now that we have unified the first-order checking. original commit: 96db670d8c5453173b9bf92375512fc57cafbfcd --- collects/mzlib/private/contract-object.rkt | 17 ++++------------- 1 file changed, 4 insertions(+), 13 deletions(-) diff --git a/collects/mzlib/private/contract-object.rkt b/collects/mzlib/private/contract-object.rkt index 8daded9..0188cb4 100644 --- a/collects/mzlib/private/contract-object.rkt +++ b/collects/mzlib/private/contract-object.rkt @@ -295,21 +295,12 @@ (list 'field-name ...) (list field-ctc-var ...)))) #:first-order (lambda (val) - (check-object-contract val #f (list 'method-name ...) (list 'field-name ...)))) - ctc)))))])))) + (let/ec ret + (check-object-contract val (list 'method-name ...) (list 'field-name ...) + (λ args (ret #f))))))) + ctc))))])))) -(define (check-object val blame) - (unless (object? val) - (raise-blame-error blame val "expected an object, got ~e" val))) - -(define (check-method val method-name val-mtd-names blame) - (unless (memq method-name val-mtd-names) - (raise-blame-error blame val "expected an object with method ~s" method-name))) - -(define (field-error val field-name blame) - (raise-blame-error blame val "expected an object with field ~s" field-name)) - (define (make-mixin-contract . %/<%>s) ((and/c (flat-contract class?) (apply and/c (map sub/impl?/c %/<%>s))) From d860b1a18aa51a2ddd279c1843d300a79542b52f Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 16 Nov 2010 22:01:38 -0500 Subject: [PATCH 20/21] =?UTF-8?q?Fix=20object=3D=3F.?= Also commented out some tests of reflective operations on contracted objects. I've added a note that describes how we might be able to fix this, if we decide it's worth doing. original commit: 30afcd3bf5cc272f1642449989628024bedc41eb --- collects/tests/racket/contract-mzlib-test.rktl | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/collects/tests/racket/contract-mzlib-test.rktl b/collects/tests/racket/contract-mzlib-test.rktl index 28df566..b18aa0d 100644 --- a/collects/tests/racket/contract-mzlib-test.rktl +++ b/collects/tests/racket/contract-mzlib-test.rktl @@ -2760,6 +2760,10 @@ of the contract library does not change over time. (test #t (contract-eval 'is-a?) (contract-eval `(contract (object-contract) ,o 'pos 'neg)) i<%>) (test #t (contract-eval 'is-a?) (contract-eval `(contract (object-contract) ,o 'pos 'neg)) c%)) + ;; Currently the new object contracts using impersonators don't even attempt to ensure that + ;; these reflective operations still work, and I'm not even sure they should. For now, I'll + ;; just comment them out so that we can revive them if we decide that they should work. + #| (let ([c% (parameterize ([current-inspector (make-inspector)]) (contract-eval '(class object% (super-new))))]) (test (list c% #f) @@ -2781,6 +2785,7 @@ of the contract library does not change over time. ,obj 'pos 'neg)))) +|# ; ; From de3c2dcc8a5e45013a48751600d7199d21fee357 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 2 Dec 2010 13:02:59 -0500 Subject: [PATCH 21/21] Actually turn on old object-info hack mentioned in 4e451a1. original commit: 778f0c9fc4af1c36c378e3e7bbedeb47b27feeb7 --- collects/tests/racket/contract-mzlib-test.rktl | 5 ----- 1 file changed, 5 deletions(-) diff --git a/collects/tests/racket/contract-mzlib-test.rktl b/collects/tests/racket/contract-mzlib-test.rktl index b18aa0d..28df566 100644 --- a/collects/tests/racket/contract-mzlib-test.rktl +++ b/collects/tests/racket/contract-mzlib-test.rktl @@ -2760,10 +2760,6 @@ of the contract library does not change over time. (test #t (contract-eval 'is-a?) (contract-eval `(contract (object-contract) ,o 'pos 'neg)) i<%>) (test #t (contract-eval 'is-a?) (contract-eval `(contract (object-contract) ,o 'pos 'neg)) c%)) - ;; Currently the new object contracts using impersonators don't even attempt to ensure that - ;; these reflective operations still work, and I'm not even sure they should. For now, I'll - ;; just comment them out so that we can revive them if we decide that they should work. - #| (let ([c% (parameterize ([current-inspector (make-inspector)]) (contract-eval '(class object% (super-new))))]) (test (list c% #f) @@ -2785,7 +2781,6 @@ of the contract library does not change over time. ,obj 'pos 'neg)))) -|# ; ;