suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

new attempt at contract violation error messages

Browse Source 
original commit: bb9bd1b07a29fd8773f7891e0923c89db20a5397
This commit is contained in:
Robby Findler 2010-12-22 10:29:15 -06:00
commit 709cffad7a
20 changed files with 501 additions and 382 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
collects/mzlib/contract.rkt
View File

@ -23,6 +23,20 @@
(require "private/contract-define.rkt") (require "private/contract-define.rkt")
(provide (all-from-out "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 ;; provide everything from the racket/ implementation
@ -40,7 +54,8 @@
(provide (provide
opt/c define-opt/c ;(all-from "private/contract-opt.rkt") opt/c define-opt/c ;(all-from "private/contract-opt.rkt")
(except-out (all-from-out racket/contract/private/ds) (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/base)
(all-from-out racket/contract/private/provide) (all-from-out racket/contract/private/provide)

4
collects/mzlib/date.rkt
View File

@ -289,7 +289,7 @@
(if (<= input test) (if (<= input test)
'input-smaller 'input-smaller
'test-smaller)))]))]) 'test-smaller)))]))])
; (printf "~a ~a ~a~n" compare secs (date->string date)) ; (printf "~a ~a ~a\n" compare secs (date->string date))
(cond (cond
[(eq? compare 'equal) secs] [(eq? compare 'equal) secs]
[(or (= secs below-secs) (= secs above-secs)) [(or (= secs below-secs) (= secs above-secs))
@ -362,4 +362,4 @@
(caddr reversed-digits) (caddr reversed-digits)
(cadr reversed-digits) (cadr reversed-digits)
(car reversed-digits))) (car reversed-digits)))
(loop (cdr (cdr (cdr reversed-digits)))))))))))) (loop (cdr (cdr (cdr reversed-digits))))))))))))

8
collects/mzlib/file.rkt
View File

@ -39,13 +39,7 @@
(apply build-path p args))) (apply build-path p args)))
(define (find-library name . cp) (define (find-library name . cp)
(let ([dir (with-handlers ([exn:fail:filesystem? (lambda (exn) #f)]) (apply collection-file-path name cp))
(if (null? cp)
(collection-path "mzlib")
(apply collection-path cp)))])
(and dir
(let ([file (build-path dir name)])
(and (file-exists? file) file)))))
(define (-call-with-input-file* file thunk . flags) (define (-call-with-input-file* file thunk . flags)
(let ([p (apply mz:open-input-file file flags)]) (let ([p (apply mz:open-input-file file flags)])

9
collects/mzlib/include.rkt
View File

@ -38,10 +38,11 @@
"`lib' keyword is not followed by a sequence of string datums" "`lib' keyword is not followed by a sequence of string datums"
stx stx
fn)) fn))
(build-path (if (null? (cdr l)) (apply collection-file-path
(collection-path "mzlib") (car l)
(apply collection-path (cdr l))) (if (null? (cdr l))
(car l)))] (list "mzlib")
(cdr l))))]
[else [else
(raise-syntax-error (raise-syntax-error
#f #f

2
collects/mzlib/integer-set.rkt
View File

@ -8,7 +8,7 @@
(let* defs (let* defs
(let ((real-ans code)) (let ((real-ans code))
(unless (equal? real-ans right-ans) (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))) ...)))) 'code real-ans 'right-ans))) ...))))
(define-syntax test-block (define-syntax test-block

12
collects/mzlib/kw.rkt
View File

@ -331,7 +331,7 @@
#`((if (and in-seen? in-keys?) #`((if (and in-seen? in-keys?)
#,(if allow-duplicate-keys? #,(if allow-duplicate-keys?
#`seen-keys #`seen-keys
#`(error* 'name "duplicate keyword: ~e" #`(error* 'name "duplicate keyword: ~.s"
(car body*))) (car body*)))
(cons (car body*) seen-keys))) (cons (car body*) seen-keys)))
'()))]) '()))])
@ -343,12 +343,12 @@
nl nl
#`(if in-keys? #`(if in-keys?
#,nl #,nl
(error* 'name "unknown keyword: ~e" (error* 'name "unknown keyword: ~.s"
(car body*)))))] (car body*)))))]
[(not allow-other-keys?) [(not allow-other-keys?)
#`(if (memq (car body*) 'keywords) #`(if (memq (car body*) 'keywords)
#,nl #,nl
(error* 'name "unknown keyword: ~e" (error* 'name "unknown keyword: ~.s"
(car body*)))] (car body*)))]
[else nl]))] [else nl]))]
[expr [expr
@ -381,7 +381,7 @@
#'next-loop #'next-loop
#'(if (pair? (cdr body*)) #'(if (pair? (cdr body*))
next-loop next-loop
(error* 'name "keyword list not balanced: ~e" rest*))) (error* 'name "keyword list not balanced: ~.s" rest*)))
#,(if allow-body? #,(if allow-body?
(if (and body (not (identifier? body))) (if (and body (not (identifier? body)))
(with-syntax ([name (string->symbol (with-syntax ([name (string->symbol
@ -395,7 +395,7 @@
#'expr) #'expr)
#'(if (null? body*) #'(if (null? body*)
expr expr
(error* 'name "expecting a ~s keyword got: ~e" (error* 'name "expecting a ~s keyword got: ~.s"
'keywords (car body*)))))))))) 'keywords (car body*))))))))))
;; ------------------------------------------------------------------------ ;; ------------------------------------------------------------------------
;; generates the loop that turns flags to #t's ;; generates the loop that turns flags to #t's
@ -456,7 +456,7 @@
(syntax/loc stx (syntax/loc stx
(lambda vars (lambda vars
(if (and (pair? body) (keyword? (car body))) (if (and (pair? body) (keyword? (car body)))
(error* 'name "unknown keyword: ~e" (car body)) (error* 'name "unknown keyword: ~.s" (car body))
expr)))))] expr)))))]
;; no keys => make a case-lambda for optionals ;; no keys => make a case-lambda for optionals
[(and (null? keys) (not (or body allow-other-keys?))) [(and (null? keys) (not (or body allow-other-keys?)))

2
collects/mzlib/private/contract-arr-checks.rkt
View File

@ -161,7 +161,7 @@
(raise-blame-error (raise-blame-error
blame blame
val 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 dom-length
(keyword-error-text mandatory-kwds) (keyword-error-text mandatory-kwds)
val))) val)))

