diff --git a/collects/mzlib/private/sigutil.rkt b/collects/mzlib/private/sigutil.rkt index 5119966..ff954ee 100644 --- a/collects/mzlib/private/sigutil.rkt +++ b/collects/mzlib/private/sigutil.rkt @@ -602,6 +602,7 @@ (syntax-e (stx-car (stx-cdr p))))) (cdr (stx->list (let ([rn (car body)]) + ;; Use internal-definition-context-apply ?? (local-expand rn 'expression (list (stx-car rn)) diff --git a/collects/mzlib/trace.rkt b/collects/mzlib/trace.rkt index 5cc1929..be802c4 100644 --- a/collects/mzlib/trace.rkt +++ b/collects/mzlib/trace.rkt @@ -1,268 +1,4 @@ -#lang scheme/base +#lang racket/base -(require scheme/pretty - (for-syntax scheme/base)) - -(provide trace untrace - current-trace-print-args trace-call - current-trace-notify - current-prefix-out current-prefix-in) - -(define max-dash-space-depth 10) -(define number-nesting-depth 6) -(define current-prefix-out (make-parameter "<")) -(define current-prefix-in (make-parameter ">")) - -(define (as-spaces s) - (make-string (string-length s) #\space)) - -(define-struct prefix-entry (for-first for-rest)) - -(define prefixes (make-hash)) - -(define (lookup-prefix n label) - (hash-ref prefixes (cons n label) (lambda () #f))) - -(define (insert-prefix n label first rest) - (hash-set! prefixes (cons n label) (make-prefix-entry first rest))) - -(define (construct-prefixes level label) - (let loop ([n level] - [first (list label)] - [rest '(" ")]) - (if (>= n max-dash-space-depth) - (let-values ([(pre-first pre-rest) - (build-prefixes number-nesting-depth label)]) - (let ((s (number->string level))) - (values - (string-append pre-first "[" s "] ") - (string-append pre-rest " " (as-spaces s) " ")))) - (cond - [(= n 0) (values (apply string-append (reverse first)) - (apply string-append (reverse rest)))] - [(= n 1) (loop (- n 1) - (cons '" " first) - (cons '" " rest))] - [else (loop (- n 2) - (cons (format " ~a" label) first) - (cons " " rest))])))) - -(define (build-prefixes level label) - (let ([p (lookup-prefix level label)]) - (if p - (values (prefix-entry-for-first p) - (prefix-entry-for-rest p)) - (let-values (((first rest) - (construct-prefixes level label))) - (insert-prefix level label first rest) - (values first rest))))) - -(define current-trace-notify - (make-parameter (lambda (s) - (display s) - (newline)) - (lambda (p) - (unless (and (procedure? p) - (procedure-arity-includes? p 1)) - (raise-type-error 'current-trace-notify - "procedure (arity 1)" - p)) - p))) - -(define (as-trace-notify thunk) - (let ([p (open-output-bytes)]) - (parameterize ([current-output-port p]) - (thunk)) - (let ([b (get-output-bytes p #t 0 - ;; drop newline: - (sub1 (file-position p)))]) - ((current-trace-notify) (bytes->string/utf-8 b))))) - -(define -:trace-print-args - (lambda (name args kws kw-vals level) - (as-trace-notify - (lambda () - ((current-trace-print-args) name args kws kw-vals level))))) - -(define current-trace-print-args - (make-parameter - (lambda (name args kws kw-vals level) - (let-values (((first rest) - (build-prefixes level (current-prefix-in)))) - (parameterize ((pretty-print-print-line - (lambda (n port offset width) - (display - (if n - (if (zero? n) first - (format "~n~a" rest)) - (format "~n")) - port) - (if n - (if (zero? n) - (string-length first) - (string-length rest)) - 0)))) - (pretty-print (append (cons name args) - (apply append (map list kws kw-vals))))))))) - -(define -:trace-print-results - (lambda (name results level) - (as-trace-notify - (lambda () - (trace-print-results name results level))))) - -(define trace-print-results - (lambda (name results level) - (let-values (((first rest) - (build-prefixes level (current-prefix-out)))) - (parameterize ((pretty-print-print-line - (lambda (n port offset width) - (display - (if n - (if (zero? n) first - (format "~n~a" rest)) - (format "~n")) - port) - (if n - (if (zero? n) - (string-length first) - (string-length rest)) - 0)))) - (cond - ((null? results) - (pretty-display "*** no values ***")) - ((null? (cdr results)) - (pretty-print (car results))) - (else - (pretty-print (car results)) - (parameterize ((pretty-print-print-line - (lambda (n port offset width) - (display - (if n - (if (zero? n) rest - (format "~n~a" rest)) - (format "~n")) - port) - (if n - (string-length rest) - 0)))) - (for-each pretty-print (cdr results))))))))) - - -;; A traced-proc struct instance acts like a procedure, -;; but preserves the original, too. -(define-values (struct:traced-proc make-traced-proc traced-proc? traced-proc-ref traced-proc-set!) - (make-struct-type 'traced-proc #f 2 0 #f null (current-inspector) 0)) - -;; Install traced versions of a given set of procedures. The traced -;; versions are also given, so that they can be constructed to have -;; a nice name. -(define (do-trace ids procs setters traced-procs) - (for-each (lambda (id proc) - (unless (procedure? proc) - (error 'trace - "the value of ~s is not a procedure: ~e" id proc))) - ids procs) - (for-each (lambda (proc setter traced-proc) - (unless (traced-proc? proc) - (setter (make-traced-proc - (let-values ([(a) (procedure-arity proc)] - [(req allowed) (procedure-keywords proc)]) - (procedure-reduce-keyword-arity traced-proc - a - req - allowed)) - proc)))) - procs setters traced-procs)) - -;; Key used for a continuation mark to indicate -;; the nesting depth: -(define -:trace-level-key (gensym)) - -(define trace-call - (make-keyword-procedure - (lambda (id f kws vals . args) - (do-traced id args kws vals f)) - (lambda (id f . args) - (do-traced id args '() '() f)))) - -;; Apply a traced procedure to arguments, printing arguments -;; and results. We set and inspect the -:trace-level-key continuation -;; mark a few times to detect tail calls. -(define (do-traced id args kws kw-vals real-value) - (let* ([levels (continuation-mark-set->list - (current-continuation-marks) - -:trace-level-key)] - [level (if (null? levels) 0 (car levels))]) - ;; Tentatively push the new depth level: - (with-continuation-mark -:trace-level-key (add1 level) - ;; Check for tail-call => car of levels replaced, - ;; which means that the first two new marks are - ;; not consecutive: - (let ([new-levels (continuation-mark-set->list - (current-continuation-marks) - -:trace-level-key)]) - (if (and (pair? (cdr new-levels)) - (> (car new-levels) (add1 (cadr new-levels)))) - ;; Tail call: reset level and just call real-value. - ;; (This is in tail position to the call to `do-traced'.) - ;; We don't print the results, because the original - ;; call will. - (begin - (-:trace-print-args id args kws kw-vals (sub1 level)) - (with-continuation-mark -:trace-level-key (car levels) - (if (null? kws) - (apply real-value args) - (keyword-apply real-value kws kw-vals args)))) - ;; Not a tail call; push the old level, again, to ensure - ;; that when we push the new level, we have consecutive - ;; levels associated with the mark (i.e., set up for - ;; tail-call detection the next time around): - (begin - (-:trace-print-args id args kws kw-vals level) - (with-continuation-mark -:trace-level-key level - (call-with-values - (lambda () - (with-continuation-mark -:trace-level-key (add1 level) - (if (null? kws) - (apply real-value args) - (keyword-apply real-value kws kw-vals args)))) - (lambda results - (flush-output) - ;; Print the results: - (-:trace-print-results id results level) - ;; Return the results: - (apply values results)))))))))) - -(define-for-syntax (check-ids stx ids) - (for ([id (in-list (syntax->list ids))]) - (unless (identifier? id) - (raise-syntax-error #f "not an identifier" stx id))) - #t) - -(define-syntax (trace stx) - (syntax-case stx () - [(_ id ...) (check-ids stx #'(id ...)) - (with-syntax ([(tid ...) - (for/list ([id (in-list (syntax->list #'(id ...)))]) - (let ([tid (format "traced-~a" (syntax-e id))]) - (datum->syntax id (string->symbol tid) #f)))]) - #'(do-trace - '(id ...) - (list id ...) - (list (lambda (v) (set! id v)) ...) - (list (let* ([real-value id] - [tid (make-keyword-procedure - (lambda (kws vals . args) - (do-traced 'id args kws vals real-value)) - (lambda args - (do-traced 'id args null null real-value)))]) - tid) - ...)))])) - -(define-syntax (untrace stx) - (syntax-case stx () - [(_ id ...) (check-ids stx #'(id ...)) - #'(begin (when (traced-proc? id) - (set! id (traced-proc-ref id 1))) - ...)])) +(require racket/trace) +(provide (all-from-out racket/trace)) diff --git a/collects/mzlib/unit200.rkt b/collects/mzlib/unit200.rkt index 68e2e60..1106c77 100644 --- a/collects/mzlib/unit200.rkt +++ b/collects/mzlib/unit200.rkt @@ -6,6 +6,7 @@ syntax/stx syntax/name syntax/context + unstable/syntax "list.rkt" "private/unitidmap.rkt") @@ -73,11 +74,8 @@ (begin ;; Treat imports as internal-defn names: (syntax-local-bind-syntaxes ids #f def-ctx) - (cdr (syntax->list - (local-expand #`(stop #,@ids) - 'expression - (list #'stop) - def-ctx)))) + (syntax->list + (internal-definition-context-apply def-ctx ids))) ids) ;; Let later checking report an error: ids))]) diff --git a/collects/net/url-unit.rkt b/collects/net/url-unit.rkt index 8cb55bb..1efa32b 100644 --- a/collects/net/url-unit.rkt +++ b/collects/net/url-unit.rkt @@ -28,16 +28,14 @@ (make-parameter null (lambda (v) (unless (and (list? v) - (andmap - (lambda (v) - (and (list? v) - (= 3 (length v)) - (equal? (car v) "http") - (string? (car v)) - (number? (caddr v)) - (integer? (caddr v)) - (<= 1 (caddr v) 65535))) - v)) + (andmap (lambda (v) + (and (list? v) + (= 3 (length v)) + (equal? (car v) "http") + (string? (car v)) + (exact-integer? (caddr v)) + (<= 1 (caddr v) 65535))) + v)) (raise-type-error 'current-proxy-servers "list of list of scheme, string, and exact integer in [1,65535]" @@ -199,11 +197,7 @@ (string=? scheme "https")) (let ([port (http://getpost-impure-port get? url post-data strings)]) - (with-handlers ([void (lambda (exn) - (close-input-port port) - (raise exn))]) - (purify-port port)) - port)] + (purify-http-port port))] [(string=? scheme "file") (file://get-pure-port url)] [else (url-error "Scheme ~a unsupported" scheme)]))) @@ -324,6 +318,51 @@ #rx"^HTTP/.*?(?:\r\n\r\n|\n\n|\r\r)" port)]) (if m (read-string (cdar m) port) ""))) +;; purify-http-port : in-port -> in-port +(define (purify-http-port in-port) + (define-values (in-pipe out-pipe) (make-pipe)) + (thread + (λ () + (define status (http-read-status in-port)) + (define chunked? (http-read-headers in-port)) + (http-pipe-data chunked? in-port out-pipe))) + in-pipe) + +(define (http-read-status ip) + (read-line ip 'return-linefeed)) + +(define (http-read-headers ip) + (define l (read-line ip 'return-linefeed)) + (when (eof-object? l) + (error 'purify-http-port "Connection ended before headers ended")) + (if (string=? l "") + #f + (if (string=? l "Transfer-Encoding: chunked") + (begin (http-read-headers ip) + #t) + (http-read-headers ip)))) + +(define (http-pipe-data chunked? ip op) + (if chunked? + (http-pipe-chunk ip op) + (begin + (copy-port ip op) + (flush-output op) + (close-output-port op)))) + +(define (http-pipe-chunk ip op) + (define size-str (read-line ip 'return-linefeed)) + (define chunk-size (string->number size-str 16)) + (unless chunk-size + (error 'http-pipe-chunk "Could not parse ~S as hexadecimal number" size-str)) + (if (zero? chunk-size) + (begin (flush-output op) + (close-output-port op)) + (let* ([bs (read-bytes chunk-size ip)] + [crlf (read-bytes 2 ip)]) + (write-bytes bs op) + (http-pipe-chunk ip op)))) + (define character-set-size 256) ;; netscape/string->url : str -> url @@ -530,11 +569,7 @@ [(or (string=? scheme "http") (string=? scheme "https")) (let ([port (http://method-impure-port method url data strings)]) - (with-handlers ([void (lambda (exn) - (close-input-port port) - (raise exn))]) - (purify-port port)) - port)] + (purify-http-port port))] [(string=? scheme "file") (file://get-pure-port url)] [else (url-error "Scheme ~a unsupported" scheme)]))) diff --git a/collects/tests/racket/contract-mzlib-test.rktl b/collects/tests/racket/contract-mzlib-test.rktl index 61a3953..011562f 100644 --- a/collects/tests/racket/contract-mzlib-test.rktl +++ b/collects/tests/racket/contract-mzlib-test.rktl @@ -4521,7 +4521,7 @@ so that propagation occurs. (ctest #t contract-first-order-passes? (cons/c boolean? (-> integer? integer?)) (list* #t (λ (x) x))) - (ctest #t contract-first-order-passes? + (ctest #f contract-first-order-passes? (cons/c boolean? (-> integer? integer?)) (list* 1 2))