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

Merge remote branch 'origin/master' into samth/new-logic2

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2010-05-13 14:23:58 -04:00
commit 52f5a1936c
14 changed files with 146 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/drracket/acks.rkt
View File

@ -54,6 +54,7 @@
"Paul Steckler, "
"Jens Axel Søgaard, "
"Francisco Solsona, "
"Stevie Strickland, "
"Sam Tobin-Hochstadt, "
"Neil Van Dyke, "
"David Van Horn, "

4
collects/meta/contrib/completion/racket-completion.bash
View File

@ -14,7 +14,7 @@
_smart_filedir()
{
COMPREPLY=()
_filedir '@(rkt|ss|scm|scrbl)'
_filedir '@(rkt|rktl|ss|scm|scrbl)'
if [[ ${#COMPREPLY[@]} -eq 0 ]]; then
_filedir
fi
@ -147,4 +147,4 @@ _raco()
complete -F _raco rico
complete -F _raco racket-tool
complete -F _raco raco
complete -F _raco raco

5
collects/meta/drdr/analyze.ss
View File

@ -145,7 +145,10 @@
diff
(for*/or ([(r ht) (in-hash diff)]
[(id ps) (in-hash ht)])
(and (not (empty? ps))
(and (for/or ([p (in-list ps)])
; XXX This squelch should be disabled if the committer changed this file
; XXX But even then it can lead to problems
(not (path-random? (build-path (revision-trunk-dir cur-rev) p))))
(not (symbol=? id 'changes))))))
(unless (andmap zero? nums)
(send-mail-message "drdr@plt-scheme.org"

8
collects/meta/drdr/metadata.ss
View File

@ -33,11 +33,17 @@
(define (path-responsible a-path)
(get-prop a-path 'responsible #:as-string? #t))
; XXX Document on help page
; XXX Use in computing "changes?"
(define (path-random? a-path)
(get-prop a-path 'drdr:random))
(provide/contract
[PROP:command-line string?]
[PROP:timeout string?]
[path-responsible (path-string? . -> . (or/c string? false/c))]
[path-command-line (path-string? . -> . (or/c (listof string?) false/c))]
[path-random? (path-string? . -> . boolean?)]
[path-timeout (path-string? . -> . (or/c exact-nonnegative-integer? false/c))])
;;; Property lookup
@ -55,7 +61,7 @@
(define tmp-file (make-temporary-file "props~a.ss" #f (current-temporary-directory)))
(and
; Checkout the props file
(scm-export
(scm-export-file
rev
(plt-repository)
"collects/meta/props"

1
collects/meta/drdr/plt-build.ss
View File

@ -282,6 +282,7 @@
[current-temporary-directory tmp-dir]
[current-rev rev])
(with-env (["PLTSTDERR" "error"]
["GIT_DIR" (path->string (plt-repository))]
["TMPDIR" (path->string tmp-dir)]
["PATH"
(format "~a:~a"

29
collects/meta/drdr/scm.ss
View File

@ -42,6 +42,17 @@
[_
#f]))
(define (pipe/proc cmds)
(if (null? (cdr cmds))
((car cmds))
(let-values ([(i o) (make-pipe 4096)])
(parameterize ([current-output-port o])
(thread (lambda () ((car cmds)) (close-output-port o))))
(parameterize ([current-input-port i])
(pipe/proc (cdr cmds))))))
(define-syntax-rule (pipe expr exprs ...)
(pipe/proc (list (lambda () expr) (lambda () exprs) ...)))
(define (system/output-port #:k k #:stdout [init-stdout #f] . as)
(define _ (printf "~S~n" as))
(define-values (sp stdout stdin stderr)
@ -150,7 +161,7 @@
(provide/contract
[scm-commit-author ((or/c git-push? svn-rev-log?) . -> . string?)])
(define (scm-export rev repo file dest)
(define (scm-export-file rev repo file dest)
(define commit
(push-data-end-commit (push-info rev)))
(call-with-output-file*
@ -164,6 +175,17 @@
(git-path) "--no-pager" "show" (format "~a:~a" commit file)))))
(void))
(define (scm-export-repo rev repo dest)
(pipe
(system*
(git-path) "archive"
(format "--remote=~a" repo)
(format "--prefix=~a/" (regexp-replace #rx"/+$" (path->string* dest) ""))
"--format=tar"
(push-data-end-commit (push-info rev)))
(system* (find-executable-path "tar") "xf" "-" "--absolute-names"))
(void))
(define (scm-checkout rev repo dest)
(system* (git-path) "clone" (path->string* repo) (path->string* dest))
(parameterize ([current-directory dest])
@ -188,5 +210,6 @@
(provide/contract
[scm-update (path? . -> . void?)]
[scm-revisions-after (exact-nonnegative-integer? . -> . (listof exact-nonnegative-integer?))]
[scm-export (exact-nonnegative-integer? path-string? string? path-string? . -> . void?)]
[scm-checkout (exact-nonnegative-integer? path-string? path-string? . -> . void?)])
[scm-export-file (exact-nonnegative-integer? path-string? string? path-string? . -> . void?)]
[scm-export-repo (exact-nonnegative-integer? path-string? path-string? . -> . void?)]
[scm-checkout (exact-nonnegative-integer? path-string? path-string? . -> . void?)])

38
collects/meta/props
View File

@ -395,17 +395,17 @@ path/s is either such a string or a list of them.
(for/list ([p (in-lines (current-input-port))]) p)
(let ([root (normalize-path (find-root))])
(define (norm p)
(unless (or (not check-existing-paths?)
(file-exists? p)
(directory-exists? p))
(error* #f "path does not exist: ~s" p))
(let ([n (find-relative-path root (normalize-path p))])
(cond
[(not (or (not check-existing-paths?)
(file-exists? n)
(directory-exists? n)))
(error* #f "path does not exist: ~s" p)]
[(equal? n root) ""]
[else (let ([n (path->string n)])
(if (regexp-match #rx"^\\.\\.(?:/|$)" n)
(error* #f "path is not in the plt tree: ~s" p)
n))])))
(if (equal? n root)
""
(let ([n (path->string n)])
(if (regexp-match #rx"^\\.\\.(?:/|$)" n)
(error* #f "path is not in the plt tree: ~s" p)
n)))))
(if (null? paths) (norm path) (map norm (cons path paths))))))
(define (get prop path . paths)
(let ([prop (string->symbol prop)]
@ -484,7 +484,17 @@ path/s is either such a string or a list of them.
(if (regexp-match? #rx"^ *[0-9]+ *$" str)
(string->number str)
(error "expecting an integer")))
number->string)))
number->string)
;; --------------------
(make-prop
'drdr:random
"is file output random?"
(lambda (str)
(if (regexp-match? #rx"^(yes|no)$" str)
(string=? "yes" str)
(error "expecting yes or no")))
(lambda (b)
(if b "yes" "no")))))
;; read the arguments here, so just requiring this file verifies the data
(read-props)
@ -1335,9 +1345,9 @@ path/s is either such a string or a list of them.
"collects/tests/drracket/language-test.rkt" drdr:command-line "mred ~s" drdr:timeout 600
"collects/tests/drracket/module-lang-test-utils.rkt" drdr:command-line "mred-text -t ~s"
"collects/tests/drracket/module-lang-test.rkt" drdr:command-line "mred ~s" drdr:timeout 120
"collects/tests/drracket/randomly-click-language-dialog.rkt" drdr:command-line "mzc ~s"
"collects/tests/drracket/randomly-click-preferences.rkt" drdr:command-line "mzc ~s"
"collects/tests/drracket/randomly-click.rkt" drdr:command-line ""
"collects/tests/drracket/randomly-click-language-dialog.rkt" drdr:command-line "mzc ~s" drdr:random #t
"collects/tests/drracket/randomly-click-preferences.rkt" drdr:command-line "mzc ~s" drdr:random #t
"collects/tests/drracket/randomly-click.rkt" drdr:command-line "" drdr:random #t
"collects/tests/drracket/repl-test.rkt" drdr:command-line "mred ~s" drdr:timeout 600
"collects/tests/drracket/sample-solutions-one-window.rkt" drdr:command-line "mred-text -t ~s"
"collects/tests/drracket/save-teaching-lang-file.rkt" drdr:command-line "mred ~s"

7
collects/repo-time-stamp/stamp.rkt
View File

@ -11,7 +11,7 @@
(define-runtime-path this "stamp.rkt")
(define stamp
(let ([rx:secs+id #rx"^([0-9]+)\\|([0-9a-f]+)\\|(.*?)[ \r\n]*$"])
(let ([rx:secs+id #rx"^([0-9]+)\\|([0-9a-f]+|-)\\|(.*?)[ \r\n]*$"])
(for*/or ([x (list
;; info from an archive (incl. nightly builds)
(lambda () archive-id)
@ -21,13 +21,14 @@
(find-executable-path "git.exe"))])
(and exe
(let ([out (open-output-string)])
(parameterize ([current-output-port out])
(parameterize ([current-output-port out]
[current-error-port out])
(system* exe "log" "-1"
"--pretty=format:%ct|%h|g")
(get-output-string out))))))
;; fallback: get the date of this file, no id
(lambda ()
(format "~a|0|f"
(format "~a|-|f"
(file-or-directory-modify-seconds this))))])
(let* ([x (x)]
[m (and (string? x) (regexp-match rx:secs+id x))]

11
collects/syntax/private/stxparse/runtime.rkt
View File

@ -439,13 +439,10 @@ An Expectation is one of
#`(let ([value #,(attribute-mapping-var self)])
(if (check-syntax '#,(attribute-mapping-depth self) value)
value
(raise-syntax-error #f
"attribute is bound to non-syntax value"
(quote-syntax
#,(datum->syntax
stx
(attribute-mapping-name self)
stx)))))))))
(raise-syntax-error
#f
(format "attribute is bound to non-syntax value: ~e" value)
(quote-syntax #,(attribute-mapping-name self)))))))))
;; check-syntax : nat any -> boolean
;; Returns #t if value is a (listof^depth syntax)

4
collects/syntax/private/util/txlift.ss → collects/syntax/private/util/txlift.rkt
View File

@ -1,5 +1,5 @@
#lang scheme/base
(require (for-template scheme/base))
#lang racket/base
(require (for-template racket/base))
(provide txlift
get-txlifts
get-txlifts-as-definitions

74
collects/syntax/scribblings/parse.scrbl
View File

@ -66,7 +66,7 @@ For example, here is is a module that defines
standard @scheme[let] form (including ``named @scheme[let]''):
@schemeblock[
(module example scheme/base
(module example racket/base
(require (for-syntax scheme/base syntax/parse))
(define-syntax (mylet stx)
(syntax-parse stx
@ -82,8 +82,8 @@ The macro is defined as a procedure that takes one argument,
@scheme[syntax-case], except that there is no literals list between
the syntax argument and the sequence of clauses.
@bold{Note: } Remember not to put a literals list between the syntax
argument and the clauses!
@bold{Note: } Remember not to put a @scheme[syntax-case] style
literals list between the syntax argument and the clauses!
The patterns contain identifiers consisting of two parts separated by
a colon character, such as @scheme[loop:id] or @scheme[e:expr]. These
@ -104,15 +104,15 @@ syntax classes (see @secref{lib} for a list). Programmers can also
define their own using @scheme[define-syntax-class]:
@schemeblock[
(module example-syntax scheme/base
(module example-syntax racket/base
(require syntax/parse)
(provide binding)
(define-syntax-class binding
#:attributes (x e)
(pattern (x:id e:expr))))
(module example scheme/base
(require (for-syntax scheme/base
(module example racket/base
(require (for-syntax racket/base
syntax/parse
'example-syntax))
(define-syntax (mylet stx)
@ -135,7 +135,7 @@ Alternatively, the syntax class could be made a local definition,
thus:
@schemeblock[
(module example scheme/base
(module example racket/base
(require (for-syntax scheme/base
syntax/parse))
(define-syntax (mylet stx)
@ -286,9 +286,12 @@ Two parsing forms are provided: @scheme[syntax-parse] and
(code:line #:conventions (convention-id ...))
(code:line #:local-conventions (convention-rule ...))]
[literal literal-id
(pattern-id literal-id)]
(pattern-id literal-id)
(pattern-id literal-id #:phase phase-expr)]
[literal-set literal-set-id
[literal-set-id #:at context-id]]
(literal-set-id literal-set-option ...)]
[literal-set-option (code:line #:at context-id)
(code:line #:phase phase-expr)]
[clause (syntax-pattern pattern-directive ... expr ...+)])
#:contracts ([stx-expr syntax?])]{
@ -320,12 +323,12 @@ failures; otherwise @scheme[stx-expr] is used.
@specsubform/subs[(code:line #:literals (literal ...))
([literal literal-id
[pattern-id literal-id]])]{
(pattern-id literal-id)
(pattern-id literal-id #:phase phase-expr)])]{
@margin-note{
Unlike @scheme[syntax-case], @scheme[syntax-parse] requires all
literals to have a binding. To match identifiers by their symbolic
names, consider using the @scheme[~datum] pattern form instead.
names, use the @scheme[~datum] pattern form instead.
}
@;
The @scheme[#:literals] option specifies identifiers that should be
@ -335,16 +338,22 @@ within the pattern to signify the positions to be matched
(@scheme[pattern-id]), and the identifier expected to occur in those
positions (@scheme[literal-id]). If the entry is a single identifier,
that identifier is used for both purposes.
If the @scheme[#:phase] option is given, then the literal is compared
at phase @scheme[phase-expr]. Specifically, the binding of the
@scheme[literal-id] at phase @scheme[phase-expr] must match the
input's binding at phase @scheme[phase-expr].
}
@specsubform/subs[(code:line #:literal-sets (literal-set ...))
([literal-set literal-set-id
[literal-set-id #:at context-id]])]{
(literal-set-id literal-set-option ...)]
[literal-set-option (code:line #:at context-id)
(code:line #:phase phase-expr)])]{
Many literals can be declared at once via one or more @tech{literal
sets}, imported with the @scheme[#:literal-sets] option. The
literal-set definition determines the literal identifiers to recognize
and the names used in the patterns to recognize those literals.
sets}, imported with the @scheme[#:literal-sets] option. See
@tech{literal sets} for more information.
}
@specsubform[(code:line #:conventions (conventions-id ...))]{
@ -721,6 +730,39 @@ identifiers the literal matches.
[(define-values (x:id ...) e:expr) 'v]
[(define-syntaxes (x:id ...) e:expr) 's])
]
The literals in a literal set always refer to the phase-0 bindings of
the enclosing module. For example:
@myexamples[
(module common racket/base
(define x 'something)
(provide x))
(module lits racket/base
(require syntax/parse 'common)
(define-literal-set common-lits (x))
(provide common-lits))
]
In the literal set @scheme[common-lits], the literal @scheme[x] always
recognizes identifiers bound to the variable @scheme[x] defined in
module @schememodname['common].
When a literal set is used with the @scheme[#:phase phase-expr]
option, the literals' fixed bindings are compared against the binding of
the input literal at the specified phase. Continuing the example:
@myexamples[
(require syntax/parse 'lits (for-syntax 'common))
(syntax-parse #'x #:literal-sets ([common-lits #:phase 1])
[x 'yes]
[_ 'no])
]
The occurrence of @scheme[x] in the pattern matches any identifier
whose binding at phase 1 is the @scheme[x] from module
@schememodname['common].
}
@defform/subs[(define-conventions name-id convention-rule ...)

16
collects/web-server/http/response-structs.rkt
View File

@ -19,7 +19,7 @@
(define (response/full->size resp)
(apply + (map bytes-length (response/full-body resp))))
(define (normalize-response close? resp)
(define (normalize-response resp [close? #f])
(cond
[(response/full? resp)
(make-response/full
@ -43,14 +43,14 @@
(response/incremental-generator resp)))]
[(response/basic? resp)
(normalize-response
close?
(make-response/full
(response/basic-code resp)
(response/basic-message resp)
(response/basic-seconds resp)
(response/basic-mime resp)
(response/basic-headers resp)
empty))]
empty)
close?)]
[(and (list? resp)
(not (empty? resp))
(bytes? (first resp))
@ -58,18 +58,18 @@
(bytes? i)))
(rest resp)))
(normalize-response
close?
(make-response/full
200 #"Okay" (current-seconds) (car resp) empty
(map (lambda (bs)
(if (string? bs)
(string->bytes/utf-8 bs)
bs))
(rest resp))))]
(rest resp)))
close?)]
[else
(normalize-response
close?
(make-xexpr-response resp))]))
(make-xexpr-response resp)
close?)]))
(define (make-xexpr-response
xexpr
@ -108,5 +108,5 @@
((pretty-xexpr/c)
(#:code number? #:message bytes? #:seconds number? #:mime-type bytes? #:headers (listof header?))
. ->* . response/full?)]
[normalize-response (boolean? response/c . -> . (or/c response/full? response/incremental?))]
[normalize-response ((response/c) (boolean?) . ->* . (or/c response/full? response/incremental?))]
[TEXT/HTML-MIME-TYPE bytes?])

2
collects/web-server/http/response.rkt
View File

@ -59,7 +59,7 @@
(output-response/method conn resp #"GET"))
(define (output-response/method conn resp meth)
(define bresp (normalize-response (connection-close? conn) resp))
(define bresp (normalize-response resp (connection-close? conn)))
(output-headers+response/basic conn bresp)
(unless (bytes-ci=? meth #"HEAD")
(output-response/basic conn bresp)))

5
collects/web-server/scribblings/http.scrbl
View File

@ -246,9 +246,12 @@ Here is an example typical of what you will find in many applications:
(list (string->bytes/utf-8 (xexpr->string xexpr))))
]}
@defproc[(normalize-response [close? boolean?] [response response/c])
@defproc[(normalize-response [response response/c] [close? boolean? #f])
(or/c response/full? response/incremental?)]{
Coerces @racket[response] into a full response, filling in additional details where appropriate.
@racket[close?] represents whether the connection will be closed after the response is sent (i.e. if HTTP 1.0 is being used.) The accuracy of this only matters if
@racket[response] is a @racket[response/incremental?].
}
@defthing[TEXT/HTML-MIME-TYPE bytes?]{Equivalent to @racket[#"text/html; charset=utf-8"].}