diff --git a/collects/mzlib/contract.rkt b/collects/mzlib/contract.rkt index e9a8146..01f022f 100644 --- a/collects/mzlib/contract.rkt +++ b/collects/mzlib/contract.rkt @@ -23,6 +23,20 @@ (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")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; old-style flat struct contracts +;; +(require "private/contract-struct.rkt") +(provide (all-from-out "private/contract-struct.rkt")) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; provide everything from the racket/ implementation @@ -40,7 +54,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) 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/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/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/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/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))) diff --git a/collects/mzlib/private/contract-arrow.rkt b/collects/mzlib/private/contract-arrow.rkt index 74af99a..34f4d26 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))) + impersonator-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 impersonate-procedure) + #:first-order procedure?))) ctc)))])) (define (build--> name doms doms-rest rngs kwds quoted-kwds rng-any? func) diff --git a/collects/mzlib/private/contract-mutable.rkt b/collects/mzlib/private/contract-mutable.rkt new file mode 100644 index 0000000..4e884a4 --- /dev/null +++ b/collects/mzlib/private/contract-mutable.rkt @@ -0,0 +1,73 @@ +#lang racket/base + +(require (only-in racket/contract/private/box box-immutable/c) + (only-in racket/contract/private/vector + vector-immutableof vector-immutable/c) + racket/contract/private/blame + racket/contract/private/guts) + +(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)]) + (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)))))) + +(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)))))) + +(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)))))) diff --git a/collects/mzlib/private/contract-object.rkt b/collects/mzlib/private/contract-object.rkt index d877bac..0188cb4 100644 --- a/collects/mzlib/private/contract-object.rkt +++ b/collects/mzlib/private/contract-object.rkt @@ -281,33 +281,26 @@ ... [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 ...))))))))])))) + (let/ec ret + (check-object-contract val (list 'method-name ...) (list 'field-name ...) + (λ args (ret #f))))))) + ctc))))])))) -(define (check-object val blame) - (unless (object? val) - (raise-blame-error blame val "expected an object, got ~e" val))) - -(define (check-method val method-name val-mtd-names blame) - (unless (memq method-name val-mtd-names) - (raise-blame-error blame val "expected an object with method ~s" method-name))) - -(define (field-error val field-name blame) - (raise-blame-error blame val "expected an object with field ~s" field-name)) - (define (make-mixin-contract . %/<%>s) ((and/c (flat-contract class?) (apply and/c (map sub/impl?/c %/<%>s))) diff --git a/collects/mzlib/private/contract-struct.rkt b/collects/mzlib/private/contract-struct.rkt new file mode 100644 index 0000000..733a148 --- /dev/null +++ b/collects/mzlib/private/contract-struct.rkt @@ -0,0 +1,75 @@ +#lang racket/base + +(require (for-syntax racket/base + racket/contract/private/helpers + racket/struct-info) + racket/contract/private/guts) + +(provide struct/c) + + #| + as with copy-struct in struct.rkt, this first begin0 + expansion "declares" that struct/c is an expression. + It prevents further expansion until the internal definition + context is sorted out. + |# +(define-syntax (struct/c stx) + (syntax-case stx () + [(_ . args) + (with-syntax ([x (syntax/loc stx (do-struct/c . args))]) + (syntax/loc stx (begin0 x)))])) + +(define-syntax (do-struct/c stx) + (syntax-case stx () + [(_ struct-name args ...) + (and (identifier? (syntax struct-name)) + (struct-info? (syntax-local-value (syntax struct-name) (λ () #f)))) + (with-syntax ([(ctc-x ...) (generate-temporaries (syntax (args ...)))] + [(ctc-name-x ...) (generate-temporaries (syntax (args ...)))] + [(ctc-pred-x ...) (generate-temporaries (syntax (args ...)))] + [(ctc-app-x ...) (generate-temporaries (syntax (args ...)))] + [(field-numbers ...) + (let loop ([i 0] + [l (syntax->list (syntax (args ...)))]) + (cond + [(null? l) '()] + [else (cons i (loop (+ i 1) (cdr l)))]))] + [(type-desc-id + constructor-id + predicate-id + (rev-selector-id ...) + (mutator-id ...) + super-id) + (lookup-struct-info (syntax struct-name) stx)]) + (unless (= (length (syntax->list (syntax (rev-selector-id ...)))) + (length (syntax->list (syntax (args ...))))) + (raise-syntax-error 'struct/c + (format "expected ~a contracts because struct ~a has ~a fields" + (length (syntax->list (syntax (rev-selector-id ...)))) + (syntax-e #'struct-name) + (length (syntax->list (syntax (rev-selector-id ...))))) + stx)) + (with-syntax ([(selector-id ...) (reverse (syntax->list (syntax (rev-selector-id ...))))]) + (syntax + (let ([ctc-x (coerce-contract 'struct/c args)] ...) + + (unless predicate-id + (error 'struct/c "could not determine predicate for ~s" 'struct-name)) + (unless (and selector-id ...) + (error 'struct/c "could not determine selectors for ~s" 'struct-name)) + + (unless (flat-contract? ctc-x) + (error 'struct/c "expected flat contracts as arguments, got ~e" args)) + ... + + (let ([ctc-pred-x (flat-contract-predicate ctc-x)] + ... + [ctc-name-x (contract-name ctc-x)] + ...) + (build-flat-contract + (build-compound-type-name 'struct/c 'struct-name ctc-x ...) + (λ (val) + (and (predicate-id val) + (ctc-pred-x (selector-id val)) ...))))))))] + [(_ struct-name anything ...) + (raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))])) \ No newline at end of file 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))) diff --git a/collects/mzlib/runtime-path.rkt b/collects/mzlib/runtime-path.rkt index 82b87f4..2c96054 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-index 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]) @@ -78,24 +79,31 @@ (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)))] - [else (error 'runtime-path "unknown form: ~e" p)]))) + (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)))))] + [(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 () @@ -110,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 () @@ -140,6 +147,10 @@ (syntax-case stx () [(_ id expr) #`(-define-runtime-path #,stx (id) expr values list)])) + (define-syntax (define-runtime-module-path-index 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) 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/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 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) diff --git a/collects/tests/racket/contract-mzlib-test.rktl b/collects/tests/racket/contract-mzlib-test.rktl index 011562f..365b327 100644 --- a/collects/tests/racket/contract-mzlib-test.rktl +++ b/collects/tests/racket/contract-mzlib-test.rktl @@ -78,9 +78,12 @@ of the contract library does not change over time. (define (test/spec-failed name expression blame) (let () (define (has-proper-blame? msg) - (regexp-match? - (string-append "(^| )" (regexp-quote blame) " broke") - msg)) + (define reg + (case blame + [(pos) #rx"^self-contract violation"] + [(neg) #rx"blaming neg"] + [else (error 'test/spec-failed "unknown blame name ~s" blame)])) + (regexp-match? reg msg)) (printf "testing: ~s\n" name) (contract-eval `(,thunk-error-test @@ -1546,8 +1549,8 @@ of the contract library does not change over time. 'pos 'neg) 1) - x) - (reverse '(1 3 4 2))) + (reverse x)) + '(3 1 2 4)) (test/neg-blame 'parameter/c1 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)