From 2189957b6fae75d8c3c4aa19b62a407bdc8865bf Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 4 Oct 2010 15:39:45 -0400 Subject: [PATCH 1/6] Change the errortrace protocol for `initialize-test-coverage-point' and `test-covered' to use just the expression -- looks like there's no reason to use an additional key. Also, change its uses to map each syntax to an mcons where its mcar is used to track coverage. This is done everywhere, since it turns out to be much faster to insert a `set-mcar!' with a 3d mpair, rather than a call to a thunk. Note that it still uses mpairs as a hack. It "works" in the same way that this simplified example does: (define-syntax m (let ([b (mcons 0 0)]) (lambda (stx) (with-syntax ([b b]) #'(case-lambda [() (mcar b)] [(x) (set-mcar! b x)]))))) I think that it's fragile, and likely to stop working at some point, but I don't see anything better for now. --- collects/deinprogramm/deinprogramm-langs.rkt | 24 ++-- collects/drracket/private/debug.rkt | 35 +++-- collects/errortrace/errortrace-lib.rkt | 8 +- .../errortrace/scribblings/errortrace.scrbl | 32 +++-- collects/errortrace/stacktrace.rkt | 25 ++-- collects/lang/htdp-langs.rkt | 23 ++-- collects/racket/private/sandbox-coverage.rkt | 125 +++++++++--------- 7 files changed, 141 insertions(+), 131 deletions(-) diff --git a/collects/deinprogramm/deinprogramm-langs.rkt b/collects/deinprogramm/deinprogramm-langs.rkt index ccdf1b64b7..8759c82758 100644 --- a/collects/deinprogramm/deinprogramm-langs.rkt +++ b/collects/deinprogramm/deinprogramm-langs.rkt @@ -1246,10 +1246,12 @@ ;; test coverage ;; + ;; WARNING: much code copied from "collects/lang/htdp-langs.rkt" + (define test-coverage-enabled (make-parameter #t)) (define current-test-coverage-info (make-thread-cell #f)) - (define (initialize-test-coverage-point key expr) + (define (initialize-test-coverage-point expr) (unless (thread-cell-ref current-test-coverage-info) (let ([ht (make-hasheq)]) (thread-cell-set! current-test-coverage-info ht) @@ -1272,15 +1274,19 @@ (send rep set-test-coverage-info ht on-sd off-sd #f))))))))) (let ([ht (thread-cell-ref current-test-coverage-info)]) (when ht - (hash-set! ht key (mcons #f expr))))) + (hash-set! ht expr #;(box #f) (mcons #f #f))))) - (define (test-covered key) - (let ([ht (thread-cell-ref current-test-coverage-info)]) - (and ht - (let ([v (hash-ref ht key)]) - (and v - (with-syntax ([v v]) - #'(set-mcar! v #t))))))) + (define (test-covered expr) + (let* ([ht (or (thread-cell-ref current-test-coverage-info) + (error 'deinprogramm-langs + "internal-error: no test-coverage table"))] + [v (hash-ref ht expr + (lambda () + (error 'deinprogramm-langs + "internal-error: expression not found: ~.s" + expr)))]) + #; (lambda () (set-box! v #t)) + (with-syntax ([v v]) #'(#%plain-app set-mcar! v #t)))) (define-values/invoke-unit et:stacktrace@ (import et:stacktrace-imports^) (export (prefix et: et:stacktrace^))) diff --git a/collects/drracket/private/debug.rkt b/collects/drracket/private/debug.rkt index c38d787b9c..d06a46621a 100644 --- a/collects/drracket/private/debug.rkt +++ b/collects/drracket/private/debug.rkt @@ -925,7 +925,7 @@ profile todo: (define current-test-coverage-info (make-thread-cell #f)) - (define (initialize-test-coverage-point key expr) + (define (initialize-test-coverage-point expr) (unless (hash? (thread-cell-ref current-test-coverage-info)) (let ([rep (drracket:rep:current-rep)]) (when rep @@ -938,14 +938,14 @@ profile todo: (when (hash? ht) ;; if rep isn't around, we don't do test coverage... ;; this can happen when check syntax expands, for example - (hash-set! ht key (mcons #f expr))))) + (hash-set! ht expr #;(box #f) (mcons #f #f))))) - (define (test-covered key) + (define (test-covered expr) (let ([ht (thread-cell-ref current-test-coverage-info)]) (and (hash? ht) ;; as in the `when' test in `initialize-test-coverage-point' - (let ([v (hash-ref ht key #f)]) - (and v - (λ () (set-mcar! v #t))))))) + (let ([v (hash-ref ht expr #f)]) + ;; (and v (λ () (set-box! v #t))) + (and v (with-syntax ([v v]) #'(#%plain-app set-mcar! v #t))))))) (define test-coverage-interactions-text<%> (interface () @@ -1075,7 +1075,6 @@ profile todo: [locked-ht (make-hasheq)] [already-frozen-ht (make-hasheq)] [actions-ht (make-hash)] - [on/syntaxes (hash-map ht (λ (_ pr) pr))] ;; can-annotate : (listof (list boolean srcloc)) ;; boolean is #t => code was run @@ -1083,17 +1082,17 @@ profile todo: ;; remove those that cannot be annotated [can-annotate (filter values - (map (λ (pr) - (let ([stx (mcdr pr)]) - (and (syntax? stx) - (let ([src (syntax-source stx)] - [pos (syntax-position stx)] - [span (syntax-span stx)]) - (and pos - span - (send (get-defs) port-name-matches? src) - (list (mcar pr) (make-srcloc (get-defs) #f #f pos span))))))) - on/syntaxes))] + (hash-map ht + (λ (stx covered?) + (and (syntax? stx) + (let ([src (syntax-source stx)] + [pos (syntax-position stx)] + [span (syntax-span stx)]) + (and pos + span + (send (get-defs) port-name-matches? src) + (list (mcar covered?) + (make-srcloc (get-defs) #f #f pos span))))))))] ;; filtered : (listof (list boolean srcloc)) ;; remove redundant expressions diff --git a/collects/errortrace/errortrace-lib.rkt b/collects/errortrace/errortrace-lib.rkt index 43fd6a364e..d7a11da398 100644 --- a/collects/errortrace/errortrace-lib.rkt +++ b/collects/errortrace/errortrace-lib.rkt @@ -66,7 +66,7 @@ ;; expressions with test suite coverage information. Returning the ;; first argument means no tests coverage information is collected. -;; test-coverage-point : syntax syntax -> (values syntax info) +;; test-coverage-point : syntax syntax integer -> (values syntax info) ;; sets a test coverage point for a single expression (define (test-coverage-point body expr phase) (if (and (test-coverage-enabled) (zero? phase)) @@ -240,10 +240,8 @@ (with-syntax ([key (datum->syntax #f key (quote-syntax here))] [expr expr] [register-executed-once register-executed-once]);<- 3D! - (syntax - (begin - (register-executed-once 'key) - expr)))) + #'(begin (register-executed-once 'key) + expr))) expr)) (define (get-execute-counts) diff --git a/collects/errortrace/scribblings/errortrace.scrbl b/collects/errortrace/scribblings/errortrace.scrbl index b7ee22db0e..9567e8d832 100644 --- a/collects/errortrace/scribblings/errortrace.scrbl +++ b/collects/errortrace/scribblings/errortrace.scrbl @@ -418,27 +418,31 @@ be wrapped.} Determines if the test coverage annotation is inserted into the code. This parameter controls how compilation happens---it does not affect the dynamic behavior of the already compiled code. If the parameter is set, -calls to @schemein[test-covered] are inserted into the code (and +code generated by @schemein[test-covered] are inserted into the code (and @schemein[initialize-test-coverage-point] is called during compilation). -If not, no calls to test-covered are inserted.} +If not, no calls to @scheme[test-covered] code are inserted.} -@defproc[(test-covered (key any/c)) (or/c (-> void?) syntax? #f)]{ -This is called during compilation of the program with a key value once - for each point with the key for that program point that was passed to +@defproc[(test-covered (stx any/c)) (or/c syntax? (-> void?) #f)]{ +This is called during compilation of the program with an expression for +each point in the program that was passed to @schemein[initialize-test-coverage-point]. -If the result is @scheme[#f], this program point is not -instrumented. If the result is syntax, it is inserted into the code, -and if it is a thunk, the thunk is inserted into the code in an -application. In either case, the syntax or the thunk should register -that the relevant point was covered.} +If the result is @scheme[#f], this program point is not instrumented. If +the result is syntax, it is inserted into the code, and if it is a +thunk, the thunk is inserted into the code in an application (using the +thunk directly, as a 3D value). In either case, the syntax or the thunk +should register that the relevant point was covered. -@defproc[(initialize-test-coverage-point (key any/c) (stx any/c)) void?]{ +Note: using a thunk tends to be slow. Current uses in the Racket code +will create a mutable pair in @scheme[initialize-test-coverage-point], +and @scheme[test-covered] returns syntax that will set its mcar. (This +makes the resulting overhead about 3 times smaller.)} + +@defproc[(initialize-test-coverage-point (stx any/c)) void?]{ During compilation of the program, this function is called with each -sub-expression of the program. The first argument is a special key -used to identify this program point. The second argument is the -syntax of this program point.} +sub-expression of the program. The argument is the syntax of this program +point, which is usually used as a key to identify this program point.} @defthing[profile-key any/c]{ diff --git a/collects/errortrace/stacktrace.rkt b/collects/errortrace/stacktrace.rkt index 2807ba70c4..8739af3e3e 100644 --- a/collects/errortrace/stacktrace.rkt +++ b/collects/errortrace/stacktrace.rkt @@ -85,20 +85,17 @@ (if (and (test-coverage-enabled) (zero? phase) (syntax-position expr)) - (let* ([key (gensym 'test-coverage-point)]) - (initialize-test-coverage-point key expr) - (let ([thunk (test-covered key)]) - (cond - [(procedure? thunk) - (with-syntax ([body body] - [thunk thunk]) - #'(begin (#%plain-app thunk) body))] - [(syntax? thunk) - (with-syntax ([body body] - [thunk thunk]) - #'(begin thunk body))] - [else - body]))) + (begin (initialize-test-coverage-point expr) + (let ([thunk (test-covered expr)]) + (cond [(procedure? thunk) + (with-syntax ([body body] + [thunk thunk]) + #'(begin (#%plain-app thunk) body))] + [(syntax? thunk) + (with-syntax ([body body] + [thunk thunk]) + #'(begin thunk body))] + [else body]))) body)) diff --git a/collects/lang/htdp-langs.rkt b/collects/lang/htdp-langs.rkt index 6c11906e74..a5ba78d5ae 100644 --- a/collects/lang/htdp-langs.rkt +++ b/collects/lang/htdp-langs.rkt @@ -1076,7 +1076,7 @@ (define test-coverage-enabled (make-parameter #t)) (define current-test-coverage-info (make-thread-cell #f)) - (define (initialize-test-coverage-point key expr) + (define (initialize-test-coverage-point expr) (unless (thread-cell-ref current-test-coverage-info) (let ([ht (make-hasheq)]) (thread-cell-set! current-test-coverage-info ht) @@ -1144,16 +1144,19 @@ (send rep set-test-coverage-info ht on-sd off-sd #f))))))))) (let ([ht (thread-cell-ref current-test-coverage-info)]) (when ht - (hash-set! ht key (mcons #f expr))))) + (hash-set! ht expr #;(box #f) (mcons #f #f))))) - (define (test-covered key) - (let* ([ht (thread-cell-ref current-test-coverage-info)] - [v (and ht (hash-ref ht key #f))]) - (with-syntax ([v v]) - #'(set-mcar! v #t)) - #; - (and v - (λ () (set-mcar! v #t))))) + (define (test-covered expr) + (let* ([ht (or (thread-cell-ref current-test-coverage-info) + (error 'htdp-langs + "internal-error: no test-coverage table"))] + [v (hash-ref ht expr + (lambda () + (error 'htdp-langs + "internal-error: expression not found: ~.s" + expr)))]) + #; (lambda () (set-box! v #t)) + (with-syntax ([v v]) #'(#%plain-app set-mcar! v #t)))) (define-values/invoke-unit et:stacktrace@ (import et:stacktrace-imports^) (export (prefix et: et:stacktrace^))) diff --git a/collects/racket/private/sandbox-coverage.rkt b/collects/racket/private/sandbox-coverage.rkt index 6b3e891ae4..9c121ecd25 100644 --- a/collects/racket/private/sandbox-coverage.rkt +++ b/collects/racket/private/sandbox-coverage.rkt @@ -1,70 +1,73 @@ ;; This file is is used in the context of sandboxed code, it uses the ;; stacktrace interface from errortrace to find uncovered expressions. -(module sandbox-coverage mzscheme - (require errortrace/stacktrace mzlib/unit mzlib/list) +#lang racket/base +(require errortrace/stacktrace racket/unit (for-template racket/base)) - ;; Test coverage run-time support - (define test-coverage-enabled (make-parameter #t)) - (define test-coverage-info (make-hash-table)) - (define (initialize-test-coverage-point key expr) - (hash-table-put! test-coverage-info key (mcons expr #f))) - (define (test-covered key) - (let ([mpair (hash-table-get test-coverage-info key)]) - (λ () (set-mcdr! mpair #t)))) +;; Test coverage run-time support +(define test-coverage-enabled (make-parameter #t)) +(define test-coverage-info (make-hasheq)) +(define (initialize-test-coverage-point expr) + (hash-set! test-coverage-info expr (mcons #f #f))) +(define (test-covered expr) + (let ([v (hash-ref test-coverage-info expr + (lambda () + (error 'sandbox-coverage + "internal error: no info for ~.s" expr)))]) + (and v (with-syntax ([v v]) #'(#%plain-app set-mcar! v #t))))) - (define (get-uncovered-expressions) - (let* ([xs (hash-table-map test-coverage-info (lambda (k v) - (cons (mcar v) (mcdr v))))] - [xs (filter (lambda (x) (syntax-position (car x))) xs)] - [xs (sort xs (lambda (x1 x2) - (let ([p1 (syntax-position (car x1))] - [p2 (syntax-position (car x2))]) - (or (< p1 p2) ; earlier first - (and (= p1 p2) - (> (syntax-span (car x1)) ; wider first - (syntax-span (car x2))))))))] - [xs (reverse xs)]) - (if (null? xs) - xs - (let loop ([xs (cdr xs)] [r (list (car xs))]) - (if (null? xs) - (map car (filter (lambda (x) (not (cdr x))) r)) - (loop (cdr xs) - (cond [(not (and (= (syntax-position (caar xs)) - (syntax-position (caar r))) - (= (syntax-span (caar xs)) - (syntax-span (caar r))))) - (cons (car xs) r)] - [(cdar r) r] - [else (cons (car xs) (cdr r))]))))))) +(define (get-uncovered-expressions) + (let* ([xs (hash-map test-coverage-info + (lambda (k v) (cons k (mcar v))))] + [xs (filter (lambda (x) (syntax-position (car x))) xs)] + [xs (sort xs (lambda (x1 x2) + (let ([p1 (syntax-position (car x1))] + [p2 (syntax-position (car x2))]) + (or (< p1 p2) ; earlier first + (and (= p1 p2) + (> (syntax-span (car x1)) ; wider first + (syntax-span (car x2))))))))] + [xs (reverse xs)]) + (if (null? xs) + xs + (let loop ([xs (cdr xs)] [r (list (car xs))]) + (if (null? xs) + (map car (filter (lambda (x) (not (cdr x))) r)) + (loop (cdr xs) + (cond [(not (and (= (syntax-position (caar xs)) + (syntax-position (caar r))) + (= (syntax-span (caar xs)) + (syntax-span (caar r))))) + (cons (car xs) r)] + [(cdar r) r] + [else (cons (car xs) (cdr r))]))))))) - (provide get-uncovered-expressions) +(provide get-uncovered-expressions) - ;; no profiling - (define profile-key #f) - (define profiling-enabled (lambda () #f)) - (define initialize-profile-point void) - (define register-profile-start void) - (define register-profile-done void) - ;; no marks - (define (with-mark mark expr) expr) +;; no profiling +(define profile-key #f) +(define profiling-enabled (lambda () #f)) +(define initialize-profile-point void) +(define register-profile-start void) +(define register-profile-done void) +;; no marks +(define (with-mark mark expr) expr) - (define-values/invoke-unit/infer stacktrace@) +(define-values/invoke-unit/infer stacktrace@) - (define errortrace-compile-handler - (let ([orig (current-compile)] - [ns (current-namespace)]) - (lambda (e immediate-eval?) - (orig (if (and (eq? ns (current-namespace)) - (not (compiled-expression? - (if (syntax? e) (syntax-e e) e)))) - (annotate-top - (expand-syntax (if (syntax? e) - e - (namespace-syntax-introduce - (datum->syntax-object #f e)))) - (namespace-base-phase)) - e) - immediate-eval?)))) +(define errortrace-compile-handler + (let ([orig (current-compile)] + [ns (current-namespace)]) + (lambda (e immediate-eval?) + (orig (if (and (eq? ns (current-namespace)) + (not (compiled-expression? + (if (syntax? e) (syntax-e e) e)))) + (annotate-top + (expand-syntax (if (syntax? e) + e + (namespace-syntax-introduce + (datum->syntax #f e)))) + (namespace-base-phase)) + e) + immediate-eval?)))) - (current-compile errortrace-compile-handler)) +(current-compile errortrace-compile-handler) From 2f56b23b212d41b566a3fb1e096bc1825bfcd631 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 4 Oct 2010 17:24:14 -0400 Subject: [PATCH 2/6] Some minor cleanup --- collects/errortrace/stacktrace.rkt | 126 ++++++++++++----------------- 1 file changed, 51 insertions(+), 75 deletions(-) diff --git a/collects/errortrace/stacktrace.rkt b/collects/errortrace/stacktrace.rkt index 8739af3e3e..6876aeeb0b 100644 --- a/collects/errortrace/stacktrace.rkt +++ b/collects/errortrace/stacktrace.rkt @@ -10,7 +10,7 @@ (with-mark test-coverage-enabled - test-covered + test-covered initialize-test-coverage-point profile-key @@ -73,30 +73,28 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Test case coverage instrumenter + ;; Test case coverage instrumenter - ;; The next procedure is called by `annotate' and `annotate-top' to wrap - ;; expressions with test suite coverage information. Returning the - ;; first argument means no tests coverage information is collected. + ;; The next procedure is called by `annotate' and `annotate-top' to wrap + ;; expressions with test suite coverage information. Returning the + ;; first argument means no tests coverage information is collected. - ;; test-coverage-point : syntax syntax phase -> syntax - ;; sets a test coverage point for a single expression - (define (test-coverage-point body expr phase) - (if (and (test-coverage-enabled) - (zero? phase) - (syntax-position expr)) - (begin (initialize-test-coverage-point expr) - (let ([thunk (test-covered expr)]) - (cond [(procedure? thunk) - (with-syntax ([body body] - [thunk thunk]) - #'(begin (#%plain-app thunk) body))] - [(syntax? thunk) - (with-syntax ([body body] - [thunk thunk]) - #'(begin thunk body))] - [else body]))) - body)) + ;; test-coverage-point : syntax syntax phase -> syntax + ;; sets a test coverage point for a single expression + (define (test-coverage-point body expr phase) + (if (and (test-coverage-enabled) + (zero? phase) + (syntax-position expr)) + (begin (initialize-test-coverage-point expr) + (let ([thunk (test-covered expr)]) + (cond [(procedure? thunk) + (with-syntax ([body body] [thunk thunk]) + #'(begin (#%plain-app thunk) body))] + [(syntax? thunk) + (with-syntax ([body body] [thunk thunk]) + #'(begin thunk body))] + [else body]))) + body)) @@ -224,39 +222,32 @@ (let ([p (syntax-property orig 'method-arity-error)] [p2 (syntax-property orig 'inferred-name)]) (let ([new (if p - (syntax-property new 'method-arity-error p) - new)]) + (syntax-property new 'method-arity-error p) + new)]) (if p2 (syntax-property new 'inferred-name p2) new)))) (define (annotate-let expr phase varss-stx rhss-stx bodys-stx) (let ([varss (syntax->list varss-stx)] - [rhss (syntax->list rhss-stx)] + [rhss (syntax->list rhss-stx)] [bodys (syntax->list bodys-stx)]) (let ([rhsl (map (lambda (vars rhs) (annotate-named - (syntax-case vars () - [(id) - (syntax id)] - [_else #f]) + (syntax-case vars () [(id) (syntax id)] [_else #f]) rhs phase)) varss rhss)] - [bodyl (map - (lambda (body) - (annotate body phase)) - bodys)]) + [bodyl (map (lambda (body) (annotate body phase)) + bodys)]) (rebuild expr (append (map cons bodys bodyl) (map cons rhss rhsl)))))) (define (annotate-seq expr bodys-stx annotate phase) (let* ([bodys (syntax->list bodys-stx)] - [bodyl (map (lambda (b) - (annotate b phase)) - bodys)]) + [bodyl (map (lambda (b) (annotate b phase)) bodys)]) (rebuild expr (map cons bodys bodyl)))) (define orig-inspector (current-code-inspector)) @@ -265,45 +256,30 @@ (syntax-recertify new orig orig-inspector #f)) (define (rebuild expr replacements) - (let loop ([expr expr] - [same-k (lambda () expr)] - [diff-k (lambda (x) x)]) + (let loop ([expr expr] [same-k (lambda () expr)] [diff-k (lambda (x) x)]) (let ([a (assq expr replacements)]) - (if a - (diff-k (cdr a)) - (cond - [(pair? expr) (loop (car expr) - (lambda () - (loop (cdr expr) - same-k - (lambda (y) - (diff-k (cons (car expr) y))))) - (lambda (x) - (loop (cdr expr) - (lambda () - (diff-k (cons x (cdr expr)))) - (lambda (y) - (diff-k (cons x y))))))] - [(vector? expr) - (loop (vector->list expr) - same-k - (lambda (x) (diff-k (list->vector x))))] - [(box? expr) (loop (unbox expr) - same-k - (lambda (x) - (diff-k (box x))))] - [(syntax? expr) (if (identifier? expr) - (same-k) - (loop (syntax-e expr) - same-k - (lambda (x) - (diff-k - (datum->syntax - expr - x - expr - expr)))))] - [else (same-k)]))))) + (cond + [a (diff-k (cdr a))] + [(pair? expr) + (loop (car expr) + (lambda () + (loop (cdr expr) same-k + (lambda (y) (diff-k (cons (car expr) y))))) + (lambda (x) + (loop (cdr expr) + (lambda () (diff-k (cons x (cdr expr)))) + (lambda (y) (diff-k (cons x y))))))] + [(vector? expr) + (loop (vector->list expr) same-k + (lambda (x) (diff-k (list->vector x))))] + [(box? expr) + (loop (unbox expr) same-k (lambda (x) (diff-k (box x))))] + [(syntax? expr) + (if (identifier? expr) + (same-k) + (loop (syntax-e expr) same-k + (lambda (x) (diff-k (datum->syntax expr x expr expr)))))] + [else (same-k)])))) (define (append-rebuild expr end) (cond From 09fbfcf5a91b5012963c4e84016bd418e692fc38 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 4 Oct 2010 15:38:56 -0600 Subject: [PATCH 3/6] Fixing pr11280 --- .../scribblings/tutorial/continue.scrbl | 52 +++++++++---------- .../scribblings/tutorial/examples/dummy-3.rkt | 8 +-- .../tutorial/examples/iteration-1.rkt | 10 ++-- .../tutorial/examples/iteration-2.rkt | 14 +++-- .../tutorial/examples/iteration-3.rkt | 20 +++---- .../tutorial/examples/iteration-4.rkt | 24 ++++----- .../tutorial/examples/iteration-5.rkt | 38 +++++++------- .../tutorial/examples/iteration-6.rkt | 36 ++++++------- .../tutorial/examples/iteration-7.rkt | 38 +++++++------- .../tutorial/examples/iteration-8.rkt | 20 +++---- .../scribblings/tutorial/examples/model-2.rkt | 20 +++---- .../scribblings/tutorial/examples/model-3.rkt | 8 +-- .../scribblings/tutorial/examples/model.rkt | 18 +++---- .../tutorial/examples/no-use-redirect.rkt | 4 +- .../tutorial/examples/use-redirect.rkt | 4 +- 15 files changed, 156 insertions(+), 158 deletions(-) diff --git a/collects/web-server/scribblings/tutorial/continue.scrbl b/collects/web-server/scribblings/tutorial/continue.scrbl index 240ba353f9..d77cc7c521 100644 --- a/collects/web-server/scribblings/tutorial/continue.scrbl +++ b/collects/web-server/scribblings/tutorial/continue.scrbl @@ -62,9 +62,9 @@ By the end of this tutorial, we'll have a simple blogging application. We start by considering our data definitions. We want to represent a list of posts. Let's say that a post is: -@racketblock[(define-struct post (title body))] +@racketblock[(struct post (title body))] -@(defstruct post ([title string?] [body string?])) +@(defstruct* post ([title string?] [body string?])) @bold{Exercise.} Make a few examples of posts. @@ -75,8 +75,8 @@ A blog, then, will be a list of posts: As a very simple example of a blog: @racketblock[ -(define BLOG (list (make-post "First Post!" - "Hey, this is my first post!"))) +(define BLOG (list (post "First Post!" + "Hey, this is my first post!"))) ] Now that we have a sample blog structure, let's get our web @@ -172,7 +172,7 @@ an @racket[html-response] representing that content. As an example, we want: @racketblock[ - (render-post (make-post "First post!" "This is a first post.")) + (render-post (post "First post!" "This is a first post.")) ] to produce: @@ -229,8 +229,8 @@ should produce: While @racketblock[ -(render-posts (list (make-post "Post 1" "Body 1") - (make-post "Post 2" "Body 2"))) +(render-posts (list (post "Post 1" "Body 1") + (post "Post 2" "Body 2"))) ] should produce: @@ -441,9 +441,9 @@ Earlier, we had said that a @racket[blog] was a list of @racket[post]s, but because we want to allow the blog to be changed, let's revisit our definition so that a blog is a mutable structure: -@racketblock[(define-struct blog (posts) #:mutable)] +@racketblock[(struct blog (posts) #:mutable)] -@defstruct[blog ([posts (listof post?)])] +@defstruct*[blog ([posts (listof post?)])] Mutable structures provide functions to change the fields of a structure; in this case, we now have a structure mutator called @@ -484,7 +484,7 @@ the same blog. Next, let's extend the application so that each post can hold a list of comments. We refine the data definition of a blog to be: -@defstruct[post ([title string?] [body string?] [comments (listof string?)]) #:mutable] +@defstruct*[post ([title string?] [body string?] [comments (listof string?)]) #:mutable] @bold{Exercise.} Write the updated data structure definition for posts. Make sure to make the structure mutable, since we intend to add comments to @@ -504,7 +504,7 @@ comments in an itemized list. @bold{Exercise.} Because we've extended a post to include comments, other post-manipulating parts of the application may need to be adjusted, -such as uses of @racket[make-post]. Identify and fix any other part of the +such as uses of @racket[post]. Identify and fix any other part of the application that needs to accommodate the post's new structure. @centerline{------------} @@ -736,8 +736,8 @@ between the model of our blog, and the web application that uses that model. Let's isolate the model: it's all the stuff near the top: @racketblock[ - (define-struct blog (posts) #:mutable) - (define-struct post (title body comments) #:mutable) + (struct blog (posts) #:mutable) + (struct post (title body comments) #:mutable) (define BLOG ...) (define (blog-insert-post! ...) ...) (define (post-insert-comment! ...) ...) @@ -794,7 +794,7 @@ started running---which is exactly what we want when restoring the blog data fro Our blog structure definition now looks like: @racketblock[ - (define-struct blog (posts) #:mutable #:prefab) + (struct blog (posts) #:mutable #:prefab) ] Now @racket[blog] structures can be read from the outside world with @racket[read] and written @@ -809,7 +809,7 @@ At this point, we @emph{can} read and write the blog to disk. Now let's actually First, we'll make a place to record in the model where the blog lives on disk. So, we need to change the blog structure again. Now it will be: -@defstruct[blog ([home string?] [posts (listof post?)]) #:mutable] +@defstruct*[blog ([home string?] [posts (listof post?)]) #:mutable] @bold{Exercise.} Write the new structure definition for blogs. @@ -820,14 +820,14 @@ Then, we'll make a function that allows our application to initialize the blog: @code:comment{Reads a blog from a path, if not present, returns default} (define (initialize-blog! home) (local [(define (log-missing-exn-handler exn) - (make-blog + (blog (path->string home) - (list (make-post "First Post" - "This is my first post" - (list "First comment!")) - (make-post "Second Post" - "This is another post" - (list))))) + (list (post "First Post" + "This is my first post" + (list "First comment!")) + (post "Second Post" + "This is another post" + (list))))) (define the-blog (with-handlers ([exn? log-missing-exn-handler]) (with-input-from-file home read)))] @@ -983,7 +983,7 @@ By adding a new comments table, we are more in accord with the relational style. A @racket[blog] structure will simply be a container for the database handle: -@defstruct[blog ([db sqlite:db?])] +@defstruct*[blog ([db sqlite:db?])] @bold{Exercise.} Write the @racket[blog] structure definition. (It does not need to be mutable or serializable.) @@ -993,7 +993,7 @@ We can now write the code to initialize a @racket[blog] structure: @code:comment{Sets up a blog database (if it doesn't exist)} (define (initialize-blog! home) (define db (sqlite:open home)) - (define the-blog (make-blog db)) + (define the-blog (blog db)) (with-handlers ([exn? void]) (sqlite:exec/ignore db (string-append @@ -1056,7 +1056,7 @@ However, we cannot tell from this structure what blog this posts belongs to, and therefore, what database; so, we could not extract the title or body values, since we do not know what to query. Therefore, we should associate the blog with each post: -@defstruct[post ([blog blog?] [id integer?])] +@defstruct*[post ([blog blog?] [id integer?])] @bold{Exercise.} Write the structure definition for posts. @@ -1067,7 +1067,7 @@ The only function that creates posts is @racket[blog-posts]: @code:comment{Queries for the post ids} (define (blog-posts a-blog) (local [(define (row->post a-row) - (make-post + (post a-blog (vector-ref a-row 0))) (define rows (sqlite:select diff --git a/collects/web-server/scribblings/tutorial/examples/dummy-3.rkt b/collects/web-server/scribblings/tutorial/examples/dummy-3.rkt index c18ee6451b..6e6a8a4066 100644 --- a/collects/web-server/scribblings/tutorial/examples/dummy-3.rkt +++ b/collects/web-server/scribblings/tutorial/examples/dummy-3.rkt @@ -3,17 +3,17 @@ ;; A blog is a (make-blog db) ;; where db is an sqlite database handle -(define-struct blog (db)) +(struct blog (db)) ;; A post is a (make-post blog id) ;; where blog is a blog and id is an integer? -(define-struct post (blog id)) +(struct post (blog id)) ;; initialize-blog! : path? -> blog? ;; Sets up a blog database (if it doesn't exist) (define (initialize-blog! home) (define db (sqlite:open home)) - (define the-blog (make-blog db)) + (define the-blog (blog db)) (with-handlers ([exn? void]) (sqlite:exec/ignore db (string-append @@ -35,7 +35,7 @@ ;; Queries for the post ids (define (blog-posts a-blog) (local [(define (row->post a-row) - (make-post a-blog (string->number (vector-ref a-row 0)))) + (post a-blog (string->number (vector-ref a-row 0)))) (define rows (sqlite:select (blog-db a-blog) "SELECT id FROM posts"))] diff --git a/collects/web-server/scribblings/tutorial/examples/iteration-1.rkt b/collects/web-server/scribblings/tutorial/examples/iteration-1.rkt index 76fa6d8630..54ebb4a53c 100644 --- a/collects/web-server/scribblings/tutorial/examples/iteration-1.rkt +++ b/collects/web-server/scribblings/tutorial/examples/iteration-1.rkt @@ -2,20 +2,20 @@ ;; A blog is a (listof post) ;; and a post is a (make-post title body) -(define-struct post (title body)) +(struct post (title body)) ;; BLOG: blog ;; The static blog. (define BLOG - (list (make-post "First Post" "This is my first post") - (make-post "Second Post" "This is another post"))) + (list (post "First Post" "This is my first post") + (post "Second Post" "This is another post"))) ;; start: request -> html-response ;; Consumes a request, and produces a page that displays all of the ;; web content. (define (start request) (render-blog-page BLOG request)) - + ;; render-blog-page: blog request -> html-response ;; Consumes a blog and a request, and produces an html-response page ;; of the content of the blog. @@ -23,7 +23,7 @@ `(html (head (title "My Blog")) (body (h1 "My Blog") ,(render-posts a-blog)))) - + ;; render-post: post -> html-response ;; Consumes a post, produces an html-response fragment of the post. (define (render-post a-post) diff --git a/collects/web-server/scribblings/tutorial/examples/iteration-2.rkt b/collects/web-server/scribblings/tutorial/examples/iteration-2.rkt index f33b3f30ab..cdb6ba9a30 100644 --- a/collects/web-server/scribblings/tutorial/examples/iteration-2.rkt +++ b/collects/web-server/scribblings/tutorial/examples/iteration-2.rkt @@ -2,13 +2,13 @@ ;; A blog is a (listof post) ;; and a post is a (make-post title body) -(define-struct post (title body)) +(struct post (title body)) ;; BLOG: blog ;; The static blog. (define BLOG - (list (make-post "First Post" "This is my first post") - (make-post "Second Post" "This is another post"))) + (list (post "First Post" "This is my first post") + (post "Second Post" "This is another post"))) ;; start: request -> html-response ;; Consumes a request and produces a page that displays all of the @@ -21,7 +21,7 @@ [else BLOG]))] (render-blog-page a-blog request))) - + ;; can-parse-post?: bindings -> boolean ;; Produces true if bindings contains values for 'title and 'body. @@ -33,8 +33,8 @@ ;; parse-post: bindings -> post ;; Consumes a bindings, and produces a post out of the bindings. (define (parse-post bindings) - (make-post (extract-binding/single 'title bindings) - (extract-binding/single 'body bindings))) + (post (extract-binding/single 'title bindings) + (extract-binding/single 'body bindings))) ;; render-blog-page: blog request -> html-response ;; Consumes a blog and a request, and produces an html-response page @@ -49,8 +49,6 @@ (input ((name "body"))) (input ((type "submit"))))))) - - ;; render-post: post -> html-response ;; Consumes a post, produces an html-response fragment of the post. (define (render-post a-post) diff --git a/collects/web-server/scribblings/tutorial/examples/iteration-3.rkt b/collects/web-server/scribblings/tutorial/examples/iteration-3.rkt index 882f4c41e9..15fdc5f728 100644 --- a/collects/web-server/scribblings/tutorial/examples/iteration-3.rkt +++ b/collects/web-server/scribblings/tutorial/examples/iteration-3.rkt @@ -2,25 +2,25 @@ ;; A blog is a (listof post) ;; and a post is a (make-post title body) -(define-struct post (title body)) +(struct post (title body)) ;; BLOG: blog ;; The static blog. (define BLOG - (list (make-post "First Post" "This is my first post") - (make-post "Second Post" "This is another post"))) + (list (post "First Post" "This is my first post") + (post "Second Post" "This is another post"))) ;; start: request -> html-response ;; Consumes a request and produces a page that displays all of the ;; web content. (define (start request) (render-blog-page BLOG request)) - + ;; parse-post: bindings -> post ;; Extracts a post out of the bindings. (define (parse-post bindings) - (make-post (extract-binding/single 'title bindings) - (extract-binding/single 'body bindings))) + (post (extract-binding/single 'title bindings) + (extract-binding/single 'body bindings))) ;; render-blog-page: blog request -> html-response ;; Consumes a blog and a request, and produces an html-response page @@ -33,16 +33,16 @@ ,(render-posts a-blog) (form ((action ,(make-url insert-post-handler))) - (input ((name "title"))) - (input ((name "body"))) - (input ((type "submit"))))))) + (input ((name "title"))) + (input ((name "body"))) + (input ((type "submit"))))))) (define (insert-post-handler request) (render-blog-page (cons (parse-post (request-bindings request)) a-blog) request))] - + (send/suspend/dispatch response-generator))) ;; render-post: post -> html-response diff --git a/collects/web-server/scribblings/tutorial/examples/iteration-4.rkt b/collects/web-server/scribblings/tutorial/examples/iteration-4.rkt index 3a5a766a57..d58660bd03 100644 --- a/collects/web-server/scribblings/tutorial/examples/iteration-4.rkt +++ b/collects/web-server/scribblings/tutorial/examples/iteration-4.rkt @@ -2,25 +2,25 @@ ;; A blog is a (make-blog posts) ;; where posts is a (listof post) -(define-struct blog (posts) #:mutable) +(struct blog (posts) #:mutable) ;; and post is a (make-post title body) ;; where title is a string, and body is a string -(define-struct post (title body)) +(struct post (title body)) ;; BLOG: blog ;; The initial BLOG. (define BLOG - (make-blog - (list (make-post "First Post" "This is my first post") - (make-post "Second Post" "This is another post")))) + (blog + (list (post "First Post" "This is my first post") + (post "Second Post" "This is another post")))) ;; blog-insert-post!: blog post -> void ;; Consumes a blog and a post, adds the post at the top of the blog. (define (blog-insert-post! a-blog a-post) (set-blog-posts! a-blog (cons a-post (blog-posts a-blog)))) - + ;; start: request -> html-response ;; Consumes a request and produces a page that displays ;; all of the web content. @@ -30,8 +30,8 @@ ;; parse-post: bindings -> post ;; Extracts a post out of the bindings. (define (parse-post bindings) - (make-post (extract-binding/single 'title bindings) - (extract-binding/single 'body bindings))) + (post (extract-binding/single 'title bindings) + (extract-binding/single 'body bindings))) ;; render-blog-page: request -> html-response ;; Produces an html-response page of the content of the BLOG. @@ -43,15 +43,15 @@ ,(render-posts) (form ((action ,(make-url insert-post-handler))) - (input ((name "title"))) - (input ((name "body"))) - (input ((type "submit"))))))) + (input ((name "title"))) + (input ((name "body"))) + (input ((type "submit"))))))) (define (insert-post-handler request) (blog-insert-post! BLOG (parse-post (request-bindings request))) (render-blog-page request))] - + (send/suspend/dispatch response-generator))) ;; render-post: post -> html-response diff --git a/collects/web-server/scribblings/tutorial/examples/iteration-5.rkt b/collects/web-server/scribblings/tutorial/examples/iteration-5.rkt index 807c0bea78..8263efdd8c 100644 --- a/collects/web-server/scribblings/tutorial/examples/iteration-5.rkt +++ b/collects/web-server/scribblings/tutorial/examples/iteration-5.rkt @@ -2,23 +2,23 @@ ;; A blog is a (make-blog posts) ;; where posts is a (listof post) -(define-struct blog (posts) #:mutable) +(struct blog (posts) #:mutable) ;; and post is a (make-post title body comments) ;; where title is a string, body is a string, ;; and comments is a (listof string) -(define-struct post (title body comments) #:mutable) +(struct post (title body comments) #:mutable) ;; BLOG: blog ;; The initial BLOG. (define BLOG - (make-blog - (list (make-post "First Post" - "This is my first post" - (list "First comment!")) - (make-post "Second Post" - "This is another post" - (list))))) + (blog + (list (post "First Post" + "This is my first post" + (list "First comment!")) + (post "Second Post" + "This is another post" + (list))))) ;; blog-insert-post!: blog post -> void ;; Consumes a blog and a post, adds the post at the top of the blog. @@ -52,22 +52,22 @@ ,(render-posts make-url) (form ((action ,(make-url insert-post-handler))) - (input ((name "title"))) - (input ((name "body"))) - (input ((type "submit"))))))) + (input ((name "title"))) + (input ((name "body"))) + (input ((type "submit"))))))) ;; parse-post: bindings -> post ;; Extracts a post out of the bindings. (define (parse-post bindings) - (make-post (extract-binding/single 'title bindings) - (extract-binding/single 'body bindings) - (list))) + (post (extract-binding/single 'title bindings) + (extract-binding/single 'body bindings) + (list))) (define (insert-post-handler request) (blog-insert-post! BLOG (parse-post (request-bindings request))) (render-blog-page request))] - + (send/suspend/dispatch response-generator))) ;; render-post-detail-page: post request -> html-response @@ -86,7 +86,7 @@ ,(make-url insert-comment-handler))) (input ((name "comment"))) (input ((type "submit"))))))) - + (define (parse-comment bindings) (extract-binding/single 'comment bindings)) @@ -94,8 +94,8 @@ (post-insert-comment! a-post (parse-comment (request-bindings a-request))) (render-post-detail-page a-post a-request))] - - + + (send/suspend/dispatch response-generator))) diff --git a/collects/web-server/scribblings/tutorial/examples/iteration-6.rkt b/collects/web-server/scribblings/tutorial/examples/iteration-6.rkt index aff791c8e8..0d9fa491e4 100644 --- a/collects/web-server/scribblings/tutorial/examples/iteration-6.rkt +++ b/collects/web-server/scribblings/tutorial/examples/iteration-6.rkt @@ -2,23 +2,23 @@ ;; A blog is a (make-blog posts) ;; where posts is a (listof post) -(define-struct blog (posts) #:mutable) +(struct blog (posts) #:mutable) ;; and post is a (make-post title body comments) ;; where title is a string, body is a string, ;; and comments is a (listof string) -(define-struct post (title body comments) #:mutable) +(struct post (title body comments) #:mutable) ;; BLOG: blog ;; The initial BLOG. (define BLOG - (make-blog - (list (make-post "First Post" - "This is my first post" - (list "First comment!")) - (make-post "Second Post" - "This is another post" - (list))))) + (blog + (list (post "First Post" + "This is my first post" + (list "First comment!")) + (post "Second Post" + "This is another post" + (list))))) ;; blog-insert-post!: blog post -> void ;; Consumes a blog and a post, adds the post at the top of the blog. @@ -52,22 +52,22 @@ ,(render-posts make-url) (form ((action ,(make-url insert-post-handler))) - (input ((name "title"))) - (input ((name "body"))) - (input ((type "submit"))))))) + (input ((name "title"))) + (input ((name "body"))) + (input ((type "submit"))))))) ;; parse-post: bindings -> post ;; Extracts a post out of the bindings. (define (parse-post bindings) - (make-post (extract-binding/single 'title bindings) - (extract-binding/single 'body bindings) - (list))) + (post (extract-binding/single 'title bindings) + (extract-binding/single 'body bindings) + (list))) (define (insert-post-handler request) (blog-insert-post! BLOG (parse-post (request-bindings request))) (render-blog-page request))] - + (send/suspend/dispatch response-generator))) ;; render-post-detail-page: post request -> html-response @@ -101,7 +101,7 @@ (define (back-handler request) (render-blog-page request))] - + (send/suspend/dispatch response-generator))) ;; render-confirm-add-comment-page : @@ -130,7 +130,7 @@ (define (cancel-handler request) (render-post-detail-page a-post request))] - + (send/suspend/dispatch response-generator))) ;; render-post: post (handler -> string) -> html-response diff --git a/collects/web-server/scribblings/tutorial/examples/iteration-7.rkt b/collects/web-server/scribblings/tutorial/examples/iteration-7.rkt index 451d15a3f4..2f395e269c 100644 --- a/collects/web-server/scribblings/tutorial/examples/iteration-7.rkt +++ b/collects/web-server/scribblings/tutorial/examples/iteration-7.rkt @@ -2,23 +2,23 @@ ;; A blog is a (make-blog posts) ;; where posts is a (listof post) -(define-struct blog (posts) #:mutable) +(struct blog (posts) #:mutable) ;; and post is a (make-post title body comments) ;; where title is a string, body is a string, ;; and comments is a (listof string) -(define-struct post (title body comments) #:mutable) +(struct post (title body comments) #:mutable) ;; BLOG: blog ;; The initial BLOG. (define BLOG - (make-blog - (list (make-post "First Post" - "This is my first post" - (list "First comment!")) - (make-post "Second Post" - "This is another post" - (list))))) + (blog + (list (post "First Post" + "This is my first post" + (list "First comment!")) + (post "Second Post" + "This is another post" + (list))))) ;; blog-insert-post!: blog post -> void ;; Consumes a blog and a post, adds the post at the top of the blog. @@ -52,22 +52,22 @@ ,(render-posts make-url) (form ((action ,(make-url insert-post-handler))) - (input ((name "title"))) - (input ((name "body"))) - (input ((type "submit"))))))) + (input ((name "title"))) + (input ((name "body"))) + (input ((type "submit"))))))) ;; parse-post: bindings -> post ;; Extracts a post out of the bindings. (define (parse-post bindings) - (make-post (extract-binding/single 'title bindings) - (extract-binding/single 'body bindings) - (list))) + (post (extract-binding/single 'title bindings) + (extract-binding/single 'body bindings) + (list))) (define (insert-post-handler request) (blog-insert-post! BLOG (parse-post (request-bindings request))) (render-blog-page (redirect/get)))] - + (send/suspend/dispatch response-generator))) ;; render-post-detail-page: post request -> html-response @@ -98,10 +98,10 @@ (parse-comment (request-bindings request)) a-post request)) - + (define (back-handler request) (render-blog-page request))] - + (send/suspend/dispatch response-generator))) ;; render-confirm-add-comment-page : @@ -130,7 +130,7 @@ (define (cancel-handler request) (render-post-detail-page a-post request))] - + (send/suspend/dispatch response-generator))) ;; render-post: post (handler -> string) -> html-response diff --git a/collects/web-server/scribblings/tutorial/examples/iteration-8.rkt b/collects/web-server/scribblings/tutorial/examples/iteration-8.rkt index 28520978d8..45fa7b3e25 100644 --- a/collects/web-server/scribblings/tutorial/examples/iteration-8.rkt +++ b/collects/web-server/scribblings/tutorial/examples/iteration-8.rkt @@ -19,22 +19,22 @@ ,(render-posts make-url) (form ((action ,(make-url insert-post-handler))) - (input ((name "title"))) - (input ((name "body"))) - (input ((type "submit"))))))) + (input ((name "title"))) + (input ((name "body"))) + (input ((type "submit"))))))) ;; parse-post: bindings -> post ;; Extracts a post out of the bindings. (define (parse-post bindings) - (make-post (extract-binding/single 'title bindings) - (extract-binding/single 'body bindings) - (list))) + (post (extract-binding/single 'title bindings) + (extract-binding/single 'body bindings) + (list))) (define (insert-post-handler request) (blog-insert-post! BLOG (parse-post (request-bindings request))) (render-blog-page (redirect/get)))] - + (send/suspend/dispatch response-generator))) ;; render-post-detail-page: post request -> html-response @@ -65,10 +65,10 @@ (parse-comment (request-bindings request)) a-post request)) - + (define (back-handler request) (render-blog-page request))] - + (send/suspend/dispatch response-generator))) ;; render-confirm-add-comment-page : @@ -97,7 +97,7 @@ (define (cancel-handler request) (render-post-detail-page a-post request))] - + (send/suspend/dispatch response-generator))) ;; render-post: post (handler -> string) -> html-response diff --git a/collects/web-server/scribblings/tutorial/examples/model-2.rkt b/collects/web-server/scribblings/tutorial/examples/model-2.rkt index 5cac68e31a..58260c2924 100644 --- a/collects/web-server/scribblings/tutorial/examples/model-2.rkt +++ b/collects/web-server/scribblings/tutorial/examples/model-2.rkt @@ -2,25 +2,25 @@ ;; A blog is a (make-blog home posts) ;; where home is a string, posts is a (listof post) -(define-struct blog (home posts) #:mutable #:prefab) +(struct blog (home posts) #:mutable #:prefab) ;; and post is a (make-post blog title body comments) ;; where title is a string, body is a string, ;; and comments is a (listof string) -(define-struct post (title body comments) #:mutable #:prefab) +(struct post (title body comments) #:mutable #:prefab) ;; initialize-blog! : path? -> blog ;; Reads a blog from a path, if not present, returns default (define (initialize-blog! home) (local [(define (log-missing-exn-handler exn) - (make-blog + (blog (path->string home) - (list (make-post "First Post" - "This is my first post" - (list "First comment!")) - (make-post "Second Post" - "This is another post" - (list))))) + (list (post "First Post" + "This is my first post" + (list "First comment!")) + (post "Second Post" + "This is another post" + (list))))) (define the-blog (with-handlers ([exn? log-missing-exn-handler]) (with-input-from-file home read)))] @@ -41,7 +41,7 @@ (define (blog-insert-post! a-blog title body) (set-blog-posts! a-blog - (cons (make-post title body empty) (blog-posts a-blog))) + (cons (post title body empty) (blog-posts a-blog))) (save-blog! a-blog)) ;; post-insert-comment!: blog post string -> void diff --git a/collects/web-server/scribblings/tutorial/examples/model-3.rkt b/collects/web-server/scribblings/tutorial/examples/model-3.rkt index 1729309951..ee30d332eb 100644 --- a/collects/web-server/scribblings/tutorial/examples/model-3.rkt +++ b/collects/web-server/scribblings/tutorial/examples/model-3.rkt @@ -3,17 +3,17 @@ ;; A blog is a (make-blog db) ;; where db is an sqlite database handle -(define-struct blog (db)) +(struct blog (db)) ;; A post is a (make-post blog id) ;; where blog is a blog and id is an integer? -(define-struct post (blog id)) +(struct post (blog id)) ;; initialize-blog! : path? -> blog? ;; Sets up a blog database (if it doesn't exist) (define (initialize-blog! home) (define db (sqlite:open home)) - (define the-blog (make-blog db)) + (define the-blog (blog db)) (with-handlers ([exn? void]) (sqlite:exec/ignore db (string-append @@ -35,7 +35,7 @@ ;; Queries for the post ids (define (blog-posts a-blog) (local [(define (row->post a-row) - (make-post + (post a-blog (vector-ref a-row 0))) (define rows (sqlite:select diff --git a/collects/web-server/scribblings/tutorial/examples/model.rkt b/collects/web-server/scribblings/tutorial/examples/model.rkt index 0219b20a77..c9676ab0f7 100644 --- a/collects/web-server/scribblings/tutorial/examples/model.rkt +++ b/collects/web-server/scribblings/tutorial/examples/model.rkt @@ -2,23 +2,23 @@ ;; A blog is a (make-blog posts) ;; where posts is a (listof post) -(define-struct blog (posts) #:mutable) +(struct blog (posts) #:mutable) ;; and post is a (make-post title body comments) ;; where title is a string, body is a string, ;; and comments is a (listof string) -(define-struct post (title body comments) #:mutable) +(struct post (title body comments) #:mutable) ;; BLOG: blog ;; The initial BLOG. (define BLOG - (make-blog - (list (make-post "First Post" - "This is my first post" - (list "First comment!")) - (make-post "Second Post" - "This is another post" - (list))))) + (blog + (list (post "First Post" + "This is my first post" + (list "First comment!")) + (post "Second Post" + "This is another post" + (list))))) ;; blog-insert-post!: blog post -> void ;; Consumes a blog and a post, adds the post at the top of the blog. diff --git a/collects/web-server/scribblings/tutorial/examples/no-use-redirect.rkt b/collects/web-server/scribblings/tutorial/examples/no-use-redirect.rkt index 59f172be78..ddf48c4eff 100644 --- a/collects/web-server/scribblings/tutorial/examples/no-use-redirect.rkt +++ b/collects/web-server/scribblings/tutorial/examples/no-use-redirect.rkt @@ -2,7 +2,7 @@ ;; A roster is a (make-roster names) ;; where names is a list of string. -(define-struct roster (names) #:mutable) +(struct roster (names) #:mutable) ;; roster-add-name!: roster string -> void ;; Given a roster and a name, adds the name @@ -12,7 +12,7 @@ (append (roster-names a-roster) (list a-name)))) -(define ROSTER (make-roster '("kathi" "shriram" "dan"))) +(define ROSTER (roster '("kathi" "shriram" "dan"))) ;; start: request -> html-response (define (start request) diff --git a/collects/web-server/scribblings/tutorial/examples/use-redirect.rkt b/collects/web-server/scribblings/tutorial/examples/use-redirect.rkt index b69ea84f53..7d3fc30e8a 100644 --- a/collects/web-server/scribblings/tutorial/examples/use-redirect.rkt +++ b/collects/web-server/scribblings/tutorial/examples/use-redirect.rkt @@ -2,7 +2,7 @@ ;; A roster is a (make-roster names) ;; where names is a list of string. -(define-struct roster (names) #:mutable) +(struct roster (names) #:mutable) ;; roster-add-name!: roster string -> void ;; Given a roster and a name, adds the name @@ -12,7 +12,7 @@ (append (roster-names a-roster) (list a-name)))) -(define ROSTER (make-roster '("kathi" "shriram" "dan"))) +(define ROSTER (roster '("kathi" "shriram" "dan"))) ;; start: request -> html-response (define (start request) From 61441bba8f04a84aa003150dc8b463b1dc9287e7 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 4 Oct 2010 15:40:58 -0600 Subject: [PATCH 4/6] Fixing pr11284 --- collects/web-server/servlet-dispatch.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/web-server/servlet-dispatch.rkt b/collects/web-server/servlet-dispatch.rkt index 251f0830d3..2e063e5824 100644 --- a/collects/web-server/servlet-dispatch.rkt +++ b/collects/web-server/servlet-dispatch.rkt @@ -135,7 +135,7 @@ (if launch-path (string-append server-url launch-path) server-url)) - (printf "Click 'Stop' at any time to terminate the Web Server.\n")) + (printf "Stop this program at any time to terminate the Web Server.\n")) (let ([bye (lambda () (when banner? (printf "\nWeb Server stopped.\n")) (shutdown-server))]) From 0965af6c690583ca1641e8250145e3909e671bd8 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 4 Oct 2010 15:43:36 -0600 Subject: [PATCH 5/6] Adding some unsafe ops to the match compiler --- collects/racket/match/compiler.rkt | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/collects/racket/match/compiler.rkt b/collects/racket/match/compiler.rkt index 9f422e0794..c32a4e12fe 100644 --- a/collects/racket/match/compiler.rkt +++ b/collects/racket/match/compiler.rkt @@ -1,6 +1,6 @@ #lang scheme/base -(require (for-template scheme/base "runtime.rkt" scheme/stxparam) +(require (for-template scheme/base "runtime.rkt" scheme/stxparam racket/unsafe/ops) syntax/boundmap syntax/stx "patterns.rkt" @@ -60,12 +60,13 @@ #`[(pred #,x) (let ([tmps (accs #,x)] ...) body)])) (cond [(eq? 'box k) - (compile-con-pat (list #'unbox) #'box? (compose list Box-p))] + (compile-con-pat (list #'unsafe-unbox*) #'box? (compose list Box-p))] [(eq? 'pair k) - (compile-con-pat (list #'car #'cdr) #'pair? + (compile-con-pat (list #'unsafe-car #'unsafe-cdr) #'pair? (lambda (p) (list (Pair-a p) (Pair-d p))))] [(eq? 'mpair k) - (compile-con-pat (list #'mcar #'mcdr) #'mpair? + ; XXX These should be unsafe-mcar* when mpairs have chaperones + (compile-con-pat (list #'unsafe-mcar #'unsafe-mcdr) #'mpair? (lambda (p) (list (MPair-a p) (MPair-d p))))] [(eq? 'string k) (constant-pat #'string?)] [(eq? 'number k) (constant-pat #'number?)] @@ -104,10 +105,10 @@ esc)] [(n ...) ns]) #`[(#,arity) - (let ([tmps (vector-ref #,x n)] ...) + (let ([tmps (unsafe-vector*-ref #,x n)] ...) body)]))))])]) #`[(vector? #,x) - (case (vector-length #,x) + (case (unsafe-vector*-length #,x) clauses ... [else (#,esc)])])] ;; it's a structure From 0c47e572c012b8bcdc0f67a9cc9800e8955c62bf Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 4 Oct 2010 15:54:05 -0600 Subject: [PATCH 6/6] Using unsafe operations in racket/match --- collects/racket/match/compiler.rkt | 3 + collects/racket/match/parse-helper.rkt | 70 +++++++++++++----------- collects/racket/match/patterns.rkt | 3 +- collects/tests/match/plt-match-tests.rkt | 12 ++++ 4 files changed, 54 insertions(+), 34 deletions(-) diff --git a/collects/racket/match/compiler.rkt b/collects/racket/match/compiler.rkt index c32a4e12fe..533d877405 100644 --- a/collects/racket/match/compiler.rkt +++ b/collects/racket/match/compiler.rkt @@ -116,6 +116,9 @@ ;; all the rows are structures with the same predicate (let* ([s (Row-first-pat (car rows))] [accs (Struct-accessors s)] + [accs (if (Struct-complete? s) + (build-list (length accs) (λ (i) #`(λ (x) (unsafe-struct*-ref x #,i)))) + accs)] [pred (Struct-pred s)]) (compile-con-pat accs pred Struct-ps))] [else (error 'match-compile "bad key: ~a" k)])) diff --git a/collects/racket/match/parse-helper.rkt b/collects/racket/match/parse-helper.rkt index 3d45825914..5b7f3bfa79 100644 --- a/collects/racket/match/parse-helper.rkt +++ b/collects/racket/match/parse-helper.rkt @@ -85,43 +85,47 @@ (let ([super (list-ref (extract-struct-info (syntax-local-value struct-name)) 5)]) - (cond [(equal? super #t) '()] ;; no super type exists - [(equal? super #f) '()] ;; super type is unknown - [else (cons super (get-lineage super))]))) + (cond [(equal? super #t) (values #t '())] ;; no super type exists + [(equal? super #f) (values #f '())] ;; super type is unknown + [else + (let-values ([(complete? lineage) (get-lineage super)]) + (values complete? + (cons super lineage)))]))) (unless pred (raise-syntax-error 'match (format "structure ~a does not have an associated predicate" (syntax->datum struct-name)) stx struct-name)) - (let* (;; the accessors come in reverse order - [acc (reverse acc)] - ;; remove the first element, if it's #f - [acc (cond [(null? acc) acc] - [(not (car acc)) (cdr acc)] - [else acc])]) - (make-Struct pred - (syntax-property - pred - 'disappeared-use (list struct-name)) - (get-lineage (cert struct-name)) - acc - (cond [(eq? '_ (syntax-e pats)) - (map make-Dummy acc)] - [(syntax->list pats) - => - (lambda (ps) - (unless (= (length ps) (length acc)) - (raise-syntax-error - 'match - (format "~a structure ~a: expected ~a but got ~a" - "wrong number for fields for" - (syntax->datum struct-name) (length acc) - (length ps)) - stx pats)) - (map parse ps))] - [else (raise-syntax-error - 'match - "improper syntax for struct pattern" - stx pats)])))))) + (let-values ([(complete? lineage) (get-lineage (cert struct-name))]) + (let* (;; the accessors come in reverse order + [acc (reverse acc)] + ;; remove the first element, if it's #f + [acc (cond [(null? acc) acc] + [(not (car acc)) (cdr acc)] + [else acc])]) + (make-Struct pred + (syntax-property + pred + 'disappeared-use (list struct-name)) + lineage complete? + acc + (cond [(eq? '_ (syntax-e pats)) + (map make-Dummy acc)] + [(syntax->list pats) + => + (lambda (ps) + (unless (= (length ps) (length acc)) + (raise-syntax-error + 'match + (format "~a structure ~a: expected ~a but got ~a" + "wrong number for fields for" + (syntax->datum struct-name) (length acc) + (length ps)) + stx pats)) + (map parse ps))] + [else (raise-syntax-error + 'match + "improper syntax for struct pattern" + stx pats)]))))))) (define (trans-match pred transformer pat) (make-And (list (make-Pred pred) (make-App transformer pat)))) diff --git a/collects/racket/match/patterns.rkt b/collects/racket/match/patterns.rkt index 9ba024c964..0b562ff57a 100644 --- a/collects/racket/match/patterns.rkt +++ b/collects/racket/match/patterns.rkt @@ -55,9 +55,10 @@ ;; pred is an identifier ;; super is an identifier, or #f +;; complete? is a boolean ;; accessors is a listof identifiers (NB in reverse order from the struct info) ;; ps is a listof patterns -(define-struct (Struct CPat) (id pred super accessors ps) #:transparent) +(define-struct (Struct CPat) (id pred super complete? accessors ps) #:transparent) ;; both fields are lists of pats (define-struct (HashTable CPat) (key-pats val-pats) #:transparent) diff --git a/collects/tests/match/plt-match-tests.rkt b/collects/tests/match/plt-match-tests.rkt index a8b9b14657..ffd23cd20a 100644 --- a/collects/tests/match/plt-match-tests.rkt +++ b/collects/tests/match/plt-match-tests.rkt @@ -179,6 +179,18 @@ (else #f))) (check-true (origin? (make-point 0 0))) (check-false (origin? (make-point 1 1))))) + ; This test ensures that the unsafe struct optimization is correct + (test-case "struct patterns (with opaque parent)" + (let () + (define-struct opq (any)) + (parameterize ([current-inspector (make-sibling-inspector)]) + (define-struct point (x y) #:super struct:opq) + (define (origin? pt) + (match pt + ((struct point (0 0)) #t) + (else #f))) + (check-true (origin? (make-point 'a 0 0))) + (check-false (origin? (make-point 'a 1 1)))))) )) (define nonlinear-tests