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")
(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)

4
collects/mzlib/date.rkt
View File

@ -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))))))))))))
(loop (cdr (cdr (cdr reversed-digits))))))))))))

8
collects/mzlib/file.rkt
View File

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

9
collects/mzlib/include.rkt
View File

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

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

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

12
collects/mzlib/kw.rkt
View File

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

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

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

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

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

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)]
...)
(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)))

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

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

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

16
collects/mzlib/thread.rkt
View File

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

4
collects/mzlib/traceld.rkt
View File

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

4
collects/mzlib/unit.rkt
View File

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

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:
;; 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)

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

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

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

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

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