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

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

@ -1,7 +1,8 @@
IN: tools.deploy.tests IN: tools.deploy.tests
USING: tools.test system io.files kernel tools.deploy.config USING: tools.test system io.files kernel tools.deploy.config
tools.deploy.backend math sequences io.launcher arrays 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 -- ) : shake-and-bake ( vocab -- )
[ "test.image" temp-file delete-file ] ignore-errors [ "test.image" temp-file delete-file ] ignore-errors
@ -38,7 +39,7 @@ namespaces continuations layouts accessors ;
! [ ] [ "tetris" shake-and-bake ] unit-test ! [ ] [ "tetris" shake-and-bake ] unit-test
! !
! [ t ] [ 1500000 small-enough? ] unit-test ! [ t ] [ 1500000 small-enough? ] unit-test
!
[ ] [ "bunny" shake-and-bake ] unit-test [ ] [ "bunny" shake-and-bake ] unit-test
[ t ] [ 2500000 small-enough? ] unit-test [ t ] [ 2500000 small-enough? ] unit-test
@ -71,22 +72,24 @@ M: quit-responder call-responder*
: add-quot-responder ( responder -- responder ) : add-quot-responder ( responder -- responder )
quit-responder "quit" add-responder ; quit-responder "quit" add-responder ;
: test-httpd ( -- ) : test-httpd ( responder -- )
#! Return as soon as server is running. [
<http-server> main-responder set
1237 >>insecure <http-server>
f >>secure 0 >>insecure
start-server* ; 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>
<dispatcher> add-quot-responder
add-quot-responder "resource:basis/http/test" <static> >>default
"resource:basis/http/test" <static> >>default
main-responder set
test-httpd test-httpd
] with-scope
] unit-test ] unit-test
[ ] [ [ ] [
@ -94,7 +97,10 @@ M: quit-responder call-responder*
run-temp-image run-temp-image
] unit-test ] 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 "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 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 ( -- ) : 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 MAIN: deploy-test-5

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

@ -12,6 +12,7 @@ SYMBOL: failures
error-continuation get 3array ; error-continuation get 3array ;
: failure ( error what -- ) : failure ( error what -- )
"--> test failed!" print
<failure> failures get push ; <failure> failures get push ;
SYMBOL: this-test 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 ui.tools.listener hashtables kernel namespaces parser sequences
tools.test ui.commands ui.gadgets ui.gadgets.editors tools.test ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.panes vocabs words tools.test.ui slots.private 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 IN: ui.tools.listener.tests
[ f ] [ "word" source-editor command-map commands>> empty? ] unit-test [ 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 [ ] [ "listener" get com-end ] unit-test
] with-grafted-gadget ] 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 ; "engine-generic" word-prop word-completion-string ;
: use-if-necessary ( word seq -- ) : use-if-necessary ( word seq -- )
over vocabulary>> [ over vocabulary>> over and [
2dup assoc-stack pick = [ 2drop ] [ 2dup [ assoc-stack ] keep = [ 2drop ] [
>r vocabulary>> vocab-words r> push >r vocabulary>> vocab-words r> push
] if ] if
] [ 2drop ] if ; ] [ 2drop ] if ;
@ -114,9 +114,10 @@ M: engine-word word-completion-string
2bi ; 2bi ;
: quot-action ( interactor -- lines ) : quot-action ( interactor -- lines )
dup control-value [ control-value ] keep
dup "\n" join pick add-interactor-history [ [ "\n" join ] dip add-interactor-history ]
swap select-all ; [ select-all ]
2bi ;
TUPLE: stack-display < track ; TUPLE: stack-display < track ;

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

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

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

@ -138,8 +138,12 @@ ERROR: bad-superclass class ;
: define-tuple-prototype ( class -- ) : define-tuple-prototype ( class -- )
dup tuple-prototype "prototype" set-word-prop ; dup tuple-prototype "prototype" set-word-prop ;
: prepare-slots ( slots superclass -- slots' )
[ make-slots ] [ class-size 2 + ] bi* finalize-slots ;
: define-tuple-slots ( class -- ) : 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 ) : make-tuple-layout ( class -- layout )
[ ] [ ]
@ -242,7 +246,7 @@ PRIVATE>
: define-tuple-class ( class superclass slots -- ) : define-tuple-class ( class superclass slots -- )
over check-superclass over check-superclass
make-slots over class-size 2 + finalize-slots over prepare-slots
(define-tuple-class) ; (define-tuple-class) ;
M: word (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 ! Copyright (C) 2008 Slava Pestov.
io.streams.duplex debugger tools.time prettyprint ! See http://factorcode.org/license.txt for BSD license.
concurrency.count-downs namespaces arrays continuations USING: accessors kernel math threads io io.sockets
destructors ; io.encodings.ascii io.streams.duplex debugger tools.time
prettyprint concurrency.count-downs concurrency.promises
namespaces arrays continuations destructors ;
IN: benchmark.sockets IN: benchmark.sockets
SYMBOL: counter SYMBOL: counter
SYMBOL: port-promise
SYMBOL: server
: number-of-requests 1000 ; : 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 -- ) : server-loop ( server -- )
dup accept drop [ dup accept drop [
[ [
read1 CHAR: x = [ read1 CHAR: x = [
"server" get dispose server get dispose
] [ ] [
number-of-requests number-of-requests
[ read1 write1 flush ] times [ read1 write1 flush ] times
@ -25,9 +30,11 @@ SYMBOL: counter
: simple-server ( -- ) : simple-server ( -- )
[ [
server-addr ascii <server> dup "server" set [ "127.0.0.1" 0 <inet4> ascii <server>
server-loop [ server set ]
] with-disposal [ addr>> port>> port-promise get fulfill ]
[ [ server-loop ] with-disposal ]
tri
] ignore-errors ; ] ignore-errors ;
: simple-client ( -- ) : simple-client ( -- )
@ -47,6 +54,7 @@ SYMBOL: counter
: clients ( n -- ) : clients ( n -- )
dup pprint " clients: " write [ dup pprint " clients: " write [
<promise> port-promise set
dup 2 * <count-down> counter set dup 2 * <count-down> counter set
[ simple-server ] "Simple server" spawn drop [ simple-server ] "Simple server" spawn drop
yield yield yield yield

13
extra/tetris/deploy.factor
View File

@ -1,12 +1,15 @@
USING: tools.deploy.config ; USING: tools.deploy.config ;
V{ H{
{ deploy-ui? t } { deploy-ui? t }
{ deploy-io 1 }
{ deploy-reflection 1 }
{ deploy-compiler? t } { deploy-compiler? t }
{ deploy-math? t } { deploy-threads? t }
{ deploy-word-props? f } { deploy-word-props? f }
{ deploy-c-types? f } { deploy-reflection 1 }
{ "stop-after-last-window?" t } { "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" } { 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 ;