Merge branch 'master' of git://factorcode.org/git/factor

basis/bootstrap/image/image.factor

@@ -417,7 +417,7 @@ M: quotation '
     } [ [ bootstrap-word ] [ get ] bi ] H{ } map>assoc
     {
         class<=-cache class-not-cache classes-intersect-cache
-        class-and-cache class-or-cache
+        class-and-cache class-or-cache next-method-quot-cache
     } [ H{ } clone ] H{ } map>assoc assoc-union
     bootstrap-global set
     bootstrap-global emit-userenv ;

basis/http/client/client-docs.factor

@@ -39,11 +39,21 @@ HELP: http-post
 { $description "Submits a form at a URL." }
 { $errors "Throws an error if the HTTP request fails." } ;
 
+HELP: with-http-get
+{ $values { "url" "a " { $link url } " or " { $link string } } { "quot" "a quotation with stack effect " { $snippet "( chunk -- )" } } { "response" response } }
+{ $description "Downloads the contents of a URL. Chunks of data are passed to the quotation as they are read." }
+{ $errors "Throws an error if the HTTP request fails." } ;
+
 HELP: http-request
 { $values { "request" request } { "response" response } { "data" sequence } }
 { $description "Sends an HTTP request to an HTTP server, and reads the response." }
 { $errors "Throws an error if the HTTP request fails." } ;
 
+HELP: with-http-request
+{ $values { "request" request } { "quot" "a quotation with stack effect " { $snippet "( chunk -- )" } } { "response" response } }
+{ $description "Sends an HTTP request to an HTTP server, and reads the response incrementally. Chunks of data are passed to the quotation as they are read." }
+{ $errors "Throws an error if the HTTP request fails." } ;
+
 ARTICLE: "http.client.get" "GET requests with the HTTP client"
 "Basic usage involves passing a " { $link url } " and getting a " { $link response } " and data back:"
 { $subsection http-get }
@@ -52,7 +62,10 @@ ARTICLE: "http.client.get" "GET requests with the HTTP client"
 { $subsection download-to }
 "Advanced usage involves constructing a " { $link request } ", which allows " { $link "http.cookies" } " and " { $link "http.headers" } " to be set:"
 { $subsection <get-request> }
-{ $subsection http-request } ;
+{ $subsection http-request }
+"The " { $link http-get } " and " { $link http-request } " words output sequences. This is undesirable if the response data may be large. Another pair of words take a quotation instead, and pass the quotation chunks of data incrementally:"
+{ $subsection with-http-get }
+{ $subsection with-http-request } ;
 
 ARTICLE: "http.client.post" "POST requests with the HTTP client"
 "As with GET requests, there is a high-level word which takes a " { $link url } " and a lower-level word which constructs an HTTP request object which can be passed to " { $link http-request } ":"

basis/http/client/client-tests.factor

@@ -1,5 +1,8 @@
 USING: http.client http.client.private http tools.test
 namespaces urls ;