41
collects/mzlib/private/contract-arrow.rkt
View File

@ -35,22 +35,33 @@
[(res-x ...) (generate-temporaries #'(rngs ...))]) [(res-x ...) (generate-temporaries #'(rngs ...))])
#'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...) #'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
(let ([proj-x (contract-projection rngs-x)] ...) (let ([proj-x (contract-projection rngs-x)] ...)
(define ctc (define name
(make-contract (build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...))
#:name (define (proj wrapper)
(build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...) (λ (blame)
#:projection (let* ([p-app-x (proj-x blame)] ...
(λ (blame) [res-checker (λ (res-x ...) (values (p-app-x res-x) ...))])
(let ([p-app-x (proj-x blame)] ...) (λ (val)
(λ (val) (if (procedure? val)
(if (procedure? val) (wrapper
(make-contracted-function val
(make-keyword-procedure
(λ (kwds kwd-vals . args)
(apply values res-checker kwd-vals args))
(λ args (λ args
(let-values ([(res-x ...) (apply val args)]) (apply values res-checker args)))
(values (p-app-x res-x) ...))) impersonator-prop:contracted ctc)
ctc) (raise-blame-error blame val "expected a procedure"))))))
(raise-blame-error blame val "expected a procedure"))))) (define ctc
#:first-order procedure?)) (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)))])) ctc)))]))
(define (build--> name doms doms-rest rngs kwds quoted-kwds rng-any? func) (define (build--> name doms doms-rest rngs kwds quoted-kwds rng-any? func)

73
collects/mzlib/private/contract-mutable.rkt Normal file
View File

@ -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))))))

41
collects/mzlib/private/contract-object.rkt
View File

