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

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

Doug Coleman 2008-10-20 23:40:15 -05:00
parent 7e734ead14 655b483ff1
commit e6754ab62e
12 changed files with 426 additions and 140 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

159
basis/http/http-tests.factor
View File

@ -192,110 +192,104 @@ test-db [
init-furnace-tables
] with-db
: test-httpd ( -- )
#! Return as soon as server is running.
<http-server>
1237 >>insecure
f >>secure
start-server* ;
: test-httpd ( responder -- )
[
main-responder set
<http-server>
0 >>insecure
f >>secure
dup start-server*
sockets>> first addr>> port>>
] with-scope "port" set ;
[ ] [
[
<dispatcher>
add-quit-action
<dispatcher>
add-quit-action
<dispatcher>
"resource:basis/http/test" <static> >>default
"nested" add-responder
<action>
[ URL" redirect-loop" <temporary-redirect> ] >>display
"redirect-loop" add-responder
main-responder set
"resource:basis/http/test" <static> >>default
"nested" add-responder
<action>
[ URL" redirect-loop" <temporary-redirect> ] >>display
"redirect-loop" add-responder
test-httpd
] with-scope
test-httpd
] unit-test
: add-port ( url -- url' )
>url clone "port" get >>port ;
[ t ] [
"resource:basis/http/test/foo.html" ascii file-contents
"http://localhost:1237/nested/foo.html" http-get nip =
"http://localhost/nested/foo.html" add-port http-get nip =
] unit-test
[ "http://localhost:1237/redirect-loop" http-get nip ]
[ "http://localhost/redirect-loop" add-port http-get nip ]
[ too-many-redirects? ] must-fail-with
[ "Goodbye" ] [
"http://localhost:1237/quit" http-get nip
"http://localhost/quit" add-port http-get nip
] unit-test
! HTTP client redirect bug
[ ] [
[
<dispatcher>
add-quit-action
<action> [ "quit" <temporary-redirect> ] >>display
"redirect" add-responder
main-responder set
<dispatcher>
add-quit-action
<action> [ "quit" <temporary-redirect> ] >>display
"redirect" add-responder
test-httpd
] with-scope
test-httpd
] unit-test
[ "Goodbye" ] [
"http://localhost:1237/redirect" http-get nip
"http://localhost/redirect" add-port http-get nip
] unit-test
[ ] [
[ "http://localhost:1237/quit" http-get 2drop ] ignore-errors
[ "http://localhost/quit" add-port http-get 2drop ] ignore-errors
] unit-test
! Dispatcher bugs
[ ] [
[
<dispatcher>
<action> <protected>
"Test" <login-realm>
<sessions>
"" add-responder
add-quit-action
<dispatcher>
<action> <protected>
"Test" <login-realm>
<sessions>
"" add-responder
add-quit-action
<dispatcher>
<action> "" add-responder
"d" add-responder
test-db <db-persistence>
main-responder set
<action> "" add-responder
"d" add-responder
test-db <db-persistence>
test-httpd
] with-scope
test-httpd
] unit-test
: 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ;
! This should give a 404 not an infinite redirect loop
[ "http://localhost:1237/d/blah" http-get nip ] [ 404? ] must-fail-with
[ "http://localhost/d/blah" add-port http-get nip ] [ 404? ] must-fail-with
! This should give a 404 not an infinite redirect loop
[ "http://localhost:1237/blah/" http-get nip ] [ 404? ] must-fail-with
[ "http://localhost/blah/" add-port http-get nip ] [ 404? ] must-fail-with
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
[ ] [
[
<dispatcher>
<action> [ [ "Hi" write ] "text/plain" <content> ] >>display
"Test" <login-realm>
<sessions>
"" add-responder
add-quit-action
test-db <db-persistence>
main-responder set
<dispatcher>
<action> [ [ "Hi" write ] "text/plain" <content> ] >>display
"Test" <login-realm>
<sessions>
"" add-responder
add-quit-action
test-db <db-persistence>
test-httpd
] with-scope
test-httpd
] unit-test
[ "Hi" ] [ "http://localhost:1237/" http-get nip ] unit-test
[ "Hi" ] [ "http://localhost/" add-port http-get nip ] unit-test
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
USING: html.components html.elements html.forms
xml xml.utilities validators
@ -304,22 +298,19 @@ furnace furnace.conversations ;
SYMBOL: a
[ ] [
[
<dispatcher>
<action>
[ a get-global "a" set-value ] >>init
[ [ <html> "a" <field> render </html> ] "text/html" <content> ] >>display
[ { { "a" [ v-integer ] } } validate-params ] >>validate
[ "a" value a set-global URL" " <redirect> ] >>submit
<conversations>
<sessions>
>>default
add-quit-action
test-db <db-persistence>
main-responder set
<dispatcher>
<action>
[ a get-global "a" set-value ] >>init
[ [ <html> "a" <field> render </html> ] "text/html" <content> ] >>display
[ { { "a" [ v-integer ] } } validate-params ] >>validate
[ "a" value a set-global URL" " <redirect> ] >>submit
<conversations>
<sessions>
>>default
add-quit-action
test-db <db-persistence>
test-httpd
] with-scope
test-httpd
] unit-test
3 a set-global
@ -327,27 +318,35 @@ SYMBOL: a
: test-a string>xml "input" tag-named "value" swap at ;
[ "3" ] [
"http://localhost:1237/" http-get
"http://localhost/" add-port http-get
swap dup cookies>> "cookies" set session-id-key get-cookie
value>> "session-id" set test-a
] unit-test
[ "4" ] [
H{ { "a" "4" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union
"http://localhost:1237/" <post-request> "cookies" get >>cookies http-request nip test-a
[
"4" "a" set
"http://localhost" add-port "__u" set
"session-id" get session-id-key set
] H{ } make-assoc
"http://localhost/" add-port <post-request> "cookies" get >>cookies http-request nip test-a
] unit-test
[ 4 ] [ a get-global ] unit-test
! Test flash scope
[ "xyz" ] [
H{ { "a" "xyz" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union
"http://localhost:1237/" <post-request> "cookies" get >>cookies http-request nip test-a
[
"xyz" "a" set
"http://localhost" add-port "__u" set
"session-id" get session-id-key set
] H{ } make-assoc
"http://localhost/" add-port <post-request> "cookies" get >>cookies http-request nip test-a
] unit-test
[ 4 ] [ a get-global ] unit-test
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
! Test cloning
[ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test

19
basis/io/servers/connection/connection-tests.factor
View File

@ -27,25 +27,12 @@ concurrency.promises io.encodings.ascii io threads calendar ;
init-server semaphore>> count>>
] unit-test
[ ] [ <promise> "p" set ] unit-test
[ ] [
<threaded-server>
5 >>max-connections
1237 >>insecure
0 >>insecure
[ "Hello world." write stop-this-server ] >>handler
"server" set
dup start-server* sockets>> first addr>> port>> "port" set
] unit-test
[ ] [
[
"server" get start-server
t "p" get fulfill
] in-thread
] unit-test
[ ] [ "server" get wait-for-server ] unit-test
[ "Hello world." ] [ "localhost" 1237 <inet> ascii <client> drop contents ] unit-test
[ t ] [ "p" get 2 seconds ?promise-timeout ] unit-test
[ "Hello world." ] [ "localhost" "port" get <inet> ascii <client> drop contents ] unit-test

38
basis/tools/deploy/deploy-tests.factor
View File

@ -1,7 +1,8 @@
IN: tools.deploy.tests
USING: tools.test system io.files kernel tools.deploy.config
tools.deploy.backend math sequences io.launcher arrays
namespaces continuations layouts accessors ;
namespaces continuations layouts accessors io.encodings.ascii
urls math.parser ;
: shake-and-bake ( vocab -- )
[ "test.image" temp-file delete-file ] ignore-errors
@ -38,7 +39,7 @@ namespaces continuations layouts accessors ;
! [ ] [ "tetris" shake-and-bake ] unit-test
!
! [ t ] [ 1500000 small-enough? ] unit-test
!
[ ] [ "bunny" shake-and-bake ] unit-test
[ t ] [ 2500000 small-enough? ] unit-test
@ -71,22 +72,24 @@ M: quit-responder call-responder*
: add-quot-responder ( responder -- responder )
quit-responder "quit" add-responder ;
: test-httpd ( -- )
#! Return as soon as server is running.
<http-server>
1237 >>insecure
f >>secure
start-server* ;
: test-httpd ( responder -- )
[
main-responder set
<http-server>
0 >>insecure
f >>secure
dup start-server*
sockets>> first addr>> port>>
dup number>string "resource:temp/port-number" ascii set-file-contents
] with-scope
"port" set ;
[ ] [
[
<dispatcher>
add-quot-responder
"resource:basis/http/test" <static> >>default
main-responder set
<dispatcher>
add-quot-responder
"resource:basis/http/test" <static> >>default
test-httpd
] with-scope
test-httpd
] unit-test
[ ] [
@ -94,7 +97,10 @@ M: quit-responder call-responder*
run-temp-image
] unit-test
[ ] [ "http://localhost:1237/quit" http-get 2drop ] unit-test
: add-port ( url -- url' )
>url clone "port" get >>port ;
[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test
[ ] [
"tools.deploy.test.6" shake-and-bake

7
basis/tools/deploy/test/5/5.factor
View File

@ -1,7 +1,10 @@
IN: tools.deploy.test.5
USING: http.client kernel ;
USING: accessors urls io.encodings.ascii io.files math.parser
http.client kernel ;
: deploy-test-5 ( -- )
"http://localhost:1237/foo.html" http-get 2drop ;
URL" http://localhost/foo.html" clone
"resource:port-number" ascii file-contents string>number >>port
http-get 2drop ;
MAIN: deploy-test-5

1
basis/tools/test/test.factor
View File

@ -12,6 +12,7 @@ SYMBOL: failures
error-continuation get 3array ;
: failure ( error what -- )
"--> test failed!" print
<failure> failures get push ;
SYMBOL: this-test

4
basis/ui/tools/listener/listener-tests.factor
View File

@ -2,7 +2,7 @@ USING: continuations documents ui.tools.interactor
ui.tools.listener hashtables kernel namespaces parser sequences
tools.test ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.panes vocabs words tools.test.ui slots.private
threads arrays generic threads accessors listener ;
threads arrays generic threads accessors listener math ;
IN: ui.tools.listener.tests
[ f ] [ "word" source-editor command-map commands>> empty? ] unit-test
@ -51,3 +51,5 @@ IN: ui.tools.listener.tests
[ ] [ "listener" get com-end ] unit-test
] with-grafted-gadget
[ ] [ \ + <pane> <interactor> interactor-use use-if-necessary ] unit-test

11
basis/ui/tools/listener/listener.factor
View File

@ -101,8 +101,8 @@ M: engine-word word-completion-string
"engine-generic" word-prop word-completion-string ;
: use-if-necessary ( word seq -- )
over vocabulary>> [
2dup assoc-stack pick = [ 2drop ] [
over vocabulary>> over and [
2dup [ assoc-stack ] keep = [ 2drop ] [
>r vocabulary>> vocab-words r> push
] if
] [ 2drop ] if ;
@ -114,9 +114,10 @@ M: engine-word word-completion-string
2bi ;
: quot-action ( interactor -- lines )
dup control-value
dup "\n" join pick add-interactor-history
swap select-all ;
[ control-value ] keep
[ [ "\n" join ] dip add-interactor-history ]
[ select-all ]
2bi ;
TUPLE: stack-display < track ;

8
basis/ui/tools/tools.factor
View File

@ -40,11 +40,11 @@ IN: ui.tools
: resize-workspace ( workspace -- )
dup sizes>> over control-value zero? [
1/5 1 pick set-nth
4/5 2 rot set-nth
1/5 over set-second
4/5 swap set-third
] [
2/3 1 pick set-nth
1/3 2 rot set-nth
2/3 over set-second
1/3 swap set-third
] if relayout ;
M: workspace model-changed

8
core/classes/tuple/tuple.factor
View File

@ -138,8 +138,12 @@ ERROR: bad-superclass class ;
: define-tuple-prototype ( class -- )
dup tuple-prototype "prototype" set-word-prop ;
: prepare-slots ( slots superclass -- slots' )
[ make-slots ] [ class-size 2 + ] bi* finalize-slots ;
: define-tuple-slots ( class -- )
dup "slots" word-prop define-accessors ;
dup "slots" word-prop over superclass prepare-slots
define-accessors ;
: make-tuple-layout ( class -- layout )
[ ]
@ -242,7 +246,7 @@ PRIVATE>
: define-tuple-class ( class superclass slots -- )
over check-superclass
make-slots over class-size 2 + finalize-slots
over prepare-slots
(define-tuple-class) ;
M: word (define-tuple-class)

26
extra/benchmark/sockets/sockets.factor
View File

@ -1,20 +1,25 @@
USING: io.sockets io kernel math threads io.encodings.ascii
io.streams.duplex debugger tools.time prettyprint
concurrency.count-downs namespaces arrays continuations
destructors ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math threads io io.sockets
io.encodings.ascii io.streams.duplex debugger tools.time
prettyprint concurrency.count-downs concurrency.promises
namespaces arrays continuations destructors ;
IN: benchmark.sockets
SYMBOL: counter
SYMBOL: port-promise
SYMBOL: server
: number-of-requests 1000 ;
: server-addr ( -- addr ) "127.0.0.1" 7777 <inet4> ;
: server-addr ( -- addr )
"127.0.0.1" port-promise get ?promise <inet4> ;
: server-loop ( server -- )
dup accept drop [
[
read1 CHAR: x = [
"server" get dispose
server get dispose
] [
number-of-requests
[ read1 write1 flush ] times
@ -25,9 +30,11 @@ SYMBOL: counter
: simple-server ( -- )
[
server-addr ascii <server> dup "server" set [
server-loop
] with-disposal
"127.0.0.1" 0 <inet4> ascii <server>
[ server set ]
[ addr>> port>> port-promise get fulfill ]
[ [ server-loop ] with-disposal ]
tri
] ignore-errors ;
: simple-client ( -- )
@ -47,6 +54,7 @@ SYMBOL: counter
: clients ( n -- )
dup pprint " clients: " write [
<promise> port-promise set
dup 2 * <count-down> counter set
[ simple-server ] "Simple server" spawn drop
yield yield

13
extra/tetris/deploy.factor
View File

@ -1,12 +1,15 @@
USING: tools.deploy.config ;
V{
H{
{ deploy-ui? t }
{ deploy-io 1 }
{ deploy-reflection 1 }
{ deploy-compiler? t }
{ deploy-math? t }
{ deploy-threads? t }
{ deploy-word-props? f }
{ deploy-c-types? f }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
{ deploy-random? t }
{ deploy-io 2 }
{ deploy-math? t }
{ deploy-word-defs? f }
{ deploy-c-types? f }
{ deploy-name "Tetris" }
}

272
unfinished/benchmark/richards/richards.factor Normal file
View File

@ -0,0 +1,272 @@
! Based on http://research.sun.com/people/mario/java_benchmarking/
! Ported by Factor by Slava Pestov
!
! Based on original version written in BCPL by Dr Martin Richards
! in 1981 at Cambridge University Computer Laboratory, England
! Java version: Copyright (C) 1995 Sun Microsystems, Inc.
! by Jonathan Gibbons.
! Outer loop added 8/7/96 by Alex Jacoby
USING: values kernel accessors math math.bitwise sequences
arrays combinators fry locals ;
IN: benchmark.richards
! Packets
TUPLE: packet link id kind a1 a2 ;
: BUFSIZE 4 ; inline
: <packet> ( link id kind -- packet )
packet new
swap >>kind
swap >>id
swap >>link
0 >>a1
BUFSIZE 0 <array> >>a2 ;
: last-packet ( packet -- last )
dup link>> [ last-packet ] [ ] ?if ;
: append-to ( packet list -- packet )
[ f >>link ] dip
[ tuck last-packet >>link drop ] when* ;
! Tasks
: I_IDLE 1 ; inline
: I_WORK 2 ; inline
: I_HANDLERA 3 ; inline
: I_HANDLERB 4 ; inline
: I_DEVA 5 ; inline
: I_DEVB 6 ; inline
! Packet types
: K_DEV 1000 ; inline
: K_WORK 1001 ; inline
: PKTBIT 1 ; inline
: WAITBIT 2 ; inline
: HOLDBIT 4 ; inline
: S_RUN 0 ; inline
: S_RUNPKT { PKTBIT } flags ; inline
: S_WAIT { WAITBIT } flags ; inline
: S_WAITPKT { WAITBIT PKTBIT } flags ; inline
: S_HOLD { HOLDBIT } flags ; inline
: S_HOLDPKT { HOLDBIT PKTBIT } flags ; inline
: S_HOLDWAIT { HOLDBIT WAITBIT } flags ; inline
: S_HOLDWAITPKT { HOLDBIT WAITBIT PKTBIT } flags ; inline
: task-tab-size 10 ; inline
VALUE: task-tab
VALUE: task-list
VALUE: tracing
VALUE: hold-count
VALUE: qpkt-count
TUPLE: task link id pri wkq state ;
: new-task ( id pri wkq state class -- task )
new
swap >>state
swap >>wkq
swap >>pri
swap >>id
task-list >>link
dup to: task-list
dup dup id>> task-tab set-nth ; inline
GENERIC: fn ( packet task -- task )
: state-on ( task flag -- task )
'[ _ bitor ] change-state ; inline
: state-off ( task flag -- task )
'[ _ bitnot bitand ] change-state ; inline
: wait-task ( task -- task )
WAITBIT state-on ;
: hold ( task -- task )
hold-count 1+ to: hold-count
HOLDBIT state-on
link>> ;
: highest-priority ( t1 t2 -- t1/t2 )
[ [ pri>> ] bi@ > ] most ;
: find-tcb ( i -- task )
task-tab nth [ "Bad task" throw ] unless* ;
: release ( task i -- task )
find-tcb HOLDBIT state-off highest-priority ;
:: qpkt ( task pkt -- task )
[let | t [ pkt id>> find-tcb ] |
t [
qpkt-count 1+ to: qpkt-count
f pkt (>>link)
task id>> pkt (>>id)
t wkq>> [
pkt t wkq>> append-to t (>>wkq)
task
] [
pkt t (>>wkq)
t PKTBIT state-on drop
t task highest-priority
] if
] [ task ] if
] ;
: schedule-waitpkt ( task -- task pkt )
dup wkq>>
2dup link>> >>wkq drop
2dup S_RUNPKT S_RUN ? >>state drop ; inline
: schedule-run ( task pkt -- task )
swap fn ; inline
: schedule-wait ( task -- task )
link>> ; inline
: (schedule) ( task -- )
[
dup state>> {
{ S_WAITPKT [ schedule-waitpkt schedule-run (schedule) ] }
{ S_RUN [ f schedule-run (schedule) ] }
{ S_RUNPKT [ f schedule-run (schedule) ] }
{ S_WAIT [ schedule-wait (schedule) ] }
{ S_HOLD [ schedule-wait (schedule) ] }
{ S_HOLDPKT [ schedule-wait (schedule) ] }
{ S_HOLDWAIT [ schedule-wait (schedule) ] }
{ S_HOLDWAITPKT [ schedule-wait (schedule) ] }
[ 2drop ]
} case
] when* ;
: schedule ( -- )
task-list (schedule) ;
! Device task
TUPLE: device-task < task v1 ;
: <device-task> ( id pri wkq -- task )
dup S_WAITPKT S_WAIT ? device-task new-task ;
M:: device-task fn ( pkt task -- task )
pkt [
task dup v1>>
[ wait-task ]
[ [ f ] change-v1 swap qpkt ] if
] [ pkt task (>>v1) task hold ] if ;
TUPLE: handler-task < task workpkts devpkts ;
: <handler-task> ( id pri wkq -- task )
dup S_WAITPKT S_WAIT ? handler-task new-task ;
M:: handler-task fn ( pkt task -- task )
pkt [
task over kind>> K_WORK =
[ [ append-to ] change-workpkts ]
[ [ append-to ] change-devpkts ]
if drop
] when*
task workpkts>> [
[let* | devpkt [ task devpkts>> ]
workpkt [ task workpkts>> ]
count [ workpkt a1>> ] |
count BUFSIZE > [
workpkt link>> task (>>workpkts)
task workpkt qpkt
] [
devpkt [
devpkt link>> task (>>devpkts)
count workpkt a2>> nth devpkt (>>a1)
count 1+ workpkt (>>a1)
task devpkt qpkt
] [
task wait-task
] if
] if
]
] [ task wait-task ] if ;
! Idle task
TUPLE: idle-task < task { v1 fixnum } { v2 fixnum } ;
: <idle-task> ( i a1 a2 -- task )
[ 0 f S_RUN idle-task new-task ] 2dip
[ >>v1 ] [ >>v2 ] bi* ;
M: idle-task fn ( pkt task -- task )
nip
[ 1- ] change-v2
dup v2>> 0 = [ hold ] [
dup v1>> 1 bitand 0 = [
[ -1 shift ] change-v1
I_DEVA release
] [
[ -1 shift HEX: d008 bitor ] change-v1
I_DEVB release
] if
] if ;
! Work task
TUPLE: work-task < task { handler fixnum } { n fixnum } ;
: <work-task> ( id pri w -- work-task )
dup S_WAITPKT S_WAIT ? work-task new-task
I_HANDLERA >>handler
0 >>n ;
M:: work-task fn ( pkt task -- task )
pkt [
task [ I_HANDLERA = I_HANDLERB I_HANDLERA ? ] change-handler drop
task handler>> pkt (>>id)
0 pkt (>>a1)
BUFSIZE [| i |
task [ 1+ ] change-n drop
task n>> 26 > [ 1 task (>>n) ] when
task n>> 1 - CHAR: A + i pkt a2>> set-nth
] each
task pkt qpkt
] [ task wait-task ] if ;
! Main
: init ( -- )
task-tab-size f <array> to: task-tab
f to: tracing
0 to: hold-count
0 to: qpkt-count ;
: start ( -- )
I_IDLE 1 10000 <idle-task> drop
I_WORK 1000
f 0 K_WORK <packet> 0 K_WORK <packet>
<work-task> drop
I_HANDLERA 2000
f I_DEVA K_DEV <packet>
I_DEVA K_DEV <packet>
I_DEVA K_DEV <packet>
<handler-task> drop
I_HANDLERB 3000
f I_DEVB K_DEV <packet>
I_DEVB K_DEV <packet>
I_DEVB K_DEV <packet>
<handler-task> drop
I_DEVA 4000 f <device-task> drop
I_DEVB 4000 f <device-task> drop ;
: check ( -- )
qpkt-count 23246 assert=
hold-count 9297 assert= ;
: run ( -- )
init
start
schedule check ;