diff --git a/collects/drracket/acks.rkt b/collects/drracket/acks.rkt index 601afb6739..2f8325b97c 100644 --- a/collects/drracket/acks.rkt +++ b/collects/drracket/acks.rkt @@ -54,6 +54,7 @@ "Paul Steckler, " "Jens Axel Søgaard, " "Francisco Solsona, " + "Stevie Strickland, " "Sam Tobin-Hochstadt, " "Neil Van Dyke, " "David Van Horn, " diff --git a/collects/meta/contrib/completion/racket-completion.bash b/collects/meta/contrib/completion/racket-completion.bash index a22b0f5d58..2c2292646b 100644 --- a/collects/meta/contrib/completion/racket-completion.bash +++ b/collects/meta/contrib/completion/racket-completion.bash @@ -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 \ No newline at end of file +complete -F _raco raco diff --git a/collects/meta/drdr/analyze.ss b/collects/meta/drdr/analyze.ss index f29cf3ba6c..766cd993b0 100644 --- a/collects/meta/drdr/analyze.ss +++ b/collects/meta/drdr/analyze.ss @@ -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" diff --git a/collects/meta/drdr/metadata.ss b/collects/meta/drdr/metadata.ss index 2f9d2de4a8..6de61f36ef 100644 --- a/collects/meta/drdr/metadata.ss +++ b/collects/meta/drdr/metadata.ss @@ -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" diff --git a/collects/meta/drdr/plt-build.ss b/collects/meta/drdr/plt-build.ss index d0791683f1..0ed865525c 100644 --- a/collects/meta/drdr/plt-build.ss +++ b/collects/meta/drdr/plt-build.ss @@ -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" diff --git a/collects/meta/drdr/scm.ss b/collects/meta/drdr/scm.ss index 95bb4abc91..8449f94407 100644 --- a/collects/meta/drdr/scm.ss +++ b/collects/meta/drdr/scm.ss @@ -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?)]) \ No newline at end of file + [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?)]) diff --git a/collects/meta/props b/collects/meta/props index 5f8f0581b6..c49f570be6 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -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" diff --git a/collects/repo-time-stamp/stamp.rkt b/collects/repo-time-stamp/stamp.rkt index d39cb78600..f764632f8e 100644 --- a/collects/repo-time-stamp/stamp.rkt +++ b/collects/repo-time-stamp/stamp.rkt @@ -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))] diff --git a/collects/syntax/private/stxparse/runtime.rkt b/collects/syntax/private/stxparse/runtime.rkt index d7fad96a6a..b042b7bced 100644 --- a/collects/syntax/private/stxparse/runtime.rkt +++ b/collects/syntax/private/stxparse/runtime.rkt @@ -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) diff --git a/collects/syntax/private/util/txlift.ss b/collects/syntax/private/util/txlift.rkt similarity index 96% rename from collects/syntax/private/util/txlift.ss rename to collects/syntax/private/util/txlift.rkt index 11f53a09ef..7195f69884 100644 --- a/collects/syntax/private/util/txlift.ss +++ b/collects/syntax/private/util/txlift.rkt @@ -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 diff --git a/collects/syntax/scribblings/parse.scrbl b/collects/syntax/scribblings/parse.scrbl index dc1c828c03..23dbb8b140 100644 --- a/collects/syntax/scribblings/parse.scrbl +++ b/collects/syntax/scribblings/parse.scrbl @@ -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 ...) diff --git a/collects/web-server/http/response-structs.rkt b/collects/web-server/http/response-structs.rkt index 202288a7c5..c6fb464fc4 100644 --- a/collects/web-server/http/response-structs.rkt +++ b/collects/web-server/http/response-structs.rkt @@ -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?]) diff --git a/collects/web-server/http/response.rkt b/collects/web-server/http/response.rkt index e342355bd8..a474bbbf8d 100644 --- a/collects/web-server/http/response.rkt +++ b/collects/web-server/http/response.rkt @@ -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))) diff --git a/collects/web-server/scribblings/http.scrbl b/collects/web-server/scribblings/http.scrbl index 605beb40da..2de2af8a3a 100644 --- a/collects/web-server/scribblings/http.scrbl +++ b/collects/web-server/scribblings/http.scrbl @@ -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"].}