From b0c2ce40dc5bc1912b09c628ec97550c8ee748d7 Mon Sep 17 00:00:00 2001 From: Slava Pestov <slava@slava-pestovs-macbook-pro.local> Date: Mon, 21 Apr 2008 18:30:07 -0500 Subject: [PATCH 01/10] Fix load error --- extra/unix/linux/ifreq/ifreq.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 From 0ae1862805dbaf14ab2c4e3193a778f46c84c649 Mon Sep 17 00:00:00 2001 From: Slava Pestov <slava@slava-pestovs-macbook-pro.local> Date: Mon, 21 Apr 2008 18:31:16 -0500 Subject: [PATCH 02/10] Fix Windows bootstrap --- extra/windows/shell32/shell32.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 From d03d2280851fa55bc596238e2b11336b6ce47445 Mon Sep 17 00:00:00 2001 From: Slava Pestov <slava@slava-pestovs-macbook-pro.local> Date: Mon, 21 Apr 2008 19:04:17 -0500 Subject: [PATCH 03/10] Third time lucky --- extra/windows/winsock/winsock.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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 From 18fa6fd115d82ca751dfa5b6213266003bed8ccc Mon Sep 17 00:00:00 2001 From: Slava Pestov <slava@slava-pestovs-macbook-pro.local> Date: Mon, 21 Apr 2008 19:20:18 -0500 Subject: [PATCH 04/10] Arggh --- extra/io/windows/nt/files/files.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) 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 From 757115bc6449c97abe3d5f9020a4625c8f04a226 Mon Sep 17 00:00:00 2001 From: Eric Mertens <emertens@gmail.com> Date: Mon, 21 Apr 2008 23:39:54 -0700 Subject: [PATCH 05/10] Update implementation of sigma to use compose --- extra/sequences/lib/lib.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 From 4fdfb97a4db4c7cc3416603ba7ad42c05c5625c3 Mon Sep 17 00:00:00 2001 From: Eric Mertens <emertens@gmail.com> Date: Mon, 21 Apr 2008 23:40:13 -0700 Subject: [PATCH 06/10] Add project-euler.190 --- extra/project-euler/190/190.factor | 48 ++++++++++++++++++++++++++++++ 1 file changed, 48 insertions(+) create mode 100644 extra/project-euler/190/190.factor 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 ; From 206609242e707b005f44a9c6cd83c88c4907835e Mon Sep 17 00:00:00 2001 From: Slava Pestov <slava@slava-pestovs-macbook-pro.local> Date: Tue, 22 Apr 2008 14:37:26 -0500 Subject: [PATCH 07/10] Add support for chunked encoding, and set connection: close on http requests --- extra/http/client/client.factor | 39 ++++++++++++++++++++++++++------- extra/http/http.factor | 19 ++++++++-------- 2 files changed, 41 insertions(+), 17 deletions(-) diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index e4bbf0279f..1c42b174d4 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -3,7 +3,7 @@ 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 ; IN: http.client DEFER: http-request @@ -61,20 +61,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 +118,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.factor b/extra/http/http.factor index 9e31855e53..926336cae1 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -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 ; @@ -330,9 +334,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 +348,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 From cdb31b48139231121ada8c4a2535d63ec92383f8 Mon Sep 17 00:00:00 2001 From: Slava Pestov <slava@slava-pestovs-macbook-pro.local> Date: Tue, 22 Apr 2008 15:37:49 -0500 Subject: [PATCH 08/10] Fix host: header in http.client and add redirection limit --- extra/http/client/client-tests.factor | 8 +++---- extra/http/client/client.factor | 30 +++++++++++++++++++-------- extra/http/http-tests.factor | 10 +++++++-- extra/http/http.factor | 12 ++++++++--- 4 files changed, 42 insertions(+), 18 deletions(-) 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 1c42b174d4..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 debugger ; +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 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 926336cae1..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 @@ -299,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* From f1113b7c2a1136fb81ab6e2c3be64430d5daed74 Mon Sep 17 00:00:00 2001 From: Slava Pestov <slava@slava-pestovs-macbook-pro.local> Date: Tue, 22 Apr 2008 16:29:10 -0500 Subject: [PATCH 09/10] Fix case bug --- core/combinators/combinators.factor | 2 +- core/optimizer/known-words/known-words.factor | 3 ++- core/optimizer/optimizer-tests.factor | 17 ++++++++++++----- 3 files changed, 15 insertions(+), 7 deletions(-) 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 From decdaf1e32f94a7830b90ae1b5a39c0910ea9a12 Mon Sep 17 00:00:00 2001 From: Slava Pestov <slava@slava-pestovs-macbook-pro.local> Date: Tue, 22 Apr 2008 16:29:20 -0500 Subject: [PATCH 10/10] Recursive fry --- extra/fry/fry-tests.factor | 4 ++++ extra/fry/fry.factor | 39 +++++++++++++++++++++++++------------- 2 files changed, 30 insertions(+), 13 deletions(-) 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