@ -281,33 +281,26 @@
... ...
[field-ctc-var (coerce-contract 'object-contract field-ctc-stx)] [field-ctc-var (coerce-contract 'object-contract field-ctc-stx)]
...) ...)
(make-contract (define ctc
#:name (make-contract
`(object-contract #:name
,(build-compound-type-name 'method-name method-ctc-var) ... `(object-contract
,(build-compound-type-name 'field 'field-name field-ctc-var) ...) ,(build-compound-type-name 'method-name method-ctc-var) ...
#:projection ,(build-compound-type-name 'field 'field-name field-ctc-var) ...)
(lambda (blame) #: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) (lambda (val)
(make-wrapper-object val blame (let/ec ret
(list 'method-name ...) (list method-ctc-var ...) (check-object-contract val (list 'method-name ...) (list 'field-name ...)
(list 'field-name ...) (list field-ctc-var ...)))) (λ args (ret #f)))))))
#:first-order ctc))))]))))
(lambda (val)
(check-object-contract val #f (list 'method-name ...) (list 'field-name ...))))))))]))))
(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) (define (make-mixin-contract . %/<%>s)
((and/c (flat-contract class?) ((and/c (flat-contract class?)
(apply and/c (map sub/impl?/c %/<%>s))) (apply and/c (map sub/impl?/c %/<%>s)))

75
collects/mzlib/private/contract-struct.rkt Normal file
View File

@ -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))]))

349
collects/mzlib/process.rkt
View File

@ -1,210 +1,171 @@
#lang mzscheme
(provide process
process*
process/ports
process*/ports
system
system*
system/exit-code
system*/exit-code)
(module process mzscheme (require mzlib/port)
(provide process
process*
process/ports
process*/ports
system
system*
system/exit-code
system*/exit-code)
(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) (define (if-stream-out p)
(case (system-type) (cond [(or (not p) (file-stream-port? p)) p]
((unix macosx) (append '("/bin/sh" "-c") (list argstr))) [(output-port? p) #f]
((windows) (let ([cmd [else (raise-type-error 'subprocess "output port" p)]))
(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) (define (if-stream-in p)
(if (or (not p) (file-stream-port? p)) (cond [(or (not p) (file-stream-port? p)) p]
p [(input-port? p) #f]
(if (output-port? p) [else (raise-type-error 'subprocess "input port" p)]))
#f
(raise-type-error
'subprocess
"output port"
p))))
(define (if-stream-in p) (define (streamify-in cin in ready-for-break)
(if (or (not p) (file-stream-port? p)) (if (and cin (not (file-stream-port? cin)))
p (thread (lambda ()
(if (input-port? p) (dynamic-wind
#f void
(raise-type-error (lambda ()
'subprocess (with-handlers ([exn:break? void])
"input port" (ready-for-break #t)
p)))) (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) (define (streamify-out cout out)
(if (and cin (not (file-stream-port? cin))) (if (and cout (not (file-stream-port? cout)))
(let ([t (thread (lambda () (thread (lambda ()
(dynamic-wind (dynamic-wind
void void
(lambda () (lambda () (copy-port out cout))
(with-handlers ([exn:break? void]) (lambda () (close-input-port out)))))
(ready-for-break #t) out))
(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 get-thread?) ;; Old-style functions: ----------------------------------------
(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: ---------------------------------------- (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) (define (process/ports out in err str)
(let-values ([(subp out in err) (apply subprocess (apply process*/ports out in err (shell-path/args 'process/ports str)))
(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) (define (process* exe . args)
(apply process*/ports out in err (shell-path/args "process/ports" str))) (apply process*/ports #f #f #f exe args))
(define (process* exe . args) (define (process str)
(apply process*/ports #f #f #f exe args)) (apply process* (shell-path/args 'process str)))
(define (process str) ;; Note: these always use current ports
(apply process* (shell-path/args "process" str))) (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* exe . args)
(define (system*/exit-code exe . args) (zero? (apply 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) (define (system str)
(if (eq? (system-type) 'macos) (apply system* (shell-path/args 'system str)))
(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) (define (system/exit-code str)
(if (eq? (system-type) 'macos) (apply system*/exit-code (shell-path/args 'system/exit-code str)))
(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)))))

103
collects/mzlib/runtime-path.rkt
View File

@ -11,24 +11,23 @@
(provide define-runtime-path (provide define-runtime-path
define-runtime-paths define-runtime-paths
define-runtime-path-list define-runtime-path-list
define-runtime-module-path-index
runtime-paths) runtime-paths)
(define-for-syntax ext-file-table (make-hasheq)) (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 ;; This function is designed to cooperate with a table embedded
;; in an executable by create-embedding-executable. ;; 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 (let ([p (hash-ref
table table
(cons (cond (cons (resolved-module-path-name modname)
[(module-path-index? mpi)
(resolved-module-path-name (module-path-index-resolve mpi))]
[(symbol? mpi) mpi]
[else #f])
(if (path? p) (if (path? p)
(path->bytes p) (path->bytes p)
p)) (if (and (pair? p) (eq? 'module (car p)))
(list 'module (cadr p))
p)))
#f)]) #f)])
(and p (and p
(car p) (car p)
@ -36,11 +35,13 @@
[p (if (bytes? p) [p (if (bytes? p)
(bytes->path p) (bytes->path p)
p)]) p)])
(if (absolute-path? p) (if (symbol? p)
p (module-path-index-join (list 'quote p) #f) ; make it a module path index
(parameterize ([current-directory (find-system-path 'orig-dir)]) (if (absolute-path? p)
(or (find-executable-path (find-system-path 'exec-file) p #t) p
(build-path (current-directory) 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) (define (resolve-paths tag-stx get-base paths)
(let ([base #f]) (let ([base #f])
@ -78,24 +79,31 @@
(let ([s (cadr p)]) (let ([s (cadr p)])
(if (regexp-match? #rx"[./]" s) (if (regexp-match? #rx"[./]" s)
s s
(string-append s "/main.rkt"))))] (string-append s "/main.rkt"))))])
[dir (if (and (null? (cddr p)) (apply collection-file-path
(null? (cdr strs))) (last strs)
(collection-path "mzlib") (if (and (null? (cddr p))
(apply collection-path (append (cddr p) (drop-right strs 1))))]) (null? (cdr strs)))
(build-path dir (last strs)))] (list "mzlib")
[else (error 'runtime-path "unknown form: ~e" p)]))) (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))) paths)))
(define-for-syntax (register-ext-files tag-stx paths) (define-for-syntax (register-ext-files var-ref paths)
(let ([mpi (syntax-source-module tag-stx)]) (let ([modname (variable-reference->resolved-module-path var-ref)])
(let ([modname (cond (let ([files (hash-ref ext-file-table modname null)])
[(module-path-index? mpi) (module-path-index-resolve mpi)] (hash-set! ext-file-table modname (append paths files)))))
[(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-syntax (-define-runtime-path stx) (define-syntax (-define-runtime-path stx)
(syntax-case stx () (syntax-case stx ()
@ -110,23 +118,22 @@
#'orig-stx #'orig-stx
id))) id)))
ids) ids)
(let ([tag (datum->syntax #'orig-stx 'tag #'orig-stx)]) #`(begin
#`(begin (define-values (id ...)
(define-values (id ...) (let-values ([(id ...) expr])
(let-values ([(id ...) expr]) (let ([get-dir (lambda ()
(let ([get-dir (lambda () #,(datum->syntax
#,(datum->syntax #'orig-stx
tag `(,#'this-expression-source-directory)
`(,#'this-expression-source-directory) #'orig-stx))])
tag))]) (apply to-values (resolve-paths (#%variable-reference)
(apply to-values (resolve-paths (quote-syntax #,tag) get-dir
get-dir (to-list id ...))))))
(to-list id ...)))))) (begin-for-syntax
(begin-for-syntax (register-ext-files
(register-ext-files (#%variable-reference)
(quote-syntax #,tag) (let-values ([(id ...) expr])
(let-values ([(id ...) expr]) (to-list id ...))))))]))
(to-list id ...)))))))]))
(define-syntax (define-runtime-path stx) (define-syntax (define-runtime-path stx)
(syntax-case stx () (syntax-case stx ()
@ -140,6 +147,10 @@
(syntax-case stx () (syntax-case stx ()
[(_ id expr) #`(-define-runtime-path #,stx (id) expr values list)])) [(_ 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) (define-syntax (runtime-paths stx)
(syntax-case stx () (syntax-case stx ()
[(_ mp) [(_ mp)

16
collects/mzlib/thread.rkt
View File

@ -115,7 +115,7 @@
;; coroutine : ((bool ->) -> X) -> X-coroutine-object ;; coroutine : ((bool ->) -> X) -> X-coroutine-object
(define (coroutine f) (define (coroutine f)
;;(printf "2. new coroutine~n") ;;(printf "2. new coroutine\n")
(let* ([can-stop-lock (make-semaphore 1)] (let* ([can-stop-lock (make-semaphore 1)]
[done-ch (make-channel)] [done-ch (make-channel)]
[ex-ch (make-channel)] [ex-ch (make-channel)]
@ -123,7 +123,7 @@
[stop-enabled? #t] [stop-enabled? #t]
[enable-stop [enable-stop
(lambda (enable?) (lambda (enable?)
;;(printf "3. enabling ~a~n" enable?) ;;(printf "3. enabling ~a\n" enable?)
(cond (cond
[(and enable? (not stop-enabled?)) [(and enable? (not stop-enabled?))
(semaphore-post can-stop-lock) (semaphore-post can-stop-lock)
@ -131,11 +131,11 @@
[(and (not enable?) stop-enabled?) [(and (not enable?) stop-enabled?)
(semaphore-wait can-stop-lock) (semaphore-wait can-stop-lock)
(set! stop-enabled? #f)]) (set! stop-enabled? #f)])
;;(printf "3. finished enabling~n") ;;(printf "3. finished enabling\n")
)] )]
[tid (thread (lambda () [tid (thread (lambda ()
(semaphore-wait proceed-sema) (semaphore-wait proceed-sema)
;;(printf "3. creating coroutine thread~n") ;;(printf "3. creating coroutine thread\n")
(with-handlers ([(lambda (exn) #t) (with-handlers ([(lambda (exn) #t)
(lambda (exn) (lambda (exn)
(enable-stop #t) (enable-stop #t)
@ -152,7 +152,7 @@
(if (coroutine-object-worker w) (if (coroutine-object-worker w)
(let ([can-stop-lock (coroutine-object-can-stop-lock w)] (let ([can-stop-lock (coroutine-object-can-stop-lock w)]
[worker (coroutine-object-worker w)]) [worker (coroutine-object-worker w)])
#;(printf "2. starting coroutine~n") #;(printf "2. starting coroutine\n")
(thread-resume worker) (thread-resume worker)
(dynamic-wind (dynamic-wind
void void
@ -162,20 +162,20 @@
timeout timeout
(alarm-evt (+ timeout (current-inexact-milliseconds)))) (alarm-evt (+ timeout (current-inexact-milliseconds))))
(lambda (x) (lambda (x)
#;(printf "2. alarm-evt~n") #;(printf "2. alarm-evt\n")
(semaphore-wait can-stop-lock) (semaphore-wait can-stop-lock)
(thread-suspend worker) (thread-suspend worker)
(semaphore-post can-stop-lock) (semaphore-post can-stop-lock)
#f)) #f))
(wrap-evt (coroutine-object-done-ch w) (wrap-evt (coroutine-object-done-ch w)
(lambda (res) (lambda (res)
#;(printf "2. coroutine-done-evt~n") #;(printf "2. coroutine-done-evt\n")
(set-coroutine-object-result! w res) (set-coroutine-object-result! w res)
(coroutine-kill w) (coroutine-kill w)
#t)) #t))
(wrap-evt (coroutine-object-ex-ch w) (wrap-evt (coroutine-object-ex-ch w)
(lambda (exn) (lambda (exn)
#;(printf "2. ex-evt~n") #;(printf "2. ex-evt\n")
(coroutine-kill w) (coroutine-kill w)
(raise exn)))))) (raise exn))))))
;; In case we escape through a break: ;; In case we escape through a break:

4
collects/mzlib/traceld.rkt
View File

@ -8,7 +8,7 @@
(lambda (load) (lambda (load)
(lambda (filename expected-module) (lambda (filename expected-module)
(fprintf ep (fprintf ep
"~aloading ~a at ~a~n" "~aloading ~a at ~a\n"
tab filename (current-process-milliseconds)) tab filename (current-process-milliseconds))
(begin0 (begin0
(let ([s tab]) (let ([s tab])
@ -18,7 +18,7 @@
(load filename expected-module)) (load filename expected-module))
(lambda () (set! tab s)))) (lambda () (set! tab s))))
(fprintf ep (fprintf ep
"~adone ~a at ~a~n" "~adone ~a at ~a\n"
tab filename (current-process-milliseconds)))))]) tab filename (current-process-milliseconds)))))])
(current-load (mk-chain load)) (current-load (mk-chain load))
(current-load-extension (mk-chain load-extension)))) (current-load-extension (mk-chain load-extension))))

4
collects/mzlib/unit.rkt
View File

@ -843,7 +843,7 @@
(names (apply append nameses)) (names (apply append nameses))
(dup (check-duplicate-identifier names))) (dup (check-duplicate-identifier names)))
(when dup (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 (quasisyntax/loc stx
(provide #,@names)))))) (provide #,@names))))))
@ -1652,7 +1652,7 @@
(tmp-bindings (map (λ (s) (map tmarker (map car (car s)))) out-sigs)) (tmp-bindings (map (λ (s) (map tmarker (map car (car s)))) out-sigs))
(def-table (make-bound-identifier-mapping))) (def-table (make-bound-identifier-mapping)))
(when dup (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 (for-each
(λ (sig new-xs) (λ (sig new-xs)
(for-each (for-each

102
collects/net/cgi-unit.rkt
View File

@ -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: ;; is as follows:
;; spaces are turned into "+"es and lots of things are turned into %XX, where ;; 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 ;; XX are hex digits, eg, %E7 for ~. The output is a regular Scheme string
;; with all the characters converted back. ;; with all the characters converted back.
(define (query-chars->string chars) (define query-string->string form-urlencoded-decode)
(form-urlencoded-decode (list->string chars)))
;; string->html : string -> string ;; string->html : string -> string
;; -- the input is raw text, the output is HTML appropriately quoted ;; -- the input is raw text, the output is HTML appropriately quoted
@ -92,70 +91,53 @@
(define (output-http-headers) (define (output-http-headers)
(printf "Content-type: text/html\r\n\r\n")) (printf "Content-type: text/html\r\n\r\n"))
;; read-until-char : iport x char -> list (char) x bool ;; delimiter->predicate : symbol -> regexp
;; -- operates on the default input port; the second value indicates whether ;; returns a regexp to read a chunk of text up to a delimiter (excluding it)
;; reading stopped because an EOF was hit (as opposed to the delimiter being (define (delimiter->rx delimiter)
;; 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)
(case delimiter (case delimiter
[(eq) (lambda (c) (char=? c #\=))] [(amp) #rx#"^[^&]*"]
[(amp) (lambda (c) (char=? c #\&))] [(semi) #rx#"^[^;]*"]
[(semi) (lambda (c) (char=? c #\;))] [(amp-or-semi) #rx#"^[^&;]*"]
[(amp-or-semi) (lambda (c) (or (char=? c #\&) (char=? c #\;)))])) [else (error 'delimiter->rx
"internal-error, unknown delimiter: ~e" delimiter)]))
;; read-name+value : iport -> (symbol + bool) x (string + bool) x bool ;; get-bindings* : iport -> (listof (cons symbol string))
;; -- If the first value is false, so is the second, and the third is true, ;; Reads all bindings from the input port. The strings are processed to
;; indicating EOF was reached without any input seen. Otherwise, the first ;; remove the CGI spec "escape"s.
;; and second values contain strings and the third is either true or false ;; This code is _slightly_ lax: it allows an input to end in
;; depending on whether the EOF has been reached. The strings are processed ;; (current-alist-separator-mode). It's not clear this is legal by the
;; to remove the CGI spec "escape"s. This code is _slightly_ lax: it allows ;; CGI spec, which suggests that the last value binding must end in an
;; an input to end in (current-alist-separator-mode). ;; EOF. It doesn't look like this matters.
;; It's not clear this is legal by the CGI spec, ;; ELI: * Keeping this behavior for now, maybe better to remove it?
;; which suggests that the last value binding must end in an EOF. It doesn't ;; * Looks like `form-urlencoded->alist' is doing almost exactly
;; look like this matters. It would also introduce needless modality and ;; the same job this code does.
;; reduce flexibility. (define (get-bindings* method ip)
(define (read-name+value ip) (define (err fmt . xs)
(let-values ([(name eof?) (read-until-char ip (delimiter->predicate 'eq))]) (generate-error-output
(cond [(and eof? (null? name)) (values #f #f #t)] (list (format "Server generated malformed input for ~a method:" method)
[eof? (apply format fmt xs))))
(generate-error-output (define value-rx (delimiter->rx (current-alist-separator-mode)))
(list "Server generated malformed input for POST method:" (define (process str) (query-string->string (bytes->string/utf-8 str)))
(string-append (let loop ([bindings '()])
"No binding for `" (list->string name) "' field.")))] (if (eof-object? (peek-char ip))
[else (let-values ([(value eof?) (reverse bindings)
(read-until-char (let ()
ip (define name (car (or (regexp-match #rx"^[^=]+" ip)
(delimiter->predicate (err "Missing field name before `='"))))
(current-alist-separator-mode)))]) (unless (eq? #\= (read-char ip))
(values (string->symbol (query-chars->string name)) (err "No binding for `~a' field." name))
(query-chars->string value) (define value (car (regexp-match value-rx ip)))
eof?))]))) (read-char ip) ; consume the delimiter, possibly eof (retested above)
(loop (cons (cons (string->symbol (process name)) (process value))
bindings))))))
;; get-bindings/post : () -> bindings ;; get-bindings/post : () -> bindings
(define (get-bindings/post) (define (get-bindings/post)
(let-values ([(name value eof?) (read-name+value (current-input-port))]) (get-bindings* "POST" (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/get : () -> bindings ;; get-bindings/get : () -> bindings
(define (get-bindings/get) (define (get-bindings/get)
(let ([p (open-input-string (getenv "QUERY_STRING"))]) (get-bindings* "GET" (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 : () -> bindings ;; get-bindings : () -> bindings
(define (get-bindings) (define (get-bindings)

13
collects/tests/racket/contract-mzlib-test.rktl
View File

@ -78,9 +78,12 @@ of the contract library does not change over time.
(define (test/spec-failed name expression blame) (define (test/spec-failed name expression blame)
(let () (let ()
(define (has-proper-blame? msg) (define (has-proper-blame? msg)
(regexp-match? (define reg
(string-append "(^| )" (regexp-quote blame) " broke") (case blame
msg)) [(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) (printf "testing: ~s\n" name)
(contract-eval (contract-eval
`(,thunk-error-test `(,thunk-error-test
@ -1546,8 +1549,8 @@ of the contract library does not change over time.
'pos 'pos
'neg) 'neg)
1) 1)
x) (reverse x))
(reverse '(1 3 4 2))) '(3 1 2 4))
(test/neg-blame (test/neg-blame
'parameter/c1 'parameter/c1

4
collects/tests/racket/macrolib.rktl
View File

@ -97,7 +97,7 @@
(define (opt-lam-test exp expected) (define (opt-lam-test exp expected)
(let ([got (eval exp)]) (let ([got (eval exp)])
(unless (equal? got expected) (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)))) exp expected got))))
(define (opt-lam-test/bad exp expected) (define (opt-lam-test/bad exp expected)
@ -105,7 +105,7 @@
(lambda (exn) (exn-message exn))]) (lambda (exn) (exn-message exn))])
(cons 'got-result (eval exp)))]) (cons 'got-result (eval exp)))])
(unless (regexp-match expected got) (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)))) exp expected got))))
(test 1 (opt-lambda (start) start) 1) (test 1 (opt-lambda (start) start) 1)

4
collects/tests/racket/pconvert.rktl
View File

@ -51,11 +51,11 @@
[whole/fractional-exact-numbers whole/fractional-numbers?]) [whole/fractional-exact-numbers whole/fractional-numbers?])
(test (selector test-case) print-convert before)) (test (selector test-case) print-convert before))
(printf (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? constructor-style? quasi-read?
sharing? cons-as-list? sharing? cons-as-list?
whole/fractional-numbers?)))]) whole/fractional-numbers?)))])
;(printf "testing: ~s~n" before) ;(printf "testing: ~s\n" before)
;(printf ".") (flush-output (current-output-port)) ;(printf ".") (flush-output (current-output-port))
(cond (cond
[(pctest? test-case) [(pctest? test-case)