steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Doug Coleman 2008-04-22 19:45:26 -05:00
parent 5bd3068fb0 decdaf1e32
commit 2a36ed1380
15 changed files with 183 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/combinators/combinators.factor
View File

@ -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
] [

3
core/optimizer/known-words/known-words.factor
View File

@ -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 ;

17
core/optimizer/optimizer-tests.factor
View File

@ -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

4
extra/fry/fry-tests.factor
View File

@ -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

39
extra/fry/fry.factor
View File

@ -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

8
extra/http/client/client-tests.factor
View File

@ -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" } }
}
] [
[

67
extra/http/client/client.factor
View File

@ -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 ;

10
extra/http/http-tests.factor
View File

@ -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

31
extra/http/http.factor
View File

@ -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

6
extra/io/windows/nt/files/files.factor
View File

@ -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

48
extra/project-euler/190/190.factor Normal file
View File

@ -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 ;

2
extra/sequences/lib/lib.factor
View File

@ -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

2
extra/unix/linux/ifreq/ifreq.factor
View File

@ -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 ;

2
extra/windows/shell32/shell32.factor
View File

@ -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

4
extra/windows/winsock/winsock.factor
View File

@ -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