[racket-dev] [plt] Push #21179: master branch updated
One of the results of adding unsafe optimizations to match was that
Sam and I noticed there were no unsafe-mcar* (like unsafe-unbox*) that
shows there are no chaperones on mutable pairs.
Jay
On Mon, Oct 4, 2010 at 3:55 PM, <jay at racket-lang.org> wrote:
> jay has updated `master' from 2f56b23b21 to 0c47e572c0.
> http://git.racket-lang.org/plt/2f56b23b21..0c47e572c0
>
> =====[ 4 Commits ]======================================================
>
> Directory summary:
> 27.1% collects/racket/match/
> 3.5% collects/tests/match/
> 53.9% collects/web-server/scribblings/tutorial/examples/
> 14.5% collects/web-server/scribblings/tutorial/
>
> ~~~~~~~~~~
>
> 09fbfcf Jay McCarthy <jay at racket-lang.org> 2010-10-04 15:38
> :
> | Fixing pr11280
> :
> M collects/web-server/scribblings/tutorial/continue.scrbl | 52 +++---
> M collects/web-server/scribblings/tutorial/examples/model.rkt | 18 +-
> M .../scribblings/tutorial/examples/no-use-redirect.rkt | 4 +-
> M .../scribblings/tutorial/examples/use-redirect.rkt | 4 +-
> M .../web-server/scribblings/tutorial/examples/dummy-3.rkt | 8 +-
> M .../web-server/scribblings/tutorial/examples/iteration-1.rkt | 10 +-
> M .../web-server/scribblings/tutorial/examples/iteration-2.rkt | 14 +-
> M .../web-server/scribblings/tutorial/examples/iteration-3.rkt | 20 ++--
> M .../web-server/scribblings/tutorial/examples/iteration-4.rkt | 24 ++--
> M .../web-server/scribblings/tutorial/examples/iteration-5.rkt | 38 +++---
> M .../web-server/scribblings/tutorial/examples/iteration-6.rkt | 36 +++---
> M .../web-server/scribblings/tutorial/examples/iteration-7.rkt | 38 +++---
> M .../web-server/scribblings/tutorial/examples/iteration-8.rkt | 20 ++--
> M .../web-server/scribblings/tutorial/examples/model-2.rkt | 20 ++--
> M .../web-server/scribblings/tutorial/examples/model-3.rkt | 8 +-
>
> ~~~~~~~~~~
>
> 61441bb Jay McCarthy <jay at racket-lang.org> 2010-10-04 15:40
> :
> | Fixing pr11284
> :
> M collects/web-server/servlet-dispatch.rkt | 2 +-
>
> ~~~~~~~~~~
>
> 0965af6 Jay McCarthy <jay at racket-lang.org> 2010-10-04 15:43
> :
> | Adding some unsafe ops to the match compiler
> :
> M collects/racket/match/compiler.rkt | 13 +++++++------
>
> ~~~~~~~~~~
>
> 0c47e57 Jay McCarthy <jay at racket-lang.org> 2010-10-04 15:54
> :
> | Using unsafe operations in racket/match
> :
> M collects/racket/match/compiler.rkt | 3 +
> M collects/racket/match/parse-helper.rkt | 70 ++++++++++++++-------------
> M collects/racket/match/patterns.rkt | 3 +-
> M collects/tests/match/plt-match-tests.rkt | 12 +++++
>
> =====[ Overall Diff ]===================================================
>
> collects/racket/match/compiler.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/racket/match/compiler.rkt
> +++ NEW/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
> @@ -115,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)]))
>
> collects/racket/match/parse-helper.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/racket/match/parse-helper.rkt
> +++ NEW/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))))
>
> collects/racket/match/patterns.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/racket/match/patterns.rkt
> +++ NEW/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)
>
> collects/tests/match/plt-match-tests.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/tests/match/plt-match-tests.rkt
> +++ NEW/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
>
> collects/web-server/scribblings/tutorial/continue.scrbl
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/web-server/scribblings/tutorial/continue.scrbl
> +++ NEW/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:
>
> - at racketblock[(define-struct post (title body))]
> + at 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:
>
> - at racketblock[(define-struct blog (posts) #:mutable)]
> + at racketblock[(struct blog (posts) #:mutable)]
>
> - at defstruct[blog ([posts (listof post?)])]
> + at 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:
>
> - at defstruct[post ([title string?] [body string?] [comments (listof string?)]) #:mutable]
> + at 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:
>
> - at defstruct[blog ([home string?] [posts (listof post?)]) #:mutable]
> + at 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:
>
> - at defstruct[blog ([db sqlite:db?])]
> + at 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:
>
> - at defstruct[post ([blog blog?] [id integer?])]
> + at 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
>
> collects/web-server/scribblings/tutorial/examples/dummy-3.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/web-server/scribblings/tutorial/examples/dummy-3.rkt
> +++ NEW/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"))]
>
> collects/web-server/scribblings/tutorial/examples/iteration-1.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/web-server/scribblings/tutorial/examples/iteration-1.rkt
> +++ NEW/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)
>
> collects/web-server/scribblings/tutorial/examples/iteration-2.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/web-server/scribblings/tutorial/examples/iteration-2.rkt
> +++ NEW/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)
>
> collects/web-server/scribblings/tutorial/examples/iteration-3.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/web-server/scribblings/tutorial/examples/iteration-3.rkt
> +++ NEW/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
>
> collects/web-server/scribblings/tutorial/examples/iteration-4.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/web-server/scribblings/tutorial/examples/iteration-4.rkt
> +++ NEW/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
>
> collects/web-server/scribblings/tutorial/examples/iteration-5.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/web-server/scribblings/tutorial/examples/iteration-5.rkt
> +++ NEW/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)))
>
>
>
> collects/web-server/scribblings/tutorial/examples/iteration-6.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/web-server/scribblings/tutorial/examples/iteration-6.rkt
> +++ NEW/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
>
> collects/web-server/scribblings/tutorial/examples/iteration-7.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/web-server/scribblings/tutorial/examples/iteration-7.rkt
> +++ NEW/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
>
> collects/web-server/scribblings/tutorial/examples/iteration-8.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/web-server/scribblings/tutorial/examples/iteration-8.rkt
> +++ NEW/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
>
> collects/web-server/scribblings/tutorial/examples/model-2.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/web-server/scribblings/tutorial/examples/model-2.rkt
> +++ NEW/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
>
> collects/web-server/scribblings/tutorial/examples/model-3.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/web-server/scribblings/tutorial/examples/model-3.rkt
> +++ NEW/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
>
> collects/web-server/scribblings/tutorial/examples/model.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/web-server/scribblings/tutorial/examples/model.rkt
> +++ NEW/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.
>
> collects/web-server/scribblings/tutorial/examples/no-use-redirect.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/web-server/scribblings/tutorial/examples/no-use-redirect.rkt
> +++ NEW/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)
>
> collects/web-server/scribblings/tutorial/examples/use-redirect.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/web-server/scribblings/tutorial/examples/use-redirect.rkt
> +++ NEW/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)
>
> collects/web-server/servlet-dispatch.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/web-server/servlet-dispatch.rkt
> +++ NEW/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))])
>
--
Jay McCarthy <jay at cs.byu.edu>
Assistant Professor / Brigham Young University
http://teammccarthy.org/jay
"The glory of God is Intelligence" - D&C 93
![[logo]](/logo.png){kind=logo}