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

core/combinators/combinators.factor

@@ -150,7 +150,7 @@ M: hashtable hashcode*
         drop
     ] [
         dup length 4 <=
-        over keys [ word? ] contains? or
+        over keys [ [ word? ] [ wrapper? ] bi or ] contains? or
         [
             linear-case-quot
         ] [

core/optimizer/known-words/known-words.factor

@@ -60,7 +60,8 @@ sequences.private combinators ;
     [ value-literal sequence? ] [ drop f ] if ;
 
 : member-quot ( seq -- newquot )
-    [ [ t ] ] { } map>assoc [ drop f ] suffix [ nip case ] curry ;
+    [ literalize [ t ] ] { } map>assoc
+    [ drop f ] suffix [ nip case ] curry ;
 
 : expand-member ( #call -- )
     dup node-in-d peek value-literal member-quot f splice-quot ;

core/optimizer/optimizer-tests.factor

@@ -1,9 +1,9 @@
 USING: arrays compiler.units generic hashtables inference kernel
-kernel.private math optimizer prettyprint sequences sbufs
+kernel.private math optimizer generator prettyprint sequences
-strings tools.test vectors words sequences.private quotations
+sbufs strings tools.test vectors words sequences.private
-optimizer.backend classes classes.algebra inference.dataflow
+quotations optimizer.backend classes classes.algebra
-classes.tuple.private continuations growable optimizer.inlining
+inference.dataflow classes.tuple.private continuations growable
-namespaces hints ;
+optimizer.inlining namespaces hints ;
 IN: optimizer.tests
 
 [ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
@@ -349,3 +349,10 @@ USE: sequences.private
     1 2 3.0 3 counter-example ;
 
 [ 2 4 6.0 0 ] [ counter-example' ] unit-test
+
+: member-test { + - * / /i } member? ;
+
+\ member-test must-infer
+[ ] [ \ member-test word-dataflow optimize 2drop ] unit-test
+[ t ] [ \ + member-test ] unit-test
+[ f ] [ \ append member-test ] unit-test

extra/fry/fry-tests.factor

@@ -44,3 +44,7 @@ sequences ;
 : funny-dip '[ @ _ ] call ; inline
 
 [ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test
+
+[ { 1 2 3 } ] [
+    3 1 '[ , [ , + ] map ] call
+] unit-test

extra/fry/fry.factor

@@ -9,41 +9,54 @@ IN: fry
 : @ "Only valid inside a fry" throw ;
 : _ "Only valid inside a fry" throw ;
 
-DEFER: (fry)
+DEFER: (shallow-fry)
 
-: ((fry)) ( accum quot adder -- result )
+: ((shallow-fry)) ( accum quot adder -- result )
-    >r [ ] swap (fry) r>
+    >r [ ] swap (shallow-fry) r>
     append swap dup empty? [ drop ] [
         [ swap compose ] curry append
     ] if ; inline
 
-: (fry) ( accum quot -- result )
+: (shallow-fry) ( accum quot -- result )
     dup empty? [
         drop 1quotation
     ] [
         unclip {
-            { \ , [ [ curry ] ((fry)) ] }
+            { \ , [ [ curry ] ((shallow-fry)) ] }
-            { \ @ [ [ compose ] ((fry)) ] }
+            { \ @ [ [ compose ] ((shallow-fry)) ] }
 
             ! to avoid confusion, remove if fry goes core
-            { \ namespaces:, [ [ curry ] ((fry)) ] }
+            { \ namespaces:, [ [ curry ] ((shallow-fry)) ] }
 
-            [ swap >r suffix r> (fry) ]
+            [ swap >r suffix r> (shallow-fry) ]
         } case
     ] if ;
 
-: trivial-fry ( quot -- quot' ) [ ] swap (fry) ;
+: shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ;
 
-: fry ( quot -- quot' )
+: deep-fry ( quot -- quot' )
     { _ } last-split1 [
         [
-            trivial-fry %
+            shallow-fry %
             [ >r ] %
-            fry %
+            deep-fry %
             [ [ dip ] curry r> compose ] %
         ] [ ] make
     ] [
-        trivial-fry
+        shallow-fry
     ] if* ;
 
+: fry ( quot -- quot' )
+    [
+        [
+            dup callable? [
+                [
+                    [ { , namespaces:, @ } member? ] subset length
+                    \ , <repetition> %
+                ]
+                [ deep-fry % ] bi
+            ] [ namespaces:, ] if
+        ] each
+    ] [ ] make deep-fry ;
+
 : '[ \ ] parse-until fry over push-all ; parsing

extra/http/client/client-tests.factor

@@ -6,9 +6,9 @@ tuple-syntax namespaces ;
 [ "/" "localhost" 8888 ] [ "http://localhost:8888" parse-url ] unit-test
 
 [ "foo.txt" ] [ "http://www.paulgraham.com/foo.txt" download-name ] unit-test
-[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt?xxx" download-name ] unit-test
+[ "foo.txt" ] [ "http://www.arc.com/foo.txt?xxx" download-name ] unit-test
-[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt/" download-name ] unit-test
+[ "foo.txt" ] [ "http://www.arc.com/foo.txt/" download-name ] unit-test
-[ "www.arcsucks.com" ] [ "http://www.arcsucks.com////" download-name ] unit-test
+[ "www.arc.com" ] [ "http://www.arc.com////" download-name ] unit-test
 
 [
     TUPLE{ request
@@ -18,7 +18,7 @@ tuple-syntax namespaces ;
         port: 80
         version: "1.1"
         cookies: V{ }
-        header: H{ }
+        header: H{ { "connection" "close" } }
     }
 ] [
     [

extra/http/client/client.factor

@@ -3,9 +3,17 @@
 USING: assocs http kernel math math.parser namespaces sequences
 io io.sockets io.streams.string io.files io.timeouts strings
 splitting calendar continuations accessors vectors
-io.encodings.8-bit io.encodings.binary fry ;
+io.encodings.8-bit io.encodings.binary fry debugger inspector ;
 IN: http.client
 
+: max-redirects 10 ;
+
+ERROR: too-many-redirects ;
+
+M: too-many-redirects summary
+    drop
+    [ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ;
+
 DEFER: http-request
 
 <PRIVATE
@@ -29,22 +37,26 @@ DEFER: http-request
 : relative-redirect ( path -- request )
     request get swap store-path ;
 
+SYMBOL: redirects
+
 : do-redirect ( response -- response stream )
     dup response-code 300 399 between? [
         stdio get dispose
+        redirects inc
+        redirects get max-redirects < [
             header>> "location" swap at
             dup "http://" head? [
                 absolute-redirect
             ] [
                 relative-redirect
             ] if "GET" >>method http-request
+        ] [
+            too-many-redirects
+        ] if
     ] [
         stdio get
     ] if ;
 
-: request-addr ( request -- addr )
-    dup host>> swap port>> <inet> ;
-
 : close-on-error ( stream quot -- )
     '[ , with-stream* ] [ ] pick '[ , dispose ] cleanup ; inline
 
@@ -61,20 +73,43 @@ PRIVATE>
         ] close-on-error
     ] with-variable ;
 
+: read-chunks ( -- )
+    readln ";" split1 drop hex>
+    dup { f 0 } member? [ drop ] [ read % read-chunks ] if ;
+
+: do-chunked-encoding ( response stream -- response stream/string )
+    over "transfer-encoding" header "chunked" = [
+        [ [ read-chunks ] "" make ] with-stream
+    ] when ;
+
 : <get-request> ( url -- request )
     <request> request-with-url "GET" >>method ;
 
-: http-get-stream ( url -- response stream )
+: string-or-contents ( stream/string -- string )
-    <get-request> http-request ;
+    dup string? [ contents ] unless ;
+
+: http-get-stream ( url -- response stream/string )
+    <get-request> http-request do-chunked-encoding ;
 
 : success? ( code -- ? ) 200 = ;
 
-: check-response ( response -- )
+ERROR: download-failed response body ;
-    code>> success?
+
-    [ "HTTP download failed" throw ] unless ;
+M: download-failed error.
+    "HTTP download failed:" print nl
+    [
+        response>>
+            write-response-code
+            write-response-message nl
+        drop
+    ]
+    [ body>> write ] bi ;
+
+: check-response ( response string -- string )
+    over code>> success? [ nip ] [ download-failed ] if ;
 
 : http-get ( url -- string )
-    http-get-stream contents swap check-response ;
+    http-get-stream string-or-contents check-response ;
 
 : download-name ( url -- name )
     file-name "?" split1 drop "/" ?tail drop ;
@@ -95,4 +130,4 @@ PRIVATE>
     swap >>post-data-type ;
 
 : http-post ( content-type content url -- response string )
-    <post-request> http-request contents ;
+    <post-request> http-request do-chunked-encoding string-or-contents ;

extra/http/http-tests.factor

@@ -143,6 +143,9 @@ io.encodings.ascii ;
             <dispatcher>
                 "extra/http/test" resource-path <static> >>default
             "nested" add-responder
+            <action>
+                [ "redirect-loop" f <permanent-redirect> ] >>display
+            "redirect-loop" add-responder
         main-responder set
 
         [ 1237 httpd ] "HTTPD test" spawn drop
@@ -160,10 +163,13 @@ io.encodings.ascii ;
         "GET nested HTTP/1.0\r\n" write flush
         "\r\n" write flush
         readln drop
-        read-header USE: prettyprint
+        read-header
-    ] with-stream dup . "location" swap at "/" head?
+    ] with-stream "location" swap at "/" head?
 ] unit-test
 
+[ "http://localhost:1237/redirect-loop" http-get ]
+[ too-many-redirects? ] must-fail-with
+
 [ "Goodbye" ] [
     "http://localhost:1237/quit" http-get
 ] unit-test

extra/http/http.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry hashtables io io.streams.string kernel math sets
 namespaces math.parser assocs sequences strings splitting ascii
-io.encodings.utf8 io.encodings.string namespaces unicode.case
+io.encodings.utf8 io.encodings.string io.sockets namespaces
-combinators vectors sorting accessors calendar
+unicode.case combinators vectors sorting accessors calendar
 calendar.format quotations arrays combinators.lib byte-arrays ;
 IN: http
 
@@ -175,13 +175,17 @@ post-data
 post-data-type
 cookies ;
 
+: set-header ( request/response value key -- request/response )
+    pick header>> set-at ;
+
 : <request>
     request new
         "1.1" >>version
         http-port >>port
         H{ } clone >>header
         H{ } clone >>query
-        V{ } clone >>cookies ;
+        V{ } clone >>cookies
+        "close" "connection" set-header ;
 
 : query-param ( request key -- value )
     swap query>> at ;
@@ -295,9 +299,15 @@ SYMBOL: max-post-request
         "application/x-www-form-urlencoded" >>post-data-type
     ] if ;
 
+: request-addr ( request -- addr )
+    [ host>> ] [ port>> ] bi <inet> ;
+
+: request-host ( request -- string )
+    [ host>> ] [ drop ":" ] [ port>> number>string ] tri 3append ;
+
 : write-request-header ( request -- request )
     dup header>> >hashtable
-    over host>> [ "host" pick set-at ] when*
+    over host>> [ over request-host "host" pick set-at ] when
     over post-data>> [ length "content-length" pick set-at ] when*
     over post-data-type>> [ "content-type" pick set-at ] when*
     over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when*
@@ -330,9 +340,6 @@ SYMBOL: max-post-request
         tri
     ] with-string-writer ;
 
-: set-header ( request/response value key -- request/response )
-    pick header>> set-at ;
-
 GENERIC: write-response ( response -- )
 
 GENERIC: write-full-response ( request response -- )

extra/io/windows/nt/files/files.factor

@@ -1,9 +1,9 @@
 USING: continuations destructors io.buffers io.files io.backend
 io.timeouts io.nonblocking io.windows io.windows.nt.backend
 kernel libc math threads windows windows.kernel32 system
-alien.c-types alien.arrays sequences combinators combinators.lib
+alien.c-types alien.arrays alien.strings sequences combinators
-sequences.lib ascii splitting alien strings assocs namespaces
+combinators.lib sequences.lib ascii splitting alien strings
-io.files.private accessors ;
+assocs namespaces io.files.private accessors ;
 IN: io.windows.nt.files
 
 M: winnt cwd

extra/project-euler/190/190.factor

@@ -0,0 +1,48 @@
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences sequences.lib math math.functions math.ranges locals ;
+IN: project-euler.190
+
+! PROBLEM
+! -------
+
+! http://projecteuler.net/index.php?section=problems&id=190
+
+! Let Sm = (x1, x2, ... , xm) be the m-tuple of positive real numbers
+! with x1 + x2 + ... + xm = m for which Pm = x1 * x22 * ... * xmm is
+! maximised.
+
+! For example, it can be verified that [P10] = 4112 ([ ] is the integer
+! part function).
+
+! Find Σ[Pm] for 2 ≤ m ≤ 15.
+
+! SOLUTION
+! --------
+
+! Pm = x1 * x2^2 * x3^3 * ... * xm^m
+! fm = x1 + x2 + x3 + ... + xm - m = 0
+! Gm === Pm - L * fm
+! dG/dx_i = 0 = i * Pm / xi - L
+! xi = i * Pm / L
+
+! Sum(i=1 to m) xi = m
+! Sum(i=1 to m) i * Pm / L = m
+! Pm / L * Sum(i=1 to m) i = m
+! Pm / L * m*(m+1)/2 = m
+! Pm / L = 2 / (m+1)
+
+! xi = i * (2 / (m+1)) = 2*i/(m+1)
+
+<PRIVATE
+
+: PI ( seq quot -- n )
+    [ * ] compose 1 swap reduce ; inline
+
+PRIVATE>
+
+:: P_m ( m -- P_m )
+    m [1,b] [| i | 2 i * m 1+ / i ^ ] PI ;
+
+: euler190 ( -- n )
+    2 15 [a,b] [ P_m truncate ] sigma ;

extra/sequences/lib/lib.factor

@@ -52,7 +52,7 @@ MACRO: firstn ( n -- )
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : sigma ( seq quot -- n )
-    [ rot slip + ] curry 0 swap reduce ; inline
+    [ + ] compose 0 swap reduce ; inline
 
 : count ( seq quot -- n )
     [ 1 0 ? ] compose sigma ; inline

extra/unix/linux/ifreq/ifreq.factor

@@ -55,7 +55,7 @@ IN: unix.linux.ifreq
 
 : set-if-metric ( name metric -- )
   "struct-ifreq" <c-object>
-  rot string>char-alien over set-struct-ifreq-ifr-ifrn
+  rot ascii string>alien over set-struct-ifreq-ifr-ifrn
   swap <int>		over set-struct-ifreq-ifr-ifru
 
   AF_INET SOCK_DGRAM 0 socket SIOCSIFMETRIC rot ioctl drop ;

extra/windows/shell32/shell32.factor

@@ -1,4 +1,4 @@
-USING: alien alien.c-types alien.syntax combinators
+USING: alien alien.c-types alien.strings alien.syntax combinators
 kernel windows windows.user32 windows.ole32
 windows.com windows.com.syntax io.files ;
 IN: windows.shell32

extra/windows/winsock/winsock.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006 Mackenzie Straight, Doug Coleman.
 
-USING: alien alien.c-types alien.syntax arrays byte-arrays
+USING: alien alien.c-types alien.strings alien.syntax arrays
-kernel math sequences windows.types windows.kernel32
+byte-arrays kernel math sequences windows.types windows.kernel32
 windows.errors structs windows math.bitfields ;
 IN: windows.winsock