diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor
index e3d0f88680..da98a78736 100755
--- a/core/combinators/combinators.factor
+++ b/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
] [
diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor
index 91d0c1c0de..6e1aacff44 100755
--- a/core/optimizer/known-words/known-words.factor
+++ b/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 ;
diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor
index 14dcd62c61..6f4ae2c1d5 100755
--- a/core/optimizer/optimizer-tests.factor
+++ b/core/optimizer/optimizer-tests.factor
@@ -1,9 +1,9 @@
USING: arrays compiler.units generic hashtables inference kernel
-kernel.private math optimizer prettyprint sequences sbufs
-strings tools.test vectors words sequences.private quotations
-optimizer.backend classes classes.algebra inference.dataflow
-classes.tuple.private continuations growable optimizer.inlining
-namespaces hints ;
+kernel.private math optimizer generator prettyprint sequences
+sbufs strings tools.test vectors words sequences.private
+quotations optimizer.backend classes classes.algebra
+inference.dataflow classes.tuple.private continuations growable
+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
diff --git a/extra/fry/fry-tests.factor b/extra/fry/fry-tests.factor
index 4d2c9fe1c8..7586e254b2 100755
--- a/extra/fry/fry-tests.factor
+++ b/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
diff --git a/extra/fry/fry.factor b/extra/fry/fry.factor
index 6c20aac7f2..7621af6899 100755
--- a/extra/fry/fry.factor
+++ b/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 )
- >r [ ] swap (fry) r>
+: ((shallow-fry)) ( accum quot adder -- result )
+ >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)) ] }
- { \ @ [ [ compose ] ((fry)) ] }
+ { \ , [ [ curry ] ((shallow-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
diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor
index 0f684f782a..1d947b99e5 100755
--- a/extra/http/client/client-tests.factor
+++ b/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.arcsucks.com/foo.txt/" download-name ] unit-test
-[ "www.arcsucks.com" ] [ "http://www.arcsucks.com////" download-name ] unit-test
+[ "foo.txt" ] [ "http://www.arc.com/foo.txt?xxx" download-name ] unit-test
+[ "foo.txt" ] [ "http://www.arc.com/foo.txt/" 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" } }
}
] [
[
diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor
index e4bbf0279f..ac5d220a52 100755
--- a/extra/http/client/client.factor
+++ b/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
- header>> "location" swap at
- dup "http://" head? [
- absolute-redirect
+ redirects inc
+ redirects get max-redirects < [
+ header>> "location" swap at
+ dup "http://" head? [
+ absolute-redirect
+ ] [
+ relative-redirect
+ ] if "GET" >>method http-request
] [
- 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 )
- <get-request> http-request ;
+: string-or-contents ( stream/string -- string )
+ dup string? [ contents ] unless ;
+
+: http-get-stream ( url -- response stream/string )
+ <get-request> http-request do-chunked-encoding ;
: success? ( code -- ? ) 200 = ;
-: check-response ( response -- )
- code>> success?
- [ "HTTP download failed" throw ] unless ;
+ERROR: download-failed response body ;
+
+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 ;
diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor
index d1ffce721d..9302045624 100755
--- a/extra/http/http-tests.factor
+++ b/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
- ] with-stream dup . "location" swap at "/" head?
+ read-header
+ ] 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
diff --git a/extra/http/http.factor b/extra/http/http.factor
index 9e31855e53..5e90962b27 100755
--- a/extra/http/http.factor
+++ b/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
-combinators vectors sorting accessors calendar
+io.encodings.utf8 io.encodings.string io.sockets namespaces
+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 -- )
@@ -347,11 +354,11 @@ body ;
: <response>
response new
- "1.1" >>version
- H{ } clone >>header
- "close" "connection" set-header
- now timestamp>http-string "date" set-header
- V{ } clone >>cookies ;
+ "1.1" >>version
+ H{ } clone >>header
+ "close" "connection" set-header
+ now timestamp>http-string "date" set-header
+ V{ } clone >>cookies ;
: read-response-version
" \t" read-until
diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor
index 32126443f4..c9f17147d3 100755
--- a/extra/io/windows/nt/files/files.factor
+++ b/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
-sequences.lib ascii splitting alien strings assocs namespaces
-io.files.private accessors ;
+alien.c-types alien.arrays alien.strings sequences combinators
+combinators.lib sequences.lib ascii splitting alien strings
+assocs namespaces io.files.private accessors ;
IN: io.windows.nt.files
M: winnt cwd
diff --git a/extra/project-euler/190/190.factor b/extra/project-euler/190/190.factor
new file mode 100644
index 0000000000..6fc15c9f30
--- /dev/null
+++ b/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 ;
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index 62cd0adce1..b186ee7777 100755
--- a/extra/sequences/lib/lib.factor
+++ b/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
diff --git a/extra/unix/linux/ifreq/ifreq.factor b/extra/unix/linux/ifreq/ifreq.factor
index a6cb90ba06..d688153bd0 100755
--- a/extra/unix/linux/ifreq/ifreq.factor
+++ b/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 ;
\ No newline at end of file
diff --git a/extra/windows/shell32/shell32.factor b/extra/windows/shell32/shell32.factor
index 81ecc35b5f..a9035eeeaf 100644
--- a/extra/windows/shell32/shell32.factor
+++ b/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
diff --git a/extra/windows/winsock/winsock.factor b/extra/windows/winsock/winsock.factor
index b9f8739a19..39d11b562b 100644
--- a/extra/windows/winsock/winsock.factor
+++ b/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
-kernel math sequences windows.types windows.kernel32
+USING: alien alien.c-types alien.strings alien.syntax arrays
+byte-arrays kernel math sequences windows.types windows.kernel32
windows.errors structs windows math.bitfields ;
IN: windows.winsock