+
+\ download must-infer
+
 [ "localhost" f ] [ "localhost" parse-host ] unit-test
 [ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
 

basis/http/client/client.factor

@@ -3,7 +3,7 @@
 USING: accessors assocs kernel math math.parser namespaces make
 sequences io io.sockets io.streams.string io.files io.timeouts
 strings splitting calendar continuations accessors vectors
-math.order hashtables byte-arrays prettyprint
+math.order hashtables byte-arrays prettyprint destructors
 io.encodings
 io.encodings.string
 io.encodings.ascii
@@ -88,72 +88,92 @@ M: too-many-redirects summary
     drop
     [ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ;
 
-DEFER: (http-request)
-
 <PRIVATE
 
+DEFER: (with-http-request)
+
 SYMBOL: redirects
 
 : redirect-url ( request url -- request )
     '[ _ >url derive-url ensure-port ] change-url ;
 
-: do-redirect ( response data -- response data )
-    over code>> 300 399 between? [
-        drop
-        redirects inc
-        redirects get max-redirects < [
-            request get
-            swap "location" header redirect-url
-            "GET" >>method (http-request)
-        ] [
-            too-many-redirects
-        ] if
-    ] when ;
+: redirect? ( response -- ? )
+    code>> 300 399 between? ;
 
-PRIVATE>
+: do-redirect ( quot: ( chunk -- ) response -- response )
+    redirects inc
+    redirects get max-redirects < [
+        request get clone
+        swap "location" header redirect-url
+        "GET" >>method swap (with-http-request)
+    ] [ too-many-redirects ] if ; inline recursive
 
 : read-chunk-size ( -- n )
     read-crlf ";" split1 drop [ blank? ] trim-right
     hex> [ "Bad chunk size" throw ] unless* ;
 
-: read-chunks ( -- )
+: read-chunked ( quot: ( chunk -- ) -- )
     read-chunk-size dup zero?
-    [ drop ] [ read % read-crlf B{ } assert= read-chunks ] if ;
+    [ 2drop ] [
+        read [ swap call ] [ drop ] 2bi
+        read-crlf B{ } assert= read-chunked
+    ] if ; inline recursive
 
-: read-response-body ( response -- response data )
-    dup "transfer-encoding" header "chunked" = [
-        binary decode-input
-        [ read-chunks ] B{ } make
-        over content-charset>> decode
-    ] [
-        dup content-charset>> decode-input
-        input-stream get contents
-    ] if ;
+: read-unchunked ( quot: ( chunk -- ) -- )
+    8192 read dup [
+        [ swap call ] [ drop read-unchunked ] 2bi
+    ] [ 2drop ] if ; inline recursive
 
-: (http-request) ( request -- response data )
-    dup request [
-        dup url>> url-addr ascii [
-            1 minutes timeouts
-            write-request
-            read-response
-            read-response-body
-        ] with-client
-        do-redirect
-    ] with-variable ;
+: read-response-body ( quot response -- )
+    binary decode-input
+    "transfer-encoding" header "chunked" =
+    [ read-chunked ] [ read-unchunked ] if ; inline
+
+: <request-socket> ( -- stream )
+    request get url>> url-addr ascii <client> drop
+    1 minutes over set-timeout ;
+
+: (with-http-request) ( request quot: ( chunk -- ) -- response )
+    swap
+    request [
+        <request-socket> [
+            [
+                out>>
+                [ request get write-request ]
+                with-output-stream*
+            ] [
+                in>> [
+                    read-response dup redirect? [ t ] [
+                        [ nip response set ]
+                        [ read-response-body ]
+                        [ ]
+                        2tri f
+                    ] if
+                ] with-input-stream*
+            ] bi
+        ] with-disposal
+        [ do-redirect ] [ nip ] if
+    ] with-variable ; inline recursive
+
+PRIVATE>
 
 : success? ( code -- ? ) 200 = ;
 
-ERROR: download-failed response body ;
+ERROR: download-failed response ;
 
 M: download-failed error.
-    "HTTP download failed:" print nl
-    [ response>> . nl ] [ body>> write ] bi ;
+    "HTTP request failed:" print nl
+    response>> . ;
 
-: check-response ( response data -- response data )
-    over code>> success? [ download-failed ] unless ;
+: check-response ( response -- response )
+    dup code>> success? [ download-failed ] unless ;
+
+: with-http-request ( request quot -- response )
+    (with-http-request) check-response ; inline
 
 : http-request ( request -- response data )
-    (http-request) check-response ;
+    [ [ % ] with-http-request ] B{ } make
+    over content-charset>> decode ;
 
 : <get-request> ( url -- request )
     <request>
@@ -163,14 +183,14 @@ M: download-failed error.
 : http-get ( url -- response data )
     <get-request> http-request ;
 
+: with-http-get ( url quot -- response )
+    [ <get-request> ] dip with-http-request ; inline
+
 : download-name ( url -- name )
     present file-name "?" split1 drop "/" ?tail drop ;
 
 : download-to ( url file -- )
-    #! Downloads the contents of a URL to a file.
-    swap http-get
-    [ content-charset>> ] [ '[ _ write ] ] bi*
-    with-file-writer ;
+    binary [ [ write ] with-http-get drop ] with-file-writer ;
 
 : download ( url -- )
     dup download-name download-to ;

basis/http/server/static/static-docs.factor

@@ -19,11 +19,7 @@ HELP: enable-fhtml
 { $notes "See " { $link "html.templates.fhtml" } "." }
 { $side-effects "responder" } ;
 
-ARTICLE: "http.server.static" "Serving static content"
-"The " { $vocab-link "http.server.static" } " vocabulary implements a responder for serving static files."
-{ $subsection <static> }
-"The static responder does not serve directory listings by default, as a security measure. Directory listings can be enabled by storing a true value in the " { $slot "allow-listings" } " slot."
-$nl
+ARTICLE: "http.server.static.extend" "Hooks for dynamic content"
 "The static responder can be extended for dynamic content by associating quotations with MIME types in the hashtable stored in the " { $slot "special" } " slot. The quotations have stack effect " { $snippet "( path -- )" } "."
 $nl
 "A utility word uses the above feature to enable server-side " { $snippet ".fhtml" } " scripts, allowing a development style much like PHP:"
@@ -34,4 +30,17 @@ $nl
 { $subsection <file-responder> }
 "The default just sends the file's contents with the request; " { $vocab-link "xmode.code2html.responder" } " provides an alternate hook which sends a syntax-highlighted version of the file." ;
 
+ARTICLE: "http.server.static" "Serving static content"
+"The " { $vocab-link "http.server.static" } " vocabulary implements a responder for serving static files."
+{ $subsection <static> }
+"The static responder does not serve directory listings by default, as a security measure. Directory listings can be enabled by storing a true value in the " { $slot "allow-listings" } " slot."
+$nl
+"If all you want to do is serve files from a directory, the following phrase does the trick:"
+{ $code
+    "USING: namespaces http.server http.server.static ;"
+    "/var/www/mysite.com/ <static> main-responder set"
+    "8080 httpd"
+}
+{ $subsection "http.server.static.extend" } ;
+
 ABOUT: "http.server.static"

basis/http/server/static/static.factor

@@ -3,7 +3,7 @@
 USING: calendar io io.files kernel math math.order
 math.parser namespaces parser sequences strings
 assocs hashtables debugger mime-types sorting logging
-calendar.format accessors
+calendar.format accessors splitting
 io.encodings.binary fry xml.entities destructors urls
 html.elements html.templates.fhtml
 http
@@ -14,9 +14,13 @@ IN: http.server.static
 
 TUPLE: file-responder root hook special allow-listings ;
 
+: modified-since ( request -- date )
+    "if-modified-since" header ";" split1 drop
+    dup [ rfc822>timestamp ] when ;
+
 : modified-since? ( filename -- ? )
-    request get "if-modified-since" header dup [
-        [ file-info modified>> ] [ rfc822>timestamp ] bi* after?
+    request get modified-since dup [
+        [ file-info modified>> ] dip after?
     ] [
         2drop t
     ] if ;

basis/ui/gadgets/worlds/worlds.factor

@@ -101,10 +101,10 @@ world H{
     { T{ key-down f { C+ } "c" } [ T{ copy-action } send-action ] }
     { T{ key-down f { C+ } "v" } [ T{ paste-action } send-action ] }
     { T{ key-down f { C+ } "a" } [ T{ select-all-action } send-action ] }
-    { T{ button-down f { C+ } 1 } [ T{ button-down f f 3 } swap resend-button-down ] }
-    { T{ button-down f { A+ } 1 } [ T{ button-down f f 2 } swap resend-button-down ] }
-    { T{ button-up f { C+ } 1 } [ T{ button-up f f 3 } swap resend-button-up ] }
-    { T{ button-up f { A+ } 1 } [ T{ button-up f f 2 } swap resend-button-up ] }
+    { T{ button-down f { C+ } 1 } [ drop T{ button-down f f 3 } button-gesture ] }
+    { T{ button-down f { A+ } 1 } [ drop T{ button-down f f 2 } button-gesture ] }
+    { T{ button-up f { C+ } 1 } [ drop T{ button-up f f 3 } button-gesture ] }
+    { T{ button-up f { A+ } 1 } [ drop T{ button-up f f 2 } button-gesture ] }
 } set-gestures
 
 : close-global ( world global -- )

basis/ui/gestures/gestures.factor

@@ -249,12 +249,6 @@ SYMBOL: drag-timer
 : send-action ( world gesture -- )
     swap world-focus send-gesture drop ;
 
-: resend-button-down ( gesture world -- )
-    hand-loc get-global swap send-button-down ;
-
-: resend-button-up  ( gesture world -- )
-    hand-loc get-global swap send-button-up ;
-
 GENERIC: gesture>string ( gesture -- string/f )
 
 : modifiers>string ( modifiers -- string )

core/classes/classes-docs.factor

@@ -28,12 +28,13 @@ $nl
 $nl
 "Classes themselves form a class:"
 { $subsection class? }
-"You can ask an object for its class or superclass:"
+"You can ask an object for its class:"
 { $subsection class }
-{ $subsection superclass }
-{ $subsection superclasses }
 "Testing if an object is an instance of a class:"
 { $subsection instance? }
+"You can ask a class for its superclass:"
+{ $subsection superclass }
+{ $subsection superclasses }
 "Class predicates can be used to test instances directly:"
 { $subsection "class-predicates" }
 "There is a universal class which all objects are an instance of, and an empty class with no instances:"

core/classes/classes.factor

@@ -10,20 +10,23 @@ SYMBOL: class-not-cache
 SYMBOL: classes-intersect-cache
 SYMBOL: class-and-cache
 SYMBOL: class-or-cache
+SYMBOL: next-method-quot-cache
 
 : init-caches ( -- )
     H{ } clone class<=-cache set
     H{ } clone class-not-cache set
     H{ } clone classes-intersect-cache set
     H{ } clone class-and-cache set
-    H{ } clone class-or-cache set ;
+    H{ } clone class-or-cache set
+    H{ } clone next-method-quot-cache set ;
 
 : reset-caches ( -- )
     class<=-cache get clear-assoc
     class-not-cache get clear-assoc
     classes-intersect-cache get clear-assoc
     class-and-cache get clear-assoc
-    class-or-cache get clear-assoc ;
+    class-or-cache get clear-assoc
+    next-method-quot-cache get clear-assoc ;
 
 SYMBOL: update-map
 

core/generic/generic-tests.factor

@@ -222,3 +222,17 @@ M: integer a-generic a-word ;
     M: boii jeah ;
     "> eval
 ] unit-test
+
+! call-next-method cache test
+GENERIC: c-n-m-cache ( a -- b )
+
+! Force it to be unoptimized
+M: fixnum c-n-m-cache { } [ ] like call call-next-method ;
+M: integer c-n-m-cache 1 + ;
+M: number c-n-m-cache ;
+
+[ 3 ] [ 2 c-n-m-cache ] unit-test
+
+[ ] [ [ { integer c-n-m-cache } forget ] with-compilation-unit ] unit-test
+
+[ 2 ] [ 2 c-n-m-cache ] unit-test

core/generic/generic.factor

@@ -45,7 +45,9 @@ GENERIC: effective-method ( generic -- method )
 GENERIC: next-method-quot* ( class generic combination -- quot )
 
 : next-method-quot ( class generic -- quot )
-    dup "combination" word-prop next-method-quot* ;
+    next-method-quot-cache get [
+        dup "combination" word-prop next-method-quot*
+    ] 2cache ;
 
 : (call-next-method) ( class generic -- )
     next-method-quot call ;
@@ -99,10 +101,11 @@ M: method-body crossref?
     2bi ;
 
 : create-method ( class generic -- method )
-    2dup method dup [
-        2nip
-    ] [
-        drop [ <method> dup ] 2keep reveal-method
+    2dup method dup [ 2nip ] [
+        drop
+        [ <method> dup ] 2keep
+        reveal-method
+        reset-caches
     ] if ;
 
 PREDICATE: default-method < word "default" word-prop ;
@@ -149,8 +152,8 @@ M: method-body forget*
                 ] keep eq?
                 [
                     [ [ delete-at ] with-methods ]
-                    [ [ delete-at ] with-implementors ]
-                    2bi
+                    [ [ delete-at ] with-implementors ] 2bi
+                    reset-caches
                 ] [ 2drop ] if
             ] if
         ]

core/words/words.factor

@@ -87,6 +87,8 @@ M: word (quot-uses) over crossref? [ conjoin ] [ 2drop ] if ;
 
 M: array (quot-uses) seq-uses ;
 
+M: hashtable (quot-uses) >r >alist r> seq-uses ;
+
 M: callable (quot-uses) seq-uses ;
 
 M: wrapper (quot-uses) >r wrapped>> r> (quot-uses) ;