Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
dbac0a1543
|
|
@ -89,6 +89,11 @@ set_md5sum() {
|
||||||
set_gcc() {
|
set_gcc() {
|
||||||
case $OS in
|
case $OS in
|
||||||
openbsd) ensure_program_installed egcc; CC=egcc;;
|
openbsd) ensure_program_installed egcc; CC=egcc;;
|
||||||
|
netbsd) if [[ $WORD -eq 64 ]] ; then
|
||||||
|
CC=/usr/pkg/gcc34/bin/gcc
|
||||||
|
else
|
||||||
|
CC=gcc
|
||||||
|
fi ;;
|
||||||
*) CC=gcc;;
|
*) CC=gcc;;
|
||||||
esac
|
esac
|
||||||
}
|
}
|
||||||
|
|
@ -185,6 +190,7 @@ find_architecture() {
|
||||||
i386) ARCH=x86;;
|
i386) ARCH=x86;;
|
||||||
i686) ARCH=x86;;
|
i686) ARCH=x86;;
|
||||||
amd64) ARCH=x86;;
|
amd64) ARCH=x86;;
|
||||||
|
ppc64) ARCH=ppc;;
|
||||||
*86) ARCH=x86;;
|
*86) ARCH=x86;;
|
||||||
*86_64) ARCH=x86;;
|
*86_64) ARCH=x86;;
|
||||||
"Power Macintosh") ARCH=ppc;;
|
"Power Macintosh") ARCH=ppc;;
|
||||||
|
|
|
||||||
|
|
@ -90,7 +90,11 @@ ABOUT: "continuations"
|
||||||
|
|
||||||
HELP: dispose
|
HELP: dispose
|
||||||
{ $values { "object" "a disposable object" } }
|
{ $values { "object" "a disposable object" } }
|
||||||
{ $contract "Releases operating system resources associated with a disposable object. No further operations can be performed on a disposable object after this call. Disposable objects include streams, memory mapped files, and so on." }
|
{ $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on."
|
||||||
|
$nl
|
||||||
|
"No further operations can be performed on a disposable object after this call."
|
||||||
|
$nl
|
||||||
|
"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error." }
|
||||||
{ $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word." } ;
|
{ $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word." } ;
|
||||||
|
|
||||||
HELP: with-disposal
|
HELP: with-disposal
|
||||||
|
|
|
||||||
|
|
@ -2,26 +2,6 @@ IN: definitions.tests
|
||||||
USING: tools.test generic kernel definitions sequences
|
USING: tools.test generic kernel definitions sequences
|
||||||
compiler.units words ;
|
compiler.units words ;
|
||||||
|
|
||||||
TUPLE: combination-1 ;
|
|
||||||
|
|
||||||
M: combination-1 perform-combination drop [ ] define ;
|
|
||||||
|
|
||||||
M: combination-1 make-default-method 2drop [ "No method" throw ] ;
|
|
||||||
|
|
||||||
SYMBOL: generic-1
|
|
||||||
|
|
||||||
[
|
|
||||||
generic-1 T{ combination-1 } define-generic
|
|
||||||
|
|
||||||
object \ generic-1 create-method [ ] define
|
|
||||||
] with-compilation-unit
|
|
||||||
|
|
||||||
[ ] [
|
|
||||||
[
|
|
||||||
{ combination-1 { object generic-1 } } forget-all
|
|
||||||
] with-compilation-unit
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
GENERIC: some-generic ( a -- b )
|
GENERIC: some-generic ( a -- b )
|
||||||
|
|
||||||
USE: arrays
|
USE: arrays
|
||||||
|
|
|
||||||
|
|
@ -110,6 +110,9 @@ ERROR: no-next-method class generic ;
|
||||||
\ if ,
|
\ if ,
|
||||||
] [ ] make ;
|
] [ ] make ;
|
||||||
|
|
||||||
|
: single-effective-method ( obj word -- method )
|
||||||
|
[ order [ instance? ] with find-last nip ] keep method ;
|
||||||
|
|
||||||
TUPLE: standard-combination # ;
|
TUPLE: standard-combination # ;
|
||||||
|
|
||||||
C: <standard-combination> standard-combination
|
C: <standard-combination> standard-combination
|
||||||
|
|
@ -142,8 +145,7 @@ M: standard-combination next-method-quot*
|
||||||
] with-standard ;
|
] with-standard ;
|
||||||
|
|
||||||
M: standard-generic effective-method
|
M: standard-generic effective-method
|
||||||
[ dispatch# (picker) call ] keep
|
[ dispatch# (picker) call ] keep single-effective-method ;
|
||||||
[ order [ instance? ] with find-last nip ] keep method ;
|
|
||||||
|
|
||||||
TUPLE: hook-combination var ;
|
TUPLE: hook-combination var ;
|
||||||
|
|
||||||
|
|
@ -161,6 +163,10 @@ M: hook-combination dispatch# drop 0 ;
|
||||||
|
|
||||||
M: hook-generic extra-values drop 1 ;
|
M: hook-generic extra-values drop 1 ;
|
||||||
|
|
||||||
|
M: hook-generic effective-method
|
||||||
|
[ "combination" word-prop var>> get ] keep
|
||||||
|
single-effective-method ;
|
||||||
|
|
||||||
M: hook-combination make-default-method
|
M: hook-combination make-default-method
|
||||||
[ error-method ] with-hook ;
|
[ error-method ] with-hook ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -112,8 +112,7 @@ ARTICLE: "io.files" "Basic file operations"
|
||||||
{ $subsection "file-streams" }
|
{ $subsection "file-streams" }
|
||||||
{ $subsection "fs-meta" }
|
{ $subsection "fs-meta" }
|
||||||
{ $subsection "directories" }
|
{ $subsection "directories" }
|
||||||
{ $subsection "delete-move-copy" }
|
{ $subsection "delete-move-copy" } ;
|
||||||
{ $see-also "os" } ;
|
|
||||||
|
|
||||||
ABOUT: "io.files"
|
ABOUT: "io.files"
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -4,7 +4,7 @@
|
||||||
IN: threads
|
IN: threads
|
||||||
USING: arrays hashtables heaps kernel kernel.private math
|
USING: arrays hashtables heaps kernel kernel.private math
|
||||||
namespaces sequences vectors continuations continuations.private
|
namespaces sequences vectors continuations continuations.private
|
||||||
dlists assocs system combinators init boxes ;
|
dlists assocs system combinators init boxes accessors ;
|
||||||
|
|
||||||
SYMBOL: initial-thread
|
SYMBOL: initial-thread
|
||||||
|
|
||||||
|
|
@ -18,11 +18,10 @@ mailbox variables sleep-entry ;
|
||||||
|
|
||||||
! Thread-local storage
|
! Thread-local storage
|
||||||
: tnamespace ( -- assoc )
|
: tnamespace ( -- assoc )
|
||||||
self dup thread-variables
|
self variables>> [ H{ } clone dup self (>>variables) ] unless* ;
|
||||||
[ ] [ H{ } clone dup rot set-thread-variables ] ?if ;
|
|
||||||
|
|
||||||
: tget ( key -- value )
|
: tget ( key -- value )
|
||||||
self thread-variables at ;
|
self variables>> at ;
|
||||||
|
|
||||||
: tset ( value key -- )
|
: tset ( value key -- )
|
||||||
tnamespace set-at ;
|
tnamespace set-at ;
|
||||||
|
|
@ -35,7 +34,7 @@ mailbox variables sleep-entry ;
|
||||||
: thread ( id -- thread ) threads at ;
|
: thread ( id -- thread ) threads at ;
|
||||||
|
|
||||||
: thread-registered? ( thread -- ? )
|
: thread-registered? ( thread -- ? )
|
||||||
thread-id threads key? ;
|
id>> threads key? ;
|
||||||
|
|
||||||
: check-unregistered
|
: check-unregistered
|
||||||
dup thread-registered?
|
dup thread-registered?
|
||||||
|
|
@ -48,38 +47,37 @@ mailbox variables sleep-entry ;
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: register-thread ( thread -- )
|
: register-thread ( thread -- )
|
||||||
check-unregistered dup thread-id threads set-at ;
|
check-unregistered dup id>> threads set-at ;
|
||||||
|
|
||||||
: unregister-thread ( thread -- )
|
: unregister-thread ( thread -- )
|
||||||
check-registered thread-id threads delete-at ;
|
check-registered id>> threads delete-at ;
|
||||||
|
|
||||||
: set-self ( thread -- ) 40 setenv ; inline
|
: set-self ( thread -- ) 40 setenv ; inline
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: <thread> ( quot name -- thread )
|
: <thread> ( quot name -- thread )
|
||||||
\ thread counter <box> [ ] {
|
\ thread construct-empty
|
||||||
set-thread-quot
|
swap >>name
|
||||||
set-thread-name
|
swap >>quot
|
||||||
set-thread-id
|
\ thread counter >>id
|
||||||
set-thread-continuation
|
<box> >>continuation
|
||||||
set-thread-exit-handler
|
[ ] >>exit-handler ;
|
||||||
} \ thread construct ;
|
|
||||||
|
|
||||||
: run-queue 42 getenv ;
|
: run-queue 42 getenv ;
|
||||||
|
|
||||||
: sleep-queue 43 getenv ;
|
: sleep-queue 43 getenv ;
|
||||||
|
|
||||||
: resume ( thread -- )
|
: resume ( thread -- )
|
||||||
f over set-thread-state
|
f >>state
|
||||||
check-registered run-queue push-front ;
|
check-registered run-queue push-front ;
|
||||||
|
|
||||||
: resume-now ( thread -- )
|
: resume-now ( thread -- )
|
||||||
f over set-thread-state
|
f >>state
|
||||||
check-registered run-queue push-back ;
|
check-registered run-queue push-back ;
|
||||||
|
|
||||||
: resume-with ( obj thread -- )
|
: resume-with ( obj thread -- )
|
||||||
f over set-thread-state
|
f >>state
|
||||||
check-registered 2array run-queue push-front ;
|
check-registered 2array run-queue push-front ;
|
||||||
|
|
||||||
: sleep-time ( -- ms/f )
|
: sleep-time ( -- ms/f )
|
||||||
|
|
@ -93,14 +91,14 @@ PRIVATE>
|
||||||
|
|
||||||
: schedule-sleep ( thread ms -- )
|
: schedule-sleep ( thread ms -- )
|
||||||
>r check-registered dup r> sleep-queue heap-push*
|
>r check-registered dup r> sleep-queue heap-push*
|
||||||
swap set-thread-sleep-entry ;
|
>>sleep-entry drop ;
|
||||||
|
|
||||||
: expire-sleep? ( heap -- ? )
|
: expire-sleep? ( heap -- ? )
|
||||||
dup heap-empty?
|
dup heap-empty?
|
||||||
[ drop f ] [ heap-peek nip millis <= ] if ;
|
[ drop f ] [ heap-peek nip millis <= ] if ;
|
||||||
|
|
||||||
: expire-sleep ( thread -- )
|
: expire-sleep ( thread -- )
|
||||||
f over set-thread-sleep-entry resume ;
|
f >>sleep-entry resume ;
|
||||||
|
|
||||||
: expire-sleep-loop ( -- )
|
: expire-sleep-loop ( -- )
|
||||||
sleep-queue
|
sleep-queue
|
||||||
|
|
@ -123,21 +121,21 @@ PRIVATE>
|
||||||
] [
|
] [
|
||||||
pop-back
|
pop-back
|
||||||
dup array? [ first2 ] [ f swap ] if dup set-self
|
dup array? [ first2 ] [ f swap ] if dup set-self
|
||||||
f over set-thread-state
|
f >>state
|
||||||
thread-continuation box>
|
continuation>> box>
|
||||||
continue-with
|
continue-with
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: stop ( -- )
|
: stop ( -- )
|
||||||
self dup thread-exit-handler call
|
self dup exit-handler>> call
|
||||||
unregister-thread next ;
|
unregister-thread next ;
|
||||||
|
|
||||||
: suspend ( quot state -- obj )
|
: suspend ( quot state -- obj )
|
||||||
[
|
[
|
||||||
self thread-continuation >box
|
self continuation>> >box
|
||||||
self set-thread-state
|
self (>>state)
|
||||||
self swap call next
|
self swap call next
|
||||||
] callcc1 2nip ; inline
|
] callcc1 2nip ; inline
|
||||||
|
|
||||||
|
|
@ -157,9 +155,9 @@ M: real sleep
|
||||||
millis + >integer sleep-until ;
|
millis + >integer sleep-until ;
|
||||||
|
|
||||||
: interrupt ( thread -- )
|
: interrupt ( thread -- )
|
||||||
dup thread-state [
|
dup state>> [
|
||||||
dup thread-sleep-entry [ sleep-queue heap-delete ] when*
|
dup sleep-entry>> [ sleep-queue heap-delete ] when*
|
||||||
f over set-thread-sleep-entry
|
f >>sleep-entry
|
||||||
dup resume
|
dup resume
|
||||||
] when drop ;
|
] when drop ;
|
||||||
|
|
||||||
|
|
@ -171,7 +169,7 @@ M: real sleep
|
||||||
V{ } set-catchstack
|
V{ } set-catchstack
|
||||||
{ } set-retainstack
|
{ } set-retainstack
|
||||||
>r { } set-datastack r>
|
>r { } set-datastack r>
|
||||||
thread-quot [ call stop ] call-clear
|
quot>> [ call stop ] call-clear
|
||||||
] 1 (throw)
|
] 1 (throw)
|
||||||
] "spawn" suspend 2drop ;
|
] "spawn" suspend 2drop ;
|
||||||
|
|
||||||
|
|
@ -196,8 +194,8 @@ GENERIC: error-in-thread ( error thread -- )
|
||||||
<min-heap> 43 setenv
|
<min-heap> 43 setenv
|
||||||
initial-thread global
|
initial-thread global
|
||||||
[ drop f "Initial" <thread> ] cache
|
[ drop f "Initial" <thread> ] cache
|
||||||
<box> over set-thread-continuation
|
<box> >>continuation
|
||||||
f over set-thread-state
|
f >>state
|
||||||
dup register-thread
|
dup register-thread
|
||||||
set-self ;
|
set-self ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -110,6 +110,8 @@ IN: vocabs.loader.tests
|
||||||
] with-compilation-unit
|
] with-compilation-unit
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
[ ] [ "vocabs.loader.test.b" changed-vocab ] unit-test
|
||||||
|
|
||||||
[ ] [ "vocabs.loader.test.b" refresh ] unit-test
|
[ ] [ "vocabs.loader.test.b" refresh ] unit-test
|
||||||
|
|
||||||
[ 3 ] [ "count-me" get-global ] unit-test
|
[ 3 ] [ "count-me" get-global ] unit-test
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,88 @@
|
||||||
|
|
||||||
|
USING: kernel namespaces sequences random math math.constants math.libm vars
|
||||||
|
ui
|
||||||
|
processing
|
||||||
|
processing.gadget
|
||||||
|
bubble-chamber.common
|
||||||
|
bubble-chamber.particle
|
||||||
|
bubble-chamber.particle.muon
|
||||||
|
bubble-chamber.particle.quark
|
||||||
|
bubble-chamber.particle.hadron
|
||||||
|
bubble-chamber.particle.axion ;
|
||||||
|
|
||||||
|
IN: bubble-chamber
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
VARS: particles muons quarks hadrons axions ;
|
||||||
|
|
||||||
|
VAR: boom
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: collide-all ( -- )
|
||||||
|
|
||||||
|
2 pi * 1random >collision-theta
|
||||||
|
|
||||||
|
particles> [ collide ] each ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: collide-one ( -- )
|
||||||
|
|
||||||
|
dim 2 / mouse-x - dim 2 / mouse-y - fatan2 >collision-theta
|
||||||
|
|
||||||
|
hadrons> random collide
|
||||||
|
quarks> random collide
|
||||||
|
muons> random collide ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: mouse-pressed ( -- )
|
||||||
|
boom on
|
||||||
|
1 background ! kludge
|
||||||
|
11 [ drop collide-one ] each ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: key-released ( -- )
|
||||||
|
key " " =
|
||||||
|
[
|
||||||
|
boom on
|
||||||
|
1 background
|
||||||
|
collide-all
|
||||||
|
]
|
||||||
|
when ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: bubble-chamber ( -- )
|
||||||
|
|
||||||
|
1000 1000 size*
|
||||||
|
|
||||||
|
[
|
||||||
|
1 background
|
||||||
|
no-stroke
|
||||||
|
|
||||||
|
1789 [ drop <muon> ] map >muons
|
||||||
|
1300 [ drop <quark> ] map >quarks
|
||||||
|
1000 [ drop <hadron> ] map >hadrons
|
||||||
|
111 [ drop <axion> ] map >axions
|
||||||
|
|
||||||
|
muons> quarks> hadrons> axions> 3append append >particles
|
||||||
|
|
||||||
|
collide-one
|
||||||
|
] setup
|
||||||
|
|
||||||
|
[
|
||||||
|
boom>
|
||||||
|
[ particles> [ move ] each ]
|
||||||
|
when
|
||||||
|
] draw
|
||||||
|
|
||||||
|
[ mouse-pressed ] button-down
|
||||||
|
[ key-released ] key-up ;
|
||||||
|
|
||||||
|
: go ( -- ) [ bubble-chamber run ] with-ui ;
|
||||||
|
|
||||||
|
MAIN: go
|
||||||
|
|
@ -0,0 +1,12 @@
|
||||||
|
|
||||||
|
USING: kernel math accessors combinators.cleave vars ;
|
||||||
|
|
||||||
|
IN: bubble-chamber.common
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
VAR: collision-theta
|
||||||
|
|
||||||
|
: dim ( -- dim ) 1000 ;
|
||||||
|
|
||||||
|
: center ( -- point ) dim 2 / dup {2} ; foldable
|
||||||
|
|
@ -0,0 +1,67 @@
|
||||||
|
|
||||||
|
USING: kernel sequences random accessors multi-methods
|
||||||
|
math math.constants math.ranges math.points combinators.cleave
|
||||||
|
processing bubble-chamber.common bubble-chamber.particle ;
|
||||||
|
|
||||||
|
IN: bubble-chamber.particle.axion
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
TUPLE: axion < particle ;
|
||||||
|
|
||||||
|
: <axion> ( -- axion ) axion construct-empty initialize-particle ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
METHOD: collide { axion }
|
||||||
|
|
||||||
|
center >>pos
|
||||||
|
2 pi * 1random >>theta
|
||||||
|
1.0 6.0 2random >>speed
|
||||||
|
0.998 1.000 2random >>speed-d
|
||||||
|
0 >>theta-d
|
||||||
|
0 >>theta-dd
|
||||||
|
|
||||||
|
[ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
|
||||||
|
|
||||||
|
drop ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: dy>alpha ( dy -- alpha ) neg 6 * 30 + 255.0 / ;
|
||||||
|
|
||||||
|
: axion-white ( dy -- dy ) dup 1 swap dy>alpha {2} stroke ;
|
||||||
|
: axion-black ( dy -- dy ) dup 0 swap dy>alpha {2} stroke ;
|
||||||
|
|
||||||
|
: axion-point- ( particle dy -- particle ) >r dup pos>> r> v-y point ;
|
||||||
|
: axion-point+ ( particle dy -- particle ) >r dup pos>> r> v+y point ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
METHOD: move { axion }
|
||||||
|
|
||||||
|
{ 0.06 0.59 } stroke
|
||||||
|
dup pos>> point
|
||||||
|
|
||||||
|
1 4 [a,b] [ axion-white axion-point- ] each
|
||||||
|
1 4 [a,b] [ axion-black axion-point+ ] each
|
||||||
|
|
||||||
|
dup vel>> move-by
|
||||||
|
|
||||||
|
turn
|
||||||
|
|
||||||
|
step-theta
|
||||||
|
step-theta-d
|
||||||
|
step-speed-mul
|
||||||
|
|
||||||
|
[ ] [ speed-d>> 0.9999 * ] bi >>speed-d
|
||||||
|
|
||||||
|
1000 random 996 >
|
||||||
|
[
|
||||||
|
dup speed>> neg >>speed
|
||||||
|
dup speed-d>> neg 2 + >>speed-d
|
||||||
|
|
||||||
|
100 random 30 > [ collide ] [ drop ] if
|
||||||
|
]
|
||||||
|
[ drop ]
|
||||||
|
if ;
|
||||||
|
|
@ -0,0 +1,60 @@
|
||||||
|
|
||||||
|
USING: kernel random math math.constants math.points accessors multi-methods
|
||||||
|
processing
|
||||||
|
processing.color
|
||||||
|
bubble-chamber.common
|
||||||
|
bubble-chamber.particle ;
|
||||||
|
|
||||||
|
IN: bubble-chamber.particle.hadron
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
TUPLE: hadron < particle ;
|
||||||
|
|
||||||
|
: <hadron> ( -- hadron ) hadron construct-empty initialize-particle ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
METHOD: collide { hadron }
|
||||||
|
|
||||||
|
center >>pos
|
||||||
|
2 pi * 1random >>theta
|
||||||
|
0.5 3.5 2random >>speed
|
||||||
|
0.996 1.001 2random >>speed-d
|
||||||
|
0 >>theta-d
|
||||||
|
0 >>theta-dd
|
||||||
|
|
||||||
|
[ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
|
||||||
|
|
||||||
|
0 1 0 <rgb> >>myc
|
||||||
|
|
||||||
|
drop ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
METHOD: move { hadron }
|
||||||
|
|
||||||
|
{ 1 0.11 } stroke
|
||||||
|
dup pos>> 1 v-y point
|
||||||
|
|
||||||
|
{ 0 0.11 } stroke
|
||||||
|
dup pos>> 1 v+y point
|
||||||
|
|
||||||
|
dup vel>> move-by
|
||||||
|
|
||||||
|
turn
|
||||||
|
|
||||||
|
step-theta
|
||||||
|
step-theta-d
|
||||||
|
step-speed-mul
|
||||||
|
|
||||||
|
1000 random 997 >
|
||||||
|
[
|
||||||
|
1.0 >>speed-d
|
||||||
|
0.00001 >>theta-dd
|
||||||
|
|
||||||
|
100 random 70 > [ dup collide ] when
|
||||||
|
]
|
||||||
|
when
|
||||||
|
|
||||||
|
out-of-bounds? [ collide ] [ drop ] if ;
|
||||||
|
|
@ -0,0 +1,53 @@
|
||||||
|
|
||||||
|
USING: kernel sequences math math.constants accessors
|
||||||
|
processing
|
||||||
|
processing.color ;
|
||||||
|
|
||||||
|
IN: bubble-chamber.particle.muon.colors
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: good-colors ( -- seq )
|
||||||
|
{
|
||||||
|
T{ rgba f 0.23 0.14 0.17 1 }
|
||||||
|
T{ rgba f 0.23 0.14 0.15 1 }
|
||||||
|
T{ rgba f 0.21 0.14 0.15 1 }
|
||||||
|
T{ rgba f 0.51 0.39 0.33 1 }
|
||||||
|
T{ rgba f 0.49 0.33 0.20 1 }
|
||||||
|
T{ rgba f 0.55 0.45 0.32 1 }
|
||||||
|
T{ rgba f 0.69 0.63 0.51 1 }
|
||||||
|
T{ rgba f 0.64 0.39 0.18 1 }
|
||||||
|
T{ rgba f 0.73 0.42 0.20 1 }
|
||||||
|
T{ rgba f 0.71 0.45 0.29 1 }
|
||||||
|
T{ rgba f 0.79 0.45 0.22 1 }
|
||||||
|
T{ rgba f 0.82 0.56 0.34 1 }
|
||||||
|
T{ rgba f 0.88 0.72 0.49 1 }
|
||||||
|
T{ rgba f 0.85 0.69 0.40 1 }
|
||||||
|
T{ rgba f 0.96 0.92 0.75 1 }
|
||||||
|
T{ rgba f 0.99 0.98 0.87 1 }
|
||||||
|
T{ rgba f 0.85 0.82 0.69 1 }
|
||||||
|
T{ rgba f 0.99 0.98 0.87 1 }
|
||||||
|
T{ rgba f 0.82 0.82 0.79 1 }
|
||||||
|
T{ rgba f 0.65 0.69 0.67 1 }
|
||||||
|
T{ rgba f 0.53 0.60 0.55 1 }
|
||||||
|
T{ rgba f 0.57 0.53 0.68 1 }
|
||||||
|
T{ rgba f 0.47 0.42 0.56 1 }
|
||||||
|
} ;
|
||||||
|
|
||||||
|
: anti-colors ( -- seq ) good-colors <reversed> ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: color-fraction ( particle -- particle fraction ) dup theta>> pi + 2 pi * / ;
|
||||||
|
|
||||||
|
: set-good-color ( particle -- particle )
|
||||||
|
color-fraction dup 0 1 between?
|
||||||
|
[ good-colors at-fraction-of >>myc ]
|
||||||
|
[ drop ]
|
||||||
|
if ;
|
||||||
|
|
||||||
|
: set-anti-color ( particle -- particle )
|
||||||
|
color-fraction dup 0 1 between?
|
||||||
|
[ anti-colors at-fraction-of >>mya ]
|
||||||
|
[ drop ]
|
||||||
|
if ;
|
||||||
|
|
@ -0,0 +1,62 @@
|
||||||
|
|
||||||
|
USING: kernel arrays sequences random
|
||||||
|
math
|
||||||
|
math.ranges
|
||||||
|
math.functions
|
||||||
|
math.vectors
|
||||||
|
multi-methods accessors
|
||||||
|
combinators.cleave
|
||||||
|
processing
|
||||||
|
bubble-chamber.common
|
||||||
|
bubble-chamber.particle
|
||||||
|
bubble-chamber.particle.muon.colors ;
|
||||||
|
|
||||||
|
IN: bubble-chamber.particle.muon
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
TUPLE: muon < particle ;
|
||||||
|
|
||||||
|
: <muon> ( -- muon ) muon construct-empty initialize-particle ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
METHOD: collide { muon }
|
||||||
|
|
||||||
|
center >>pos
|
||||||
|
2 32 [a,b] random >>speed
|
||||||
|
0.0001 0.001 2random >>speed-d
|
||||||
|
|
||||||
|
collision-theta> -0.1 0.1 2random + >>theta
|
||||||
|
0 >>theta-d
|
||||||
|
0 >>theta-dd
|
||||||
|
|
||||||
|
[ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] [ ] while
|
||||||
|
|
||||||
|
set-good-color
|
||||||
|
set-anti-color
|
||||||
|
|
||||||
|
drop ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
METHOD: move { muon }
|
||||||
|
|
||||||
|
dup myc>> 0.16 >>alpha stroke
|
||||||
|
dup pos>> point
|
||||||
|
|
||||||
|
dup mya>> 0.16 >>alpha stroke
|
||||||
|
dup pos>> first2 >r dim swap - r> 2array point
|
||||||
|
|
||||||
|
dup
|
||||||
|
[ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
|
||||||
|
move-by
|
||||||
|
|
||||||
|
step-theta
|
||||||
|
step-theta-d
|
||||||
|
step-speed-sub
|
||||||
|
|
||||||
|
out-of-bounds? [ collide ] [ drop ] if ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
|
@ -0,0 +1,68 @@
|
||||||
|
|
||||||
|
USING: kernel sequences combinators
|
||||||
|
math math.vectors math.functions multi-methods
|
||||||
|
accessors combinators.cleave processing processing.color
|
||||||
|
bubble-chamber.common ;
|
||||||
|
|
||||||
|
IN: bubble-chamber.particle
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
GENERIC: collide ( particle -- )
|
||||||
|
GENERIC: move ( particle -- )
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
TUPLE: particle pos vel speed speed-d theta theta-d theta-dd myc mya ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: initialize-particle ( particle -- particle )
|
||||||
|
|
||||||
|
0 0 {2} >>pos
|
||||||
|
0 0 {2} >>vel
|
||||||
|
|
||||||
|
0 >>speed
|
||||||
|
0 >>speed-d
|
||||||
|
0 >>theta
|
||||||
|
0 >>theta-d
|
||||||
|
0 >>theta-dd
|
||||||
|
|
||||||
|
0 0 0 1 <rgba> >>myc
|
||||||
|
0 0 0 1 <rgba> >>mya ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: move-by ( obj delta -- obj ) over pos>> v+ >>pos ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: theta-dd-small? ( par limit -- par ? ) >r dup theta-dd>> abs r> < ;
|
||||||
|
|
||||||
|
: random-theta-dd ( par a b -- par ) 2random >>theta-dd ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: turn ( particle -- particle )
|
||||||
|
dup
|
||||||
|
[ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
|
||||||
|
>>vel ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: step-theta ( p -- p ) [ ] [ theta>> ] [ theta-d>> ] tri + >>theta ;
|
||||||
|
: step-theta-d ( p -- p ) [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d ;
|
||||||
|
: step-speed-sub ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri - >>speed ;
|
||||||
|
: step-speed-mul ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri * >>speed ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: x ( particle -- x ) pos>> first ;
|
||||||
|
: y ( particle -- x ) pos>> second ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: out-of-bounds? ( particle -- particle ? )
|
||||||
|
dup
|
||||||
|
{ [ x dim neg < ] [ x dim 2 * > ] [ y dim neg < ] [ y dim 2 * > ] } cleave
|
||||||
|
or or or ;
|
||||||
|
|
@ -0,0 +1,53 @@
|
||||||
|
|
||||||
|
USING: kernel arrays sequences random math accessors multi-methods
|
||||||
|
processing
|
||||||
|
bubble-chamber.common
|
||||||
|
bubble-chamber.particle ;
|
||||||
|
|
||||||
|
IN: bubble-chamber.particle.quark
|
||||||
|
|
||||||
|
TUPLE: quark < particle ;
|
||||||
|
|
||||||
|
: <quark> ( -- quark ) quark construct-empty initialize-particle ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
METHOD: collide { quark }
|
||||||
|
|
||||||
|
center >>pos
|
||||||
|
collision-theta> -0.11 0.11 2random + >>theta
|
||||||
|
0.5 3.0 2random >>speed
|
||||||
|
|
||||||
|
0.996 1.001 2random >>speed-d
|
||||||
|
0 >>theta-d
|
||||||
|
0 >>theta-dd
|
||||||
|
|
||||||
|
[ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
|
||||||
|
|
||||||
|
drop ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
METHOD: move { quark }
|
||||||
|
|
||||||
|
dup myc>> 0.13 >>alpha stroke
|
||||||
|
dup pos>> point
|
||||||
|
|
||||||
|
dup pos>> first2 >r dim swap - r> 2array point
|
||||||
|
|
||||||
|
[ ] [ vel>> ] bi move-by
|
||||||
|
|
||||||
|
turn
|
||||||
|
|
||||||
|
step-theta
|
||||||
|
step-theta-d
|
||||||
|
step-speed-mul
|
||||||
|
|
||||||
|
1000 random 997 >
|
||||||
|
[
|
||||||
|
dup speed>> neg >>speed
|
||||||
|
2 over speed-d>> - >>speed-d
|
||||||
|
]
|
||||||
|
when
|
||||||
|
|
||||||
|
out-of-bounds? [ collide ] [ drop ] if ;
|
||||||
|
|
@ -57,7 +57,7 @@ HELP: mailbox-get?
|
||||||
|
|
||||||
|
|
||||||
ARTICLE: "concurrency.mailboxes" "Mailboxes"
|
ARTICLE: "concurrency.mailboxes" "Mailboxes"
|
||||||
"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty, instead of throwing an error."
|
"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty, instead of throwing an error. Mailboxes are implemented in the " { $vocab-link "concurrency.mailboxes" } " vocabulary."
|
||||||
{ $subsection mailbox }
|
{ $subsection mailbox }
|
||||||
{ $subsection <mailbox> }
|
{ $subsection <mailbox> }
|
||||||
"Removing the first element:"
|
"Removing the first element:"
|
||||||
|
|
@ -73,3 +73,5 @@ ARTICLE: "concurrency.mailboxes" "Mailboxes"
|
||||||
"Testing if a mailbox is empty:"
|
"Testing if a mailbox is empty:"
|
||||||
{ $subsection mailbox-empty? }
|
{ $subsection mailbox-empty? }
|
||||||
{ $subsection while-mailbox-empty } ;
|
{ $subsection while-mailbox-empty } ;
|
||||||
|
|
||||||
|
ABOUT: "concurrency.mailboxes"
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,7 @@
|
||||||
IN: concurrency.mailboxes.tests
|
IN: concurrency.mailboxes.tests
|
||||||
USING: concurrency.mailboxes vectors sequences threads
|
USING: concurrency.mailboxes concurrency.count-downs vectors
|
||||||
tools.test math kernel strings ;
|
sequences threads tools.test math kernel strings namespaces
|
||||||
|
continuations calendar ;
|
||||||
|
|
||||||
[ V{ 1 2 3 } ] [
|
[ V{ 1 2 3 } ] [
|
||||||
0 <vector>
|
0 <vector>
|
||||||
|
|
@ -38,3 +39,37 @@ tools.test math kernel strings ;
|
||||||
"junk2" over mailbox-put
|
"junk2" over mailbox-put
|
||||||
mailbox-get
|
mailbox-get
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
<mailbox> "m" set
|
||||||
|
|
||||||
|
1 <count-down> "c" set
|
||||||
|
1 <count-down> "d" set
|
||||||
|
|
||||||
|
[
|
||||||
|
"c" get await
|
||||||
|
[ "m" get mailbox-get drop ]
|
||||||
|
[ drop "d" get count-down ] recover
|
||||||
|
] "Mailbox close test" spawn drop
|
||||||
|
|
||||||
|
[ ] [ "c" get count-down ] unit-test
|
||||||
|
[ ] [ "m" get dispose ] unit-test
|
||||||
|
[ ] [ "d" get 5 seconds await-timeout ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "m" get dispose ] unit-test
|
||||||
|
|
||||||
|
<mailbox> "m" set
|
||||||
|
|
||||||
|
1 <count-down> "c" set
|
||||||
|
1 <count-down> "d" set
|
||||||
|
|
||||||
|
[
|
||||||
|
"c" get await
|
||||||
|
"m" get wait-for-close
|
||||||
|
"d" get count-down
|
||||||
|
] "Mailbox close test" spawn drop
|
||||||
|
|
||||||
|
[ ] [ "c" get count-down ] unit-test
|
||||||
|
[ ] [ "m" get dispose ] unit-test
|
||||||
|
[ ] [ "d" get 5 seconds await-timeout ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "m" get dispose ] unit-test
|
||||||
|
|
|
||||||
|
|
@ -3,41 +3,50 @@
|
||||||
IN: concurrency.mailboxes
|
IN: concurrency.mailboxes
|
||||||
USING: dlists threads sequences continuations
|
USING: dlists threads sequences continuations
|
||||||
namespaces random math quotations words kernel arrays assocs
|
namespaces random math quotations words kernel arrays assocs
|
||||||
init system concurrency.conditions ;
|
init system concurrency.conditions accessors ;
|
||||||
|
|
||||||
TUPLE: mailbox threads data ;
|
TUPLE: mailbox threads data closed ;
|
||||||
|
|
||||||
|
: check-closed ( mailbox -- )
|
||||||
|
closed>> [ "Mailbox closed" throw ] when ; inline
|
||||||
|
|
||||||
|
M: mailbox dispose
|
||||||
|
t >>closed threads>> notify-all ;
|
||||||
|
|
||||||
: <mailbox> ( -- mailbox )
|
: <mailbox> ( -- mailbox )
|
||||||
<dlist> <dlist> mailbox construct-boa ;
|
<dlist> <dlist> f mailbox construct-boa ;
|
||||||
|
|
||||||
: mailbox-empty? ( mailbox -- bool )
|
: mailbox-empty? ( mailbox -- bool )
|
||||||
mailbox-data dlist-empty? ;
|
data>> dlist-empty? ;
|
||||||
|
|
||||||
: mailbox-put ( obj mailbox -- )
|
: mailbox-put ( obj mailbox -- )
|
||||||
[ mailbox-data push-front ] keep
|
[ data>> push-front ]
|
||||||
mailbox-threads notify-all yield ;
|
[ threads>> notify-all ] bi yield ;
|
||||||
|
|
||||||
|
: wait-for-mailbox ( mailbox timeout -- )
|
||||||
|
>r threads>> r> "mailbox" wait ;
|
||||||
|
|
||||||
: block-unless-pred ( mailbox timeout pred -- )
|
: block-unless-pred ( mailbox timeout pred -- )
|
||||||
pick mailbox-data over dlist-contains? [
|
pick check-closed
|
||||||
|
pick data>> over dlist-contains? [
|
||||||
3drop
|
3drop
|
||||||
] [
|
] [
|
||||||
>r over mailbox-threads over "mailbox" wait r>
|
>r 2dup wait-for-mailbox r> block-unless-pred
|
||||||
block-unless-pred
|
|
||||||
] if ; inline
|
] if ; inline
|
||||||
|
|
||||||
: block-if-empty ( mailbox timeout -- mailbox )
|
: block-if-empty ( mailbox timeout -- mailbox )
|
||||||
|
over check-closed
|
||||||
over mailbox-empty? [
|
over mailbox-empty? [
|
||||||
over mailbox-threads over "mailbox" wait
|
2dup wait-for-mailbox block-if-empty
|
||||||
block-if-empty
|
|
||||||
] [
|
] [
|
||||||
drop
|
drop
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: mailbox-peek ( mailbox -- obj )
|
: mailbox-peek ( mailbox -- obj )
|
||||||
mailbox-data peek-back ;
|
data>> peek-back ;
|
||||||
|
|
||||||
: mailbox-get-timeout ( mailbox timeout -- obj )
|
: mailbox-get-timeout ( mailbox timeout -- obj )
|
||||||
block-if-empty mailbox-data pop-back ;
|
block-if-empty data>> pop-back ;
|
||||||
|
|
||||||
: mailbox-get ( mailbox -- obj )
|
: mailbox-get ( mailbox -- obj )
|
||||||
f mailbox-get-timeout ;
|
f mailbox-get-timeout ;
|
||||||
|
|
@ -45,7 +54,7 @@ TUPLE: mailbox threads data ;
|
||||||
: mailbox-get-all-timeout ( mailbox timeout -- array )
|
: mailbox-get-all-timeout ( mailbox timeout -- array )
|
||||||
block-if-empty
|
block-if-empty
|
||||||
[ dup mailbox-empty? ]
|
[ dup mailbox-empty? ]
|
||||||
[ dup mailbox-data pop-back ]
|
[ dup data>> pop-back ]
|
||||||
[ ] unfold nip ;
|
[ ] unfold nip ;
|
||||||
|
|
||||||
: mailbox-get-all ( mailbox -- array )
|
: mailbox-get-all ( mailbox -- array )
|
||||||
|
|
@ -60,11 +69,18 @@ TUPLE: mailbox threads data ;
|
||||||
|
|
||||||
: mailbox-get-timeout? ( mailbox timeout pred -- obj )
|
: mailbox-get-timeout? ( mailbox timeout pred -- obj )
|
||||||
3dup block-unless-pred
|
3dup block-unless-pred
|
||||||
nip >r mailbox-data r> delete-node-if ; inline
|
nip >r data>> r> delete-node-if ; inline
|
||||||
|
|
||||||
: mailbox-get? ( mailbox pred -- obj )
|
: mailbox-get? ( mailbox pred -- obj )
|
||||||
f swap mailbox-get-timeout? ; inline
|
f swap mailbox-get-timeout? ; inline
|
||||||
|
|
||||||
|
: wait-for-close-timeout ( mailbox timeout -- )
|
||||||
|
over closed>>
|
||||||
|
[ 2drop ] [ 2dup wait-for-mailbox wait-for-close-timeout ] if ;
|
||||||
|
|
||||||
|
: wait-for-close ( mailbox -- )
|
||||||
|
f wait-for-close-timeout ;
|
||||||
|
|
||||||
TUPLE: linked-error thread ;
|
TUPLE: linked-error thread ;
|
||||||
|
|
||||||
: <linked-error> ( error thread -- linked )
|
: <linked-error> ( error thread -- linked )
|
||||||
|
|
|
||||||
|
|
@ -32,7 +32,7 @@ HELP: spawn-linked
|
||||||
{ $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threades that restart child threades that crash due to uncaught errors.\n" }
|
{ $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threades that restart child threades that crash due to uncaught errors.\n" }
|
||||||
{ $see-also spawn } ;
|
{ $see-also spawn } ;
|
||||||
|
|
||||||
ARTICLE: { "concurrency" "messaging" } "Mailboxes"
|
ARTICLE: { "concurrency" "messaging" } "Sending and receiving messages"
|
||||||
"Each thread has an associated mailbox. Other threads can place items on this queue by sending the thread a message. A thread can check its mailbox for messages, blocking if none are pending, and thread them as they are queued."
|
"Each thread has an associated mailbox. Other threads can place items on this queue by sending the thread a message. A thread can check its mailbox for messages, blocking if none are pending, and thread them as they are queued."
|
||||||
$nl
|
$nl
|
||||||
"The messages that are sent from thread to thread are any Factor value. Factor tuples are ideal for this sort of thing as you can send a tuple to a thread and the generic word dispatch mechanism can be used to perform actions depending on what the type of the tuple is."
|
"The messages that are sent from thread to thread are any Factor value. Factor tuples are ideal for this sort of thing as you can send a tuple to a thread and the generic word dispatch mechanism can be used to perform actions depending on what the type of the tuple is."
|
||||||
|
|
@ -43,7 +43,8 @@ $nl
|
||||||
{ $subsection receive }
|
{ $subsection receive }
|
||||||
{ $subsection receive-timeout }
|
{ $subsection receive-timeout }
|
||||||
{ $subsection receive-if }
|
{ $subsection receive-if }
|
||||||
{ $subsection receive-if-timeout } ;
|
{ $subsection receive-if-timeout }
|
||||||
|
{ $see-also "concurrency.mailboxes" } ;
|
||||||
|
|
||||||
ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends"
|
ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends"
|
||||||
"The " { $link send } " word sends a message asynchronously, and the sending thread continues immediately. It is also possible to send a message to a thread and block until a response is received:"
|
"The " { $link send } " word sends a message asynchronously, and the sending thread continues immediately. It is also possible to send a message to a thread and block until a response is received:"
|
||||||
|
|
|
||||||
|
|
@ -3,7 +3,8 @@
|
||||||
!
|
!
|
||||||
USING: kernel threads vectors arrays sequences
|
USING: kernel threads vectors arrays sequences
|
||||||
namespaces tools.test continuations dlists strings math words
|
namespaces tools.test continuations dlists strings math words
|
||||||
match quotations concurrency.messaging concurrency.mailboxes ;
|
match quotations concurrency.messaging concurrency.mailboxes
|
||||||
|
concurrency.count-downs ;
|
||||||
IN: concurrency.messaging.tests
|
IN: concurrency.messaging.tests
|
||||||
|
|
||||||
[ ] [ my-mailbox mailbox-data dlist-delete-all ] unit-test
|
[ ] [ my-mailbox mailbox-data dlist-delete-all ] unit-test
|
||||||
|
|
@ -53,3 +54,14 @@ SYMBOL: exit
|
||||||
receive
|
receive
|
||||||
exit "counter" get send
|
exit "counter" get send
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
! Not yet
|
||||||
|
|
||||||
|
! 1 <count-down> "c" set
|
||||||
|
|
||||||
|
! [
|
||||||
|
! "c" get count-down
|
||||||
|
! receive drop
|
||||||
|
! ] "Bad synchronous send" spawn "t" set
|
||||||
|
|
||||||
|
! [ 3 "t" get send-synchronous ] must-fail
|
||||||
|
|
@ -151,12 +151,10 @@ SYMBOL: event-stream-callbacks
|
||||||
|
|
||||||
[
|
[
|
||||||
event-stream-callbacks global
|
event-stream-callbacks global
|
||||||
[ [ drop expired? not ] assoc-subset ] change-at
|
[ [ drop expired? not ] assoc-subset H{ } assoc-like ] change-at
|
||||||
1 \ event-stream-counter set-global
|
1 \ event-stream-counter set-global
|
||||||
] "core-foundation" add-init-hook
|
] "core-foundation" add-init-hook
|
||||||
|
|
||||||
event-stream-callbacks global [ H{ } assoc-like ] change-at
|
|
||||||
|
|
||||||
: add-event-source-callback ( quot -- id )
|
: add-event-source-callback ( quot -- id )
|
||||||
event-stream-counter <alien>
|
event-stream-counter <alien>
|
||||||
[ event-stream-callbacks get set-at ] keep ;
|
[ event-stream-callbacks get set-at ] keep ;
|
||||||
|
|
|
||||||
|
|
@ -1,5 +0,0 @@
|
||||||
USING: kernel math test namespaces crypto crypto-internals ;
|
|
||||||
|
|
||||||
[ 6 ] [ 5 T{ bbs f 590695557939 811977232793 } random-bbs-bits* ] unit-test
|
|
||||||
[ 792723710536787233474130382522 ] [ 100 T{ bbs f 200352954495 846054538649 } [ random-bbs-bits* drop ] 2keep random-bbs-bits* ] unit-test
|
|
||||||
|
|
||||||
|
|
@ -18,16 +18,16 @@ TUPLE: mysql-result-set ;
|
||||||
: mysql-error ( mysql -- )
|
: mysql-error ( mysql -- )
|
||||||
[ mysql_error throw ] when* ;
|
[ mysql_error throw ] when* ;
|
||||||
|
|
||||||
: mysql-connect ( mysql-connection -- )
|
! : mysql-connect ( mysql-connection -- )
|
||||||
new-mysql over set-mysql-db-handle
|
! new-mysql over set-mysql-db-handle
|
||||||
dup {
|
! dup {
|
||||||
mysql-db-handle
|
! mysql-db-handle
|
||||||
mysql-db-host
|
! mysql-db-host
|
||||||
mysql-db-user
|
! mysql-db-user
|
||||||
mysql-db-password
|
! mysql-db-password
|
||||||
mysql-db-db
|
! mysql-db-db
|
||||||
mysql-db-port
|
! mysql-db-port
|
||||||
} get-slots f 0 mysql_real_connect mysql-error ;
|
! } get-slots f 0 mysql_real_connect mysql-error ;
|
||||||
|
|
||||||
! =========================================================
|
! =========================================================
|
||||||
! Low level mysql utility definitions
|
! Low level mysql utility definitions
|
||||||
|
|
|
||||||
|
|
@ -224,7 +224,7 @@ $nl
|
||||||
":errors - print 2 compiler errors."
|
":errors - print 2 compiler errors."
|
||||||
":warnings - print 50 compiler warnings."
|
":warnings - print 50 compiler warnings."
|
||||||
}
|
}
|
||||||
"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erronous stack effect declarations."
|
"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erroneous stack effect declarations."
|
||||||
{ $references
|
{ $references
|
||||||
"To learn more about the compiler and static stack effect inference, read these articles:"
|
"To learn more about the compiler and static stack effect inference, read these articles:"
|
||||||
"compiler"
|
"compiler"
|
||||||
|
|
@ -259,7 +259,7 @@ $nl
|
||||||
{ $code "#! /usr/bin/env factor -script" }
|
{ $code "#! /usr/bin/env factor -script" }
|
||||||
"Running the text file will run it through Factor, assuming the " { $snippet "factor" } " binary is in your " { $snippet "$PATH" } "."
|
"Running the text file will run it through Factor, assuming the " { $snippet "factor" } " binary is in your " { $snippet "$PATH" } "."
|
||||||
$nl
|
$nl
|
||||||
"The space between " { $snippet "#!" } " and " { $snippet "/usr/bin/env" } " is necessary, since " { $link POSTPONE: #! } " is a parsing word, and a syntax error would otherwise result. The " { $snippet "-script" } " switch supresses compiler messages, and exits Factor when the script finishes."
|
"The space between " { $snippet "#!" } " and " { $snippet "/usr/bin/env" } " is necessary, since " { $link POSTPONE: #! } " is a parsing word, and a syntax error would otherwise result. The " { $snippet "-script" } " switch suppresses compiler messages, and exits Factor when the script finishes."
|
||||||
{ $references
|
{ $references
|
||||||
{ }
|
{ }
|
||||||
"cli"
|
"cli"
|
||||||
|
|
@ -273,7 +273,7 @@ $nl
|
||||||
$nl
|
$nl
|
||||||
"Keep the following guidelines in mind to avoid losing your sense of balance:"
|
"Keep the following guidelines in mind to avoid losing your sense of balance:"
|
||||||
{ $list
|
{ $list
|
||||||
"SImplify, simplify, simplify. Break your program up into small words which operate on a few values at a time. Most word definitions should fit on a single line; very rarely should they exceed two or three lines."
|
"Simplify, simplify, simplify. Break your program up into small words which operate on a few values at a time. Most word definitions should fit on a single line; very rarely should they exceed two or three lines."
|
||||||
"In addition to keeping your words short, keep them meaningful. Give them good names, and make sure each word only does one thing. Try documenting your words; if the documentation for a word is unclear or complex, chances are the word definition is too. Don't be afraid to refactor your code."
|
"In addition to keeping your words short, keep them meaningful. Give them good names, and make sure each word only does one thing. Try documenting your words; if the documentation for a word is unclear or complex, chances are the word definition is too. Don't be afraid to refactor your code."
|
||||||
"If your code looks repetitive, factor it some more."
|
"If your code looks repetitive, factor it some more."
|
||||||
"If after factoring, your code still looks repetitive, introduce combinators."
|
"If after factoring, your code still looks repetitive, introduce combinators."
|
||||||
|
|
@ -285,7 +285,7 @@ $nl
|
||||||
"Every time you define a word which simply manipulates sequences, hashtables or objects in an abstract way which is not related to your program domain, check the library to see if you can reuse an existing definition."
|
"Every time you define a word which simply manipulates sequences, hashtables or objects in an abstract way which is not related to your program domain, check the library to see if you can reuse an existing definition."
|
||||||
{ "Learn to use the " { $link "inference" } " tool." }
|
{ "Learn to use the " { $link "inference" } " tool." }
|
||||||
{ "Write unit tests. Factor provides good support for unit testing; see " { $link "tools.test" } ". Once your program has a good test suite you can refactor with confidence and catch regressions early." }
|
{ "Write unit tests. Factor provides good support for unit testing; see " { $link "tools.test" } ". Once your program has a good test suite you can refactor with confidence and catch regressions early." }
|
||||||
"Don't write Factor as if it were C. Imperitive programming and indexed loops are almost always not the most idiomatic solution."
|
"Don't write Factor as if it were C. Imperative programming and indexed loops are almost always not the most idiomatic solution."
|
||||||
{ "Use sequences, assocs and objects to group related data. Object allocation is very cheap. Don't be afraid to create tuples, pairs and triples. Don't be afraid of operations which allocate new objects either, such as " { $link append } "." }
|
{ "Use sequences, assocs and objects to group related data. Object allocation is very cheap. Don't be afraid to create tuples, pairs and triples. Don't be afraid of operations which allocate new objects either, such as " { $link append } "." }
|
||||||
{ "If you find yourself writing a loop with a sequence and an index, there's almost always a better way. Learn the " { $link "sequences-combinators" } " by heart." }
|
{ "If you find yourself writing a loop with a sequence and an index, there's almost always a better way. Learn the " { $link "sequences-combinators" } " by heart." }
|
||||||
{ "If you find yourself writing a heavily nested loop which performs several steps on each iteration, there is almost always a better way. Break the problem down into a series of passes over the data instead, gradually transforming it into the desired result with a series of simple loops. Factor the loops out and reuse them. If you're working on anything math-related, learn " { $link "math-vectors" } " by heart." }
|
{ "If you find yourself writing a heavily nested loop which performs several steps on each iteration, there is almost always a better way. Break the problem down into a series of passes over the data instead, gradually transforming it into the desired result with a series of simple loops. Factor the loops out and reuse them. If you're working on anything math-related, learn " { $link "math-vectors" } " by heart." }
|
||||||
|
|
@ -312,7 +312,7 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid"
|
||||||
$nl
|
$nl
|
||||||
"Unit tests for the " { $vocab-link "inference" } " vocabulary can be used to ensure that any methods your vocabulary defines on core generic words have static stack effects:"
|
"Unit tests for the " { $vocab-link "inference" } " vocabulary can be used to ensure that any methods your vocabulary defines on core generic words have static stack effects:"
|
||||||
{ $code "\"inference\" test" }
|
{ $code "\"inference\" test" }
|
||||||
"In general, you should strive to write code with inferrable stack effects, even for sections of a program which are not performance sensitive; the " { $link infer. } " tool together with the optimizing compiler's error reporting can catch many bugs ahead of time." }
|
"In general, you should strive to write code with inferable stack effects, even for sections of a program which are not performance sensitive; the " { $link infer. } " tool together with the optimizing compiler's error reporting can catch many bugs ahead of time." }
|
||||||
{ "Be careful when calling words which access variables from a " { $link make-assoc } " which constructs an assoc with arbitrary keys, since those keys might shadow variables." }
|
{ "Be careful when calling words which access variables from a " { $link make-assoc } " which constructs an assoc with arbitrary keys, since those keys might shadow variables." }
|
||||||
{ "If " { $link run-file } " throws a stack depth assertion, it means that the top-level form in the file left behind values on the stack. The stack depth is compared before and after loading a source file, since this type of situation is almost always an error. If you have a legitimate need to load a source file which returns data in some manner, define a word in the source file which produces this data on the stack and call the word after loading the file." }
|
{ "If " { $link run-file } " throws a stack depth assertion, it means that the top-level form in the file left behind values on the stack. The stack depth is compared before and after loading a source file, since this type of situation is almost always an error. If you have a legitimate need to load a source file which returns data in some manner, define a word in the source file which produces this data on the stack and call the word after loading the file." }
|
||||||
} ;
|
} ;
|
||||||
|
|
|
||||||
|
|
@ -1,58 +1,108 @@
|
||||||
IN: io.monitors
|
IN: io.monitors
|
||||||
USING: help.markup help.syntax continuations ;
|
USING: help.markup help.syntax continuations
|
||||||
|
concurrency.mailboxes quotations ;
|
||||||
|
|
||||||
|
HELP: with-monitors
|
||||||
|
{ $values { "quot" quotation } }
|
||||||
|
{ $description "Calls a quotation in a new dynamic scope where file system monitor operations can be performed." }
|
||||||
|
{ $errors "Throws an error if the platform does not support file system change monitors." } ;
|
||||||
|
|
||||||
HELP: <monitor>
|
HELP: <monitor>
|
||||||
{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "monitor" "a new monitor" } }
|
{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "monitor" "a new monitor" } }
|
||||||
{ $description "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported."
|
{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported." }
|
||||||
$nl
|
{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;
|
||||||
"Not all operating systems support recursive monitors; if recursive monitoring is not available, an error is thrown and the caller must implement alternative logic for monitoring subdirectories." } ;
|
|
||||||
|
HELP: (monitor)
|
||||||
|
{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "mailbox" mailbox } { "monitor" "a new monitor" } }
|
||||||
|
{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } " and posts notifications to " { $snippet "mailbox" } " as triples with shape " { $snippet "{ path changed monitor } " } ". The boolean indicates whether changes in subdirectories should be reported." }
|
||||||
|
{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;
|
||||||
|
|
||||||
HELP: next-change
|
HELP: next-change
|
||||||
{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changed" "a change descriptor" } }
|
{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changed" "a change descriptor" } }
|
||||||
{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } ;
|
{ $contract "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." }
|
||||||
|
{ $errors "Throws an error if the monitor is closed from another thread." } ;
|
||||||
|
|
||||||
HELP: with-monitor
|
HELP: with-monitor
|
||||||
{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } }
|
{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } }
|
||||||
{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." } ;
|
{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." }
|
||||||
|
{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;
|
||||||
|
|
||||||
HELP: +add-file+
|
HELP: +add-file+
|
||||||
{ $description "Indicates that the file has been added to the directory." } ;
|
{ $description "Indicates that a file has been added to its parent directory." } ;
|
||||||
|
|
||||||
HELP: +remove-file+
|
HELP: +remove-file+
|
||||||
{ $description "Indicates that the file has been removed from the directory." } ;
|
{ $description "Indicates that a file has been removed from its parent directory." } ;
|
||||||
|
|
||||||
HELP: +modify-file+
|
HELP: +modify-file+
|
||||||
{ $description "Indicates that the file contents have changed." } ;
|
{ $description "Indicates that a file's contents have changed." } ;
|
||||||
|
|
||||||
|
HELP: +rename-file-old+
|
||||||
|
{ $description "Indicates that a file has been renamed, and this is the old name." } ;
|
||||||
|
|
||||||
|
HELP: +rename-file-new+
|
||||||
|
{ $description "Indicates that a file has been renamed, and this is the new name." } ;
|
||||||
|
|
||||||
HELP: +rename-file+
|
HELP: +rename-file+
|
||||||
{ $description "Indicates that file has been renamed." } ;
|
{ $description "Indicates that a file has been renamed." } ;
|
||||||
|
|
||||||
ARTICLE: "io.monitors.descriptors" "File system change descriptors"
|
ARTICLE: "io.monitors.descriptors" "File system change descriptors"
|
||||||
"Change descriptors output by " { $link next-change } ":"
|
"Change descriptors output by " { $link next-change } ":"
|
||||||
{ $subsection +add-file+ }
|
{ $subsection +add-file+ }
|
||||||
{ $subsection +remove-file+ }
|
{ $subsection +remove-file+ }
|
||||||
{ $subsection +modify-file+ }
|
{ $subsection +modify-file+ }
|
||||||
{ $subsection +rename-file+ }
|
{ $subsection +rename-file-old+ }
|
||||||
{ $subsection +add-file+ } ;
|
{ $subsection +rename-file-new+ }
|
||||||
|
{ $subsection +rename-file+ } ;
|
||||||
|
|
||||||
|
ARTICLE: "io.monitors.platforms" "Monitors on different platforms"
|
||||||
|
"Whether the " { $snippet "path" } " output value of " { $link next-change } " contains an absolute path or a path relative to the path given to " { $link <monitor> } " is platform-specific. User code should not assume either case."
|
||||||
|
{ $heading "Mac OS X" }
|
||||||
|
"Factor uses " { $snippet "FSEventStream" } "s to implement monitors on Mac OS X. This requires Mac OS X 10.5 or later."
|
||||||
|
$nl
|
||||||
|
{ $snippet "FSEventStream" } "s always monitor directory hierarchies recursively, and the " { $snippet "recursive?" } " parameter to " { $link <monitor> } " has no effect."
|
||||||
|
$nl
|
||||||
|
"The " { $snippet "changed" } " output value of the " { $link next-change } " word always outputs " { $link +modify-file+ } " and the " { $snippet "path" } " output value is always the directory containing the file that changed. Unlike other platforms, fine-grained information is not available."
|
||||||
|
{ $heading "Windows" }
|
||||||
|
"Factor uses " { $snippet "ReadDirectoryChanges" } " to implement monitors on Windows."
|
||||||
|
$nl
|
||||||
|
"Both recursive and non-recursive monitors are directly supported by the operating system."
|
||||||
|
{ $heading "Linux" }
|
||||||
|
"Factor uses " { $snippet "inotify" } " to implement monitors on Linux. This requires Linux kernel version 2.6.16 or later."
|
||||||
|
$nl
|
||||||
|
"Factor simulates recursive monitors by creating a hierarchy of monitors for every subdirectory, since " { $snippet "inotify" } " can only monitor a single directory. This is transparent to user code."
|
||||||
|
$nl
|
||||||
|
"Inside a single " { $link with-monitors } " scope, only one monitor may be created for any given directory."
|
||||||
|
{ $heading "BSD" }
|
||||||
|
"Factor uses " { $snippet "kqueue" } " to implement monitors on BSD."
|
||||||
|
$nl
|
||||||
|
"The " { $snippet "kqueue" } " system is limited to monitoring individual files and directories. Monitoring a directory only notifies of files being added and removed to the directory itself, not of changes to file contents."
|
||||||
|
{ $heading "Windows CE" }
|
||||||
|
"Windows CE does not support monitors." ;
|
||||||
|
|
||||||
ARTICLE: "io.monitors" "File system change monitors"
|
ARTICLE: "io.monitors" "File system change monitors"
|
||||||
"File system change monitors listen for changes to file names, attributes and contents under a specified directory. They can optionally be recursive, in which case subdirectories are also monitored."
|
"File system change monitors listen for changes to file names, attributes and contents under a specified directory. They can optionally be recursive, in which case subdirectories are also monitored."
|
||||||
$nl
|
$nl
|
||||||
|
"Monitoring operations must be wrapped in a combinator:"
|
||||||
|
{ $subsection with-monitors }
|
||||||
"Creating a file system change monitor and listening for changes:"
|
"Creating a file system change monitor and listening for changes:"
|
||||||
{ $subsection <monitor> }
|
{ $subsection <monitor> }
|
||||||
{ $subsection next-change }
|
{ $subsection next-change }
|
||||||
|
"An alternative programming style is where instead of having a thread listen for changes on a monitor, change notifications are posted to a mailbox:"
|
||||||
|
{ $subsection (monitor) }
|
||||||
{ $subsection "io.monitors.descriptors" }
|
{ $subsection "io.monitors.descriptors" }
|
||||||
"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } "."
|
{ $subsection "io.monitors.platforms" }
|
||||||
$nl
|
"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } ". An easy way to pair construction with disposal is to use a combinator:"
|
||||||
"A utility combinator which opens a monitor and cleans it up after:"
|
|
||||||
{ $subsection with-monitor }
|
{ $subsection with-monitor }
|
||||||
"An example which watches the Factor directory for changes:"
|
"Monitors support the " { $link "io.timeouts" } "."
|
||||||
|
$nl
|
||||||
|
"An example which watches a directory for changes:"
|
||||||
{ $code
|
{ $code
|
||||||
"USE: io.monitors"
|
"USE: io.monitors"
|
||||||
": watch-loop ( monitor -- )"
|
": watch-loop ( monitor -- )"
|
||||||
" dup next-change . . nl nl flush watch-loop ;"
|
" dup next-change . . nl nl flush watch-loop ;"
|
||||||
""
|
""
|
||||||
"\"\" resource-path f [ watch-loop ] with-monitor"
|
": watch-directory ( path -- )"
|
||||||
|
" [ t [ watch-loop ] with-monitor ] with-monitors"
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
ABOUT: "io.monitors"
|
ABOUT: "io.monitors"
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,91 @@
|
||||||
|
IN: io.monitors.tests
|
||||||
|
USING: io.monitors tools.test io.files system sequences
|
||||||
|
continuations namespaces concurrency.count-downs kernel io
|
||||||
|
threads calendar prettyprint ;
|
||||||
|
|
||||||
|
os { winnt linux macosx } member? [
|
||||||
|
[
|
||||||
|
[ "monitor-test" temp-file delete-tree ] ignore-errors
|
||||||
|
|
||||||
|
[ ] [ "monitor-test" temp-file make-directory ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "monitor-test" temp-file t <monitor> "m" set ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "monitor-test/a1" temp-file make-directory ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "monitor-test/a2" temp-file make-directory ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "monitor-test/a1" temp-file "monitor-test/a2" temp-file move-file-into ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ "monitor-test/a2/a1" temp-file exists? ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "monitor-test/a2/a1/a3.txt" temp-file touch-file ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ "monitor-test/a2/a1/a3.txt" temp-file exists? ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "monitor-test/a2/a1/a4.txt" temp-file touch-file ] unit-test
|
||||||
|
[ ] [ "monitor-test/a2/a1/a5.txt" temp-file touch-file ] unit-test
|
||||||
|
[ ] [ "monitor-test/a2/a1/a4.txt" temp-file delete-file ] unit-test
|
||||||
|
[ ] [ "monitor-test/a2/a1/a5.txt" temp-file "monitor-test/a2/a1/a4.txt" temp-file move-file ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ "monitor-test/a2/a1/a4.txt" temp-file exists? ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "m" get dispose ] unit-test
|
||||||
|
] with-monitors
|
||||||
|
|
||||||
|
|
||||||
|
[
|
||||||
|
[ "monitor-test" temp-file delete-tree ] ignore-errors
|
||||||
|
|
||||||
|
[ ] [ "monitor-test/xyz" temp-file make-directories ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "monitor-test" temp-file t <monitor> "m" set ] unit-test
|
||||||
|
|
||||||
|
[ ] [ 1 <count-down> "b" set ] unit-test
|
||||||
|
|
||||||
|
[ ] [ 1 <count-down> "c1" set ] unit-test
|
||||||
|
|
||||||
|
[ ] [ 1 <count-down> "c2" set ] unit-test
|
||||||
|
|
||||||
|
[ ] [
|
||||||
|
[
|
||||||
|
"b" get count-down
|
||||||
|
|
||||||
|
[
|
||||||
|
"m" get next-change drop
|
||||||
|
dup print flush
|
||||||
|
dup parent-directory
|
||||||
|
[ right-trim-separators "xyz" tail? ] either? not
|
||||||
|
] [ ] [ ] while
|
||||||
|
|
||||||
|
"c1" get count-down
|
||||||
|
|
||||||
|
[
|
||||||
|
"m" get next-change drop
|
||||||
|
dup print flush
|
||||||
|
dup parent-directory
|
||||||
|
[ right-trim-separators "yxy" tail? ] either? not
|
||||||
|
] [ ] [ ] while
|
||||||
|
|
||||||
|
"c2" get count-down
|
||||||
|
] "Monitor test thread" spawn drop
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ ] [ "b" get await ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "c1" get 5 seconds await-timeout ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "monitor-test/subdir/blah/yxy" temp-file make-directories ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "monitor-test/subdir/blah/yxy/test.txt" temp-file touch-file ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "c2" get 5 seconds await-timeout ] unit-test
|
||||||
|
|
||||||
|
! Dispose twice
|
||||||
|
[ ] [ "m" get dispose ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "m" get dispose ] unit-test
|
||||||
|
] with-monitors
|
||||||
|
] when
|
||||||
|
|
@ -1,82 +1,50 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: io.backend kernel continuations namespaces sequences
|
USING: io.backend kernel continuations namespaces sequences
|
||||||
assocs hashtables sorting arrays threads boxes io.timeouts ;
|
assocs hashtables sorting arrays threads boxes io.timeouts
|
||||||
|
accessors concurrency.mailboxes ;
|
||||||
IN: io.monitors
|
IN: io.monitors
|
||||||
|
|
||||||
<PRIVATE
|
HOOK: init-monitors io-backend ( -- )
|
||||||
|
|
||||||
TUPLE: monitor queue closed? ;
|
HOOK: dispose-monitors io-backend ( -- )
|
||||||
|
|
||||||
: check-monitor ( monitor -- )
|
: with-monitors ( quot -- )
|
||||||
monitor-closed? [ "Monitor closed" throw ] when ;
|
|
||||||
|
|
||||||
: (monitor) ( delegate -- monitor )
|
|
||||||
H{ } clone {
|
|
||||||
set-delegate
|
|
||||||
set-monitor-queue
|
|
||||||
} monitor construct ;
|
|
||||||
|
|
||||||
GENERIC: fill-queue ( monitor -- )
|
|
||||||
|
|
||||||
: changed-file ( changed path -- )
|
|
||||||
namespace [ append ] change-at ;
|
|
||||||
|
|
||||||
: dequeue-change ( assoc -- path changes )
|
|
||||||
delete-any prune natural-sort >array ;
|
|
||||||
|
|
||||||
M: monitor dispose
|
|
||||||
dup check-monitor
|
|
||||||
t over set-monitor-closed?
|
|
||||||
delegate dispose ;
|
|
||||||
|
|
||||||
! Simple monitor; used on Linux and Mac OS X. On Windows,
|
|
||||||
! monitors are full-fledged ports.
|
|
||||||
TUPLE: simple-monitor handle callback timeout ;
|
|
||||||
|
|
||||||
M: simple-monitor timeout simple-monitor-timeout ;
|
|
||||||
|
|
||||||
M: simple-monitor set-timeout set-simple-monitor-timeout ;
|
|
||||||
|
|
||||||
: <simple-monitor> ( handle -- simple-monitor )
|
|
||||||
f (monitor) <box> {
|
|
||||||
set-simple-monitor-handle
|
|
||||||
set-delegate
|
|
||||||
set-simple-monitor-callback
|
|
||||||
} simple-monitor construct ;
|
|
||||||
|
|
||||||
: construct-simple-monitor ( handle class -- simple-monitor )
|
|
||||||
>r <simple-monitor> r> construct-delegate ; inline
|
|
||||||
|
|
||||||
: notify-callback ( simple-monitor -- )
|
|
||||||
simple-monitor-callback [ resume ] if-box? ;
|
|
||||||
|
|
||||||
M: simple-monitor timed-out
|
|
||||||
notify-callback ;
|
|
||||||
|
|
||||||
M: simple-monitor fill-queue ( monitor -- )
|
|
||||||
[
|
[
|
||||||
[ swap simple-monitor-callback >box ]
|
init-monitors
|
||||||
"monitor" suspend drop
|
[ dispose-monitors ] [ ] cleanup
|
||||||
] with-timeout
|
] with-scope ; inline
|
||||||
check-monitor ;
|
|
||||||
|
|
||||||
M: simple-monitor dispose ( monitor -- )
|
TUPLE: monitor < identity-tuple path queue timeout ;
|
||||||
dup delegate dispose notify-callback ;
|
|
||||||
|
|
||||||
PRIVATE>
|
M: monitor hashcode* path>> hashcode* ;
|
||||||
|
|
||||||
HOOK: <monitor> io-backend ( path recursive? -- monitor )
|
M: monitor timeout timeout>> ;
|
||||||
|
|
||||||
|
M: monitor set-timeout (>>timeout) ;
|
||||||
|
|
||||||
|
: construct-monitor ( path mailbox class -- monitor )
|
||||||
|
construct-empty
|
||||||
|
swap >>queue
|
||||||
|
swap >>path ; inline
|
||||||
|
|
||||||
|
: queue-change ( path changes monitor -- )
|
||||||
|
3dup and and
|
||||||
|
[ [ 3array ] keep queue>> mailbox-put ] [ 3drop ] if ;
|
||||||
|
|
||||||
|
HOOK: (monitor) io-backend ( path recursive? mailbox -- monitor )
|
||||||
|
|
||||||
|
: <monitor> ( path recursive? -- monitor )
|
||||||
|
<mailbox> (monitor) ;
|
||||||
|
|
||||||
: next-change ( monitor -- path changed )
|
: next-change ( monitor -- path changed )
|
||||||
dup check-monitor
|
[ queue>> ] [ timeout ] bi mailbox-get-timeout first2 ;
|
||||||
dup monitor-queue dup assoc-empty? [
|
|
||||||
drop dup fill-queue next-change
|
|
||||||
] [ nip dequeue-change ] if ;
|
|
||||||
|
|
||||||
SYMBOL: +add-file+
|
SYMBOL: +add-file+
|
||||||
SYMBOL: +remove-file+
|
SYMBOL: +remove-file+
|
||||||
SYMBOL: +modify-file+
|
SYMBOL: +modify-file+
|
||||||
|
SYMBOL: +rename-file-old+
|
||||||
|
SYMBOL: +rename-file-new+
|
||||||
SYMBOL: +rename-file+
|
SYMBOL: +rename-file+
|
||||||
|
|
||||||
: with-monitor ( path recursive? quot -- )
|
: with-monitor ( path recursive? quot -- )
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,59 @@
|
||||||
|
USING: accessors math kernel namespaces continuations
|
||||||
|
io.files io.monitors io.monitors.recursive io.backend
|
||||||
|
concurrency.mailboxes
|
||||||
|
tools.test ;
|
||||||
|
IN: io.monitors.recursive.tests
|
||||||
|
|
||||||
|
\ pump-thread must-infer
|
||||||
|
|
||||||
|
SINGLETON: mock-io-backend
|
||||||
|
|
||||||
|
TUPLE: counter i ;
|
||||||
|
|
||||||
|
SYMBOL: dummy-monitor-created
|
||||||
|
SYMBOL: dummy-monitor-disposed
|
||||||
|
|
||||||
|
TUPLE: dummy-monitor < monitor ;
|
||||||
|
|
||||||
|
M: dummy-monitor dispose
|
||||||
|
drop dummy-monitor-disposed get [ 1+ ] change-i drop ;
|
||||||
|
|
||||||
|
M: mock-io-backend (monitor)
|
||||||
|
nip
|
||||||
|
over exists? [
|
||||||
|
dummy-monitor construct-monitor
|
||||||
|
dummy-monitor-created get [ 1+ ] change-i drop
|
||||||
|
] [
|
||||||
|
"Does not exist" throw
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
M: mock-io-backend link-info
|
||||||
|
global [ link-info ] bind ;
|
||||||
|
|
||||||
|
[ ] [ 0 counter construct-boa dummy-monitor-created set ] unit-test
|
||||||
|
[ ] [ 0 counter construct-boa dummy-monitor-disposed set ] unit-test
|
||||||
|
|
||||||
|
[ ] [
|
||||||
|
mock-io-backend io-backend [
|
||||||
|
"" resource-path <mailbox> <recursive-monitor> dispose
|
||||||
|
] with-variable
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ t ] [ dummy-monitor-created get i>> 0 > ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ dummy-monitor-created get i>> dummy-monitor-disposed get i>> = ] unit-test
|
||||||
|
|
||||||
|
[ "doesnotexist" temp-file delete-tree ] ignore-errors
|
||||||
|
|
||||||
|
[
|
||||||
|
mock-io-backend io-backend [
|
||||||
|
"doesnotexist" temp-file <mailbox> <recursive-monitor> dispose
|
||||||
|
] with-variable
|
||||||
|
] must-fail
|
||||||
|
|
||||||
|
[ ] [
|
||||||
|
mock-io-backend io-backend [
|
||||||
|
"" resource-path <mailbox> <recursive-monitor>
|
||||||
|
[ dispose ] [ dispose ] bi
|
||||||
|
] with-variable
|
||||||
|
] unit-test
|
||||||
|
|
@ -0,0 +1,105 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors sequences assocs arrays continuations combinators kernel
|
||||||
|
threads concurrency.messaging concurrency.mailboxes
|
||||||
|
concurrency.promises
|
||||||
|
io.files io.monitors ;
|
||||||
|
IN: io.monitors.recursive
|
||||||
|
|
||||||
|
! Simulate recursive monitors on platforms that don't have them
|
||||||
|
|
||||||
|
TUPLE: recursive-monitor < monitor children thread ready ;
|
||||||
|
|
||||||
|
DEFER: add-child-monitor
|
||||||
|
|
||||||
|
: qualify-path ( path -- path' )
|
||||||
|
monitor tget path>> prepend-path ;
|
||||||
|
|
||||||
|
: add-child-monitors ( path -- )
|
||||||
|
#! We yield since this directory scan might take a while.
|
||||||
|
[
|
||||||
|
directory* [ first add-child-monitor yield ] each
|
||||||
|
] curry ignore-errors ;
|
||||||
|
|
||||||
|
: add-child-monitor ( path -- )
|
||||||
|
qualify-path dup link-info type>> +directory+ eq? [
|
||||||
|
[ add-child-monitors ]
|
||||||
|
[
|
||||||
|
[ f my-mailbox (monitor) ] keep
|
||||||
|
monitor tget children>> set-at
|
||||||
|
] bi
|
||||||
|
] [ drop ] if ;
|
||||||
|
|
||||||
|
USE: io
|
||||||
|
USE: prettyprint
|
||||||
|
|
||||||
|
: remove-child-monitor ( monitor -- )
|
||||||
|
monitor tget children>> delete-at*
|
||||||
|
[ dispose ] [ drop ] if ;
|
||||||
|
|
||||||
|
M: recursive-monitor dispose
|
||||||
|
dup queue>> closed>> [
|
||||||
|
drop
|
||||||
|
] [
|
||||||
|
[ "stop" swap thread>> send-synchronous drop ]
|
||||||
|
[ queue>> dispose ] bi
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: stop-pump ( -- )
|
||||||
|
monitor tget children>> [ nip dispose ] assoc-each ;
|
||||||
|
|
||||||
|
: pump-step ( msg -- )
|
||||||
|
first3 path>> swap >r prepend-path r> monitor tget 3array
|
||||||
|
monitor tget queue>>
|
||||||
|
mailbox-put ;
|
||||||
|
|
||||||
|
: child-added ( path monitor -- )
|
||||||
|
path>> prepend-path add-child-monitor ;
|
||||||
|
|
||||||
|
: child-removed ( path monitor -- )
|
||||||
|
path>> prepend-path remove-child-monitor ;
|
||||||
|
|
||||||
|
: update-hierarchy ( msg -- )
|
||||||
|
first3 swap [
|
||||||
|
{
|
||||||
|
{ +add-file+ [ child-added ] }
|
||||||
|
{ +remove-file+ [ child-removed ] }
|
||||||
|
{ +rename-file-old+ [ child-removed ] }
|
||||||
|
{ +rename-file-new+ [ child-added ] }
|
||||||
|
[ 3drop ]
|
||||||
|
} case
|
||||||
|
] with with each ;
|
||||||
|
|
||||||
|
: pump-loop ( -- )
|
||||||
|
receive dup synchronous? [
|
||||||
|
>r stop-pump t r> reply-synchronous
|
||||||
|
] [
|
||||||
|
[ [ update-hierarchy ] curry ignore-errors ] [ pump-step ] bi
|
||||||
|
pump-loop
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: monitor-ready ( error/t -- )
|
||||||
|
monitor tget ready>> fulfill ;
|
||||||
|
|
||||||
|
: pump-thread ( monitor -- )
|
||||||
|
monitor tset
|
||||||
|
[ "" add-child-monitor t monitor-ready ]
|
||||||
|
[ [ self <linked-error> monitor-ready ] keep rethrow ]
|
||||||
|
recover
|
||||||
|
pump-loop ;
|
||||||
|
|
||||||
|
: start-pump-thread ( monitor -- )
|
||||||
|
dup [ pump-thread ] curry
|
||||||
|
"Recursive monitor pump" spawn
|
||||||
|
>>thread drop ;
|
||||||
|
|
||||||
|
: wait-for-ready ( monitor -- )
|
||||||
|
ready>> ?promise ?linked drop ;
|
||||||
|
|
||||||
|
: <recursive-monitor> ( path mailbox -- monitor )
|
||||||
|
>r (normalize-path) r>
|
||||||
|
recursive-monitor construct-monitor
|
||||||
|
H{ } clone >>children
|
||||||
|
<promise> >>ready
|
||||||
|
dup start-pump-thread
|
||||||
|
dup wait-for-ready ;
|
||||||
|
|
@ -18,13 +18,13 @@ HELP: with-timeout
|
||||||
{ $description "Applies the quotation to the object. If the object's timeout expires before the quotation returns, " { $link timed-out } " is called on the object." } ;
|
{ $description "Applies the quotation to the object. If the object's timeout expires before the quotation returns, " { $link timed-out } " is called on the object." } ;
|
||||||
|
|
||||||
ARTICLE: "io.timeouts" "I/O timeout protocol"
|
ARTICLE: "io.timeouts" "I/O timeout protocol"
|
||||||
"Streams and processes support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed."
|
"Streams, processes and monitors support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed."
|
||||||
{ $subsection timeout }
|
{ $subsection timeout }
|
||||||
{ $subsection set-timeout }
|
{ $subsection set-timeout }
|
||||||
"The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations."
|
"The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations."
|
||||||
{ $subsection timed-out }
|
{ $subsection timed-out }
|
||||||
"A combinator to be used in operations which can time out:"
|
"A combinator to be used in operations which can time out:"
|
||||||
{ $subsection with-timeout }
|
{ $subsection with-timeout }
|
||||||
{ $see-also "stream-protocol" "io.launcher" } ;
|
{ $see-also "stream-protocol" "io.launcher" "io.monitors" } ;
|
||||||
|
|
||||||
ABOUT: "io.timeouts"
|
ABOUT: "io.timeouts"
|
||||||
|
|
|
||||||
|
|
@ -203,3 +203,6 @@ M: mx-task do-io-task
|
||||||
|
|
||||||
: multiplexer-error ( n -- )
|
: multiplexer-error ( n -- )
|
||||||
0 < [ err_no ignorable-error? [ (io-error) ] unless ] when ;
|
0 < [ err_no ignorable-error? [ (io-error) ] unless ] when ;
|
||||||
|
|
||||||
|
: ?flag ( n mask symbol -- n )
|
||||||
|
pick rot bitand 0 > [ , ] [ drop ] if ;
|
||||||
|
|
|
||||||
|
|
@ -1,8 +1,22 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
IN: io.unix.bsd
|
IN: io.unix.bsd
|
||||||
USING: io.backend io.unix.backend io.unix.select
|
USING: namespaces system kernel accessors assocs continuations
|
||||||
namespaces system ;
|
unix
|
||||||
|
io.backend io.unix.backend io.unix.select io.unix.kqueue io.monitors ;
|
||||||
|
|
||||||
M: bsd init-io ( -- )
|
M: bsd init-io ( -- )
|
||||||
<select-mx> mx set-global ;
|
<select-mx> mx set-global
|
||||||
|
<kqueue-mx> kqueue-mx set-global
|
||||||
|
kqueue-mx get-global <mx-port> <mx-task>
|
||||||
|
dup io-task-fd
|
||||||
|
[ mx get-global reads>> set-at ]
|
||||||
|
[ mx get-global writes>> set-at ] 2bi ;
|
||||||
|
|
||||||
|
M: bsd init-monitors ;
|
||||||
|
|
||||||
|
M: bsd dispose-monitors ;
|
||||||
|
|
||||||
|
M: bsd (monitor) ( path recursive? mailbox -- )
|
||||||
|
swap [ "Recursive kqueue monitors not supported" throw ] when
|
||||||
|
<vnode-monitor> ;
|
||||||
|
|
|
||||||
|
|
@ -1,12 +1,14 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien.c-types kernel io.nonblocking io.unix.backend
|
USING: alien.c-types kernel math math.bitfields namespaces
|
||||||
sequences assocs unix unix.time unix.kqueue unix.process math namespaces
|
locals accessors combinators threads vectors hashtables
|
||||||
combinators threads vectors io.launcher
|
sequences assocs continuations
|
||||||
io.unix.launcher ;
|
unix unix.time unix.kqueue unix.process
|
||||||
|
io.nonblocking io.unix.backend io.launcher io.unix.launcher
|
||||||
|
io.monitors ;
|
||||||
IN: io.unix.kqueue
|
IN: io.unix.kqueue
|
||||||
|
|
||||||
TUPLE: kqueue-mx events ;
|
TUPLE: kqueue-mx events monitors ;
|
||||||
|
|
||||||
: max-events ( -- n )
|
: max-events ( -- n )
|
||||||
#! We read up to 256 events at a time. This is an arbitrary
|
#! We read up to 256 events at a time. This is an arbitrary
|
||||||
|
|
@ -15,8 +17,9 @@ TUPLE: kqueue-mx events ;
|
||||||
|
|
||||||
: <kqueue-mx> ( -- mx )
|
: <kqueue-mx> ( -- mx )
|
||||||
kqueue-mx construct-mx
|
kqueue-mx construct-mx
|
||||||
kqueue dup io-error over set-mx-fd
|
H{ } clone >>monitors
|
||||||
max-events "kevent" <c-array> over set-kqueue-mx-events ;
|
kqueue dup io-error >>fd
|
||||||
|
max-events "kevent" <c-array> >>events ;
|
||||||
|
|
||||||
GENERIC: io-task-filter ( task -- n )
|
GENERIC: io-task-filter ( task -- n )
|
||||||
|
|
||||||
|
|
@ -24,14 +27,19 @@ M: input-task io-task-filter drop EVFILT_READ ;
|
||||||
|
|
||||||
M: output-task io-task-filter drop EVFILT_WRITE ;
|
M: output-task io-task-filter drop EVFILT_WRITE ;
|
||||||
|
|
||||||
|
GENERIC: io-task-fflags ( task -- n )
|
||||||
|
|
||||||
|
M: io-task io-task-fflags drop 0 ;
|
||||||
|
|
||||||
: make-kevent ( task flags -- event )
|
: make-kevent ( task flags -- event )
|
||||||
"kevent" <c-object>
|
"kevent" <c-object>
|
||||||
tuck set-kevent-flags
|
tuck set-kevent-flags
|
||||||
over io-task-fd over set-kevent-ident
|
over io-task-fd over set-kevent-ident
|
||||||
|
over io-task-fflags over set-kevent-fflags
|
||||||
swap io-task-filter over set-kevent-filter ;
|
swap io-task-filter over set-kevent-filter ;
|
||||||
|
|
||||||
: register-kevent ( kevent mx -- )
|
: register-kevent ( kevent mx -- )
|
||||||
mx-fd swap 1 f 0 f kevent
|
fd>> swap 1 f 0 f kevent
|
||||||
0 < [ err_no ESRCH = [ (io-error) ] unless ] when ;
|
0 < [ err_no ESRCH = [ (io-error) ] unless ] when ;
|
||||||
|
|
||||||
M: kqueue-mx register-io-task ( task mx -- )
|
M: kqueue-mx register-io-task ( task mx -- )
|
||||||
|
|
@ -43,33 +51,52 @@ M: kqueue-mx unregister-io-task ( task mx -- )
|
||||||
swap EV_DELETE make-kevent swap register-kevent ;
|
swap EV_DELETE make-kevent swap register-kevent ;
|
||||||
|
|
||||||
: wait-kevent ( mx timespec -- n )
|
: wait-kevent ( mx timespec -- n )
|
||||||
>r dup mx-fd f 0 roll kqueue-mx-events max-events r> kevent
|
>r [ fd>> f 0 ] keep events>> max-events r> kevent
|
||||||
dup multiplexer-error ;
|
dup multiplexer-error ;
|
||||||
|
|
||||||
: kevent-read-task ( mx fd -- )
|
:: kevent-read-task ( mx fd kevent -- )
|
||||||
over mx-reads at handle-io-task ;
|
mx fd mx reads>> at handle-io-task ;
|
||||||
|
|
||||||
: kevent-write-task ( mx fd -- )
|
:: kevent-write-task ( mx fd kevent -- )
|
||||||
over mx-reads at handle-io-task ;
|
mx fd mx writes>> at handle-io-task ;
|
||||||
|
|
||||||
: kevent-proc-task ( pid -- )
|
:: kevent-proc-task ( mx pid kevent -- )
|
||||||
dup wait-for-pid swap find-process
|
pid wait-for-pid
|
||||||
|
pid find-process
|
||||||
dup [ swap notify-exit ] [ 2drop ] if ;
|
dup [ swap notify-exit ] [ 2drop ] if ;
|
||||||
|
|
||||||
|
: parse-action ( mask -- changed )
|
||||||
|
[
|
||||||
|
NOTE_DELETE +remove-file+ ?flag
|
||||||
|
NOTE_WRITE +modify-file+ ?flag
|
||||||
|
NOTE_EXTEND +modify-file+ ?flag
|
||||||
|
NOTE_ATTRIB +modify-file+ ?flag
|
||||||
|
NOTE_RENAME +rename-file+ ?flag
|
||||||
|
NOTE_REVOKE +remove-file+ ?flag
|
||||||
|
drop
|
||||||
|
] { } make prune ;
|
||||||
|
|
||||||
|
:: kevent-vnode-task ( mx kevent fd -- )
|
||||||
|
""
|
||||||
|
kevent kevent-fflags parse-action
|
||||||
|
fd mx monitors>> at queue-change ;
|
||||||
|
|
||||||
: handle-kevent ( mx kevent -- )
|
: handle-kevent ( mx kevent -- )
|
||||||
dup kevent-ident swap kevent-filter {
|
[ ] [ kevent-ident ] [ kevent-filter ] tri {
|
||||||
{ [ dup EVFILT_READ = ] [ drop kevent-read-task ] }
|
{ [ dup EVFILT_READ = ] [ drop kevent-read-task ] }
|
||||||
{ [ dup EVFILT_WRITE = ] [ drop kevent-write-task ] }
|
{ [ dup EVFILT_WRITE = ] [ drop kevent-write-task ] }
|
||||||
{ [ dup EVFILT_PROC = ] [ drop kevent-proc-task drop ] }
|
{ [ dup EVFILT_PROC = ] [ drop kevent-proc-task ] }
|
||||||
|
{ [ dup EVFILT_VNODE = ] [ drop kevent-vnode-task ] }
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: handle-kevents ( mx n -- )
|
: handle-kevents ( mx n -- )
|
||||||
[ over kqueue-mx-events kevent-nth handle-kevent ] with each ;
|
[ over events>> kevent-nth handle-kevent ] with each ;
|
||||||
|
|
||||||
M: kqueue-mx wait-for-events ( ms mx -- )
|
M: kqueue-mx wait-for-events ( ms mx -- )
|
||||||
swap dup [ make-timespec ] when
|
swap dup [ make-timespec ] when
|
||||||
dupd wait-kevent handle-kevents ;
|
dupd wait-kevent handle-kevents ;
|
||||||
|
|
||||||
|
! Procs
|
||||||
: make-proc-kevent ( pid -- kevent )
|
: make-proc-kevent ( pid -- kevent )
|
||||||
"kevent" <c-object>
|
"kevent" <c-object>
|
||||||
tuck set-kevent-ident
|
tuck set-kevent-ident
|
||||||
|
|
@ -77,5 +104,44 @@ M: kqueue-mx wait-for-events ( ms mx -- )
|
||||||
EVFILT_PROC over set-kevent-filter
|
EVFILT_PROC over set-kevent-filter
|
||||||
NOTE_EXIT over set-kevent-fflags ;
|
NOTE_EXIT over set-kevent-fflags ;
|
||||||
|
|
||||||
: add-pid-task ( pid mx -- )
|
: register-pid-task ( pid mx -- )
|
||||||
swap make-proc-kevent swap register-kevent ;
|
swap make-proc-kevent swap register-kevent ;
|
||||||
|
|
||||||
|
! VNodes
|
||||||
|
TUPLE: vnode-monitor < monitor fd ;
|
||||||
|
|
||||||
|
: vnode-fflags ( -- n )
|
||||||
|
{
|
||||||
|
NOTE_DELETE
|
||||||
|
NOTE_WRITE
|
||||||
|
NOTE_EXTEND
|
||||||
|
NOTE_ATTRIB
|
||||||
|
NOTE_LINK
|
||||||
|
NOTE_RENAME
|
||||||
|
NOTE_REVOKE
|
||||||
|
} flags ;
|
||||||
|
|
||||||
|
: make-vnode-kevent ( fd flags -- kevent )
|
||||||
|
"kevent" <c-object>
|
||||||
|
tuck set-kevent-flags
|
||||||
|
tuck set-kevent-ident
|
||||||
|
EVFILT_VNODE over set-kevent-filter
|
||||||
|
vnode-fflags over set-kevent-fflags ;
|
||||||
|
|
||||||
|
: register-monitor ( monitor mx -- )
|
||||||
|
>r dup fd>> r>
|
||||||
|
[ >r EV_ADD EV_CLEAR bitor make-vnode-kevent r> register-kevent drop ]
|
||||||
|
[ monitors>> set-at ] 3bi ;
|
||||||
|
|
||||||
|
: unregister-monitor ( monitor mx -- )
|
||||||
|
>r fd>> r>
|
||||||
|
[ monitors>> delete-at ]
|
||||||
|
[ >r EV_DELETE make-vnode-kevent r> register-kevent ] 2bi ;
|
||||||
|
|
||||||
|
: <vnode-monitor> ( path mailbox -- monitor )
|
||||||
|
>r [ O_RDONLY 0 open dup io-error ] keep r>
|
||||||
|
vnode-monitor construct-monitor swap >>fd
|
||||||
|
[ dup kqueue-mx get register-monitor ] [ ] [ fd>> close ] cleanup ;
|
||||||
|
|
||||||
|
M: vnode-monitor dispose
|
||||||
|
[ kqueue-mx get unregister-monitor ] [ fd>> close ] bi ;
|
||||||
|
|
|
||||||
|
|
@ -1,125 +1,10 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel io.backend io.monitors io.monitors.private
|
USING: kernel io.backend io.monitors io.unix.backend
|
||||||
io.files io.buffers io.nonblocking io.timeouts io.unix.backend
|
io.unix.select io.unix.linux.monitors system namespaces ;
|
||||||
io.unix.select io.unix.launcher unix.linux.inotify assocs
|
|
||||||
namespaces threads continuations init math alien.c-types alien
|
|
||||||
vocabs.loader accessors system ;
|
|
||||||
IN: io.unix.linux
|
IN: io.unix.linux
|
||||||
|
|
||||||
TUPLE: linux-monitor ;
|
|
||||||
|
|
||||||
: <linux-monitor> ( wd -- monitor )
|
|
||||||
linux-monitor construct-simple-monitor ;
|
|
||||||
|
|
||||||
TUPLE: inotify watches ;
|
|
||||||
|
|
||||||
: watches ( -- assoc ) inotify get-global watches>> ;
|
|
||||||
|
|
||||||
: wd>monitor ( wd -- monitor ) watches at ;
|
|
||||||
|
|
||||||
: <inotify> ( -- port/f )
|
|
||||||
H{ } clone
|
|
||||||
inotify_init dup 0 < [ 2drop f ] [
|
|
||||||
inotify <buffered-port>
|
|
||||||
{ set-inotify-watches set-delegate } inotify construct
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: inotify-fd inotify get-global handle>> ;
|
|
||||||
|
|
||||||
: (add-watch) ( path mask -- wd )
|
|
||||||
inotify-fd -rot inotify_add_watch dup io-error ;
|
|
||||||
|
|
||||||
: check-existing ( wd -- )
|
|
||||||
watches key? [
|
|
||||||
"Cannot open multiple monitors for the same file" throw
|
|
||||||
] when ;
|
|
||||||
|
|
||||||
: add-watch ( path mask -- monitor )
|
|
||||||
(add-watch) dup check-existing
|
|
||||||
[ <linux-monitor> dup ] keep watches set-at ;
|
|
||||||
|
|
||||||
: remove-watch ( monitor -- )
|
|
||||||
dup simple-monitor-handle watches delete-at
|
|
||||||
simple-monitor-handle inotify-fd swap inotify_rm_watch io-error ;
|
|
||||||
|
|
||||||
: check-inotify
|
|
||||||
inotify get [
|
|
||||||
"inotify is not supported by this Linux release" throw
|
|
||||||
] unless ;
|
|
||||||
|
|
||||||
M: linux <monitor> ( path recursive? -- monitor )
|
|
||||||
check-inotify
|
|
||||||
drop IN_CHANGE_EVENTS add-watch ;
|
|
||||||
|
|
||||||
M: linux-monitor dispose ( monitor -- )
|
|
||||||
dup delegate dispose remove-watch ;
|
|
||||||
|
|
||||||
: ?flag ( n mask symbol -- n )
|
|
||||||
pick rot bitand 0 > [ , ] [ drop ] if ;
|
|
||||||
|
|
||||||
: parse-action ( mask -- changed )
|
|
||||||
[
|
|
||||||
IN_CREATE +add-file+ ?flag
|
|
||||||
IN_DELETE +remove-file+ ?flag
|
|
||||||
IN_DELETE_SELF +remove-file+ ?flag
|
|
||||||
IN_MODIFY +modify-file+ ?flag
|
|
||||||
IN_ATTRIB +modify-file+ ?flag
|
|
||||||
IN_MOVED_FROM +rename-file+ ?flag
|
|
||||||
IN_MOVED_TO +rename-file+ ?flag
|
|
||||||
IN_MOVE_SELF +rename-file+ ?flag
|
|
||||||
drop
|
|
||||||
] { } make ;
|
|
||||||
|
|
||||||
: parse-file-notify ( buffer -- changed path )
|
|
||||||
{ inotify-event-name inotify-event-mask } get-slots
|
|
||||||
parse-action swap alien>char-string ;
|
|
||||||
|
|
||||||
: events-exhausted? ( i buffer -- ? )
|
|
||||||
fill>> >= ;
|
|
||||||
|
|
||||||
: inotify-event@ ( i buffer -- alien )
|
|
||||||
ptr>> <displaced-alien> ;
|
|
||||||
|
|
||||||
: next-event ( i buffer -- i buffer )
|
|
||||||
2dup inotify-event@
|
|
||||||
inotify-event-len "inotify-event" heap-size +
|
|
||||||
swap >r + r> ;
|
|
||||||
|
|
||||||
: parse-file-notifications ( i buffer -- )
|
|
||||||
2dup events-exhausted? [ 2drop ] [
|
|
||||||
2dup inotify-event@ dup inotify-event-wd wd>monitor [
|
|
||||||
monitor-queue [
|
|
||||||
parse-file-notify changed-file
|
|
||||||
] bind
|
|
||||||
] keep notify-callback
|
|
||||||
next-event parse-file-notifications
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: read-notifications ( port -- )
|
|
||||||
dup refill drop
|
|
||||||
0 over parse-file-notifications
|
|
||||||
0 swap buffer-reset ;
|
|
||||||
|
|
||||||
TUPLE: inotify-task ;
|
|
||||||
|
|
||||||
: <inotify-task> ( port -- task )
|
|
||||||
f inotify-task <input-task> ;
|
|
||||||
|
|
||||||
: init-inotify ( mx -- )
|
|
||||||
<inotify> dup [
|
|
||||||
dup inotify set-global
|
|
||||||
<inotify-task> swap register-io-task
|
|
||||||
] [
|
|
||||||
2drop
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
M: inotify-task do-io-task ( task -- )
|
|
||||||
io-task-port read-notifications f ;
|
|
||||||
|
|
||||||
M: linux init-io ( -- )
|
M: linux init-io ( -- )
|
||||||
<select-mx>
|
<select-mx> mx set-global ;
|
||||||
[ mx set-global ]
|
|
||||||
[ init-inotify ] bi ;
|
|
||||||
|
|
||||||
linux set-io-backend
|
linux set-io-backend
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,126 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: kernel io.backend io.monitors io.monitors.recursive
|
||||||
|
io.files io.buffers io.monitors io.nonblocking io.timeouts
|
||||||
|
io.unix.backend io.unix.select unix.linux.inotify assocs
|
||||||
|
namespaces threads continuations init math math.bitfields
|
||||||
|
alien.c-types alien vocabs.loader accessors system ;
|
||||||
|
IN: io.unix.linux.monitors
|
||||||
|
|
||||||
|
TUPLE: linux-monitor < monitor wd ;
|
||||||
|
|
||||||
|
: <linux-monitor> ( wd path mailbox -- monitor )
|
||||||
|
linux-monitor construct-monitor
|
||||||
|
swap >>wd ;
|
||||||
|
|
||||||
|
SYMBOL: watches
|
||||||
|
|
||||||
|
SYMBOL: inotify
|
||||||
|
|
||||||
|
: wd>monitor ( wd -- monitor ) watches get at ;
|
||||||
|
|
||||||
|
: <inotify> ( -- port/f )
|
||||||
|
inotify_init dup 0 < [ drop f ] [ <reader> ] if ;
|
||||||
|
|
||||||
|
: inotify-fd inotify get handle>> ;
|
||||||
|
|
||||||
|
: check-existing ( wd -- )
|
||||||
|
watches get key? [
|
||||||
|
"Cannot open multiple monitors for the same file" throw
|
||||||
|
] when ;
|
||||||
|
|
||||||
|
: (add-watch) ( path mask -- wd )
|
||||||
|
inotify-fd -rot inotify_add_watch dup io-error dup check-existing ;
|
||||||
|
|
||||||
|
: add-watch ( path mask mailbox -- monitor )
|
||||||
|
>r
|
||||||
|
>r (normalize-path) r>
|
||||||
|
[ (add-watch) ] [ drop ] 2bi r>
|
||||||
|
<linux-monitor> [ ] [ ] [ wd>> ] tri watches get set-at ;
|
||||||
|
|
||||||
|
: check-inotify
|
||||||
|
inotify get [
|
||||||
|
"Calling <monitor> outside with-monitors" throw
|
||||||
|
] unless ;
|
||||||
|
|
||||||
|
M: linux (monitor) ( path recursive? mailbox -- monitor )
|
||||||
|
swap [
|
||||||
|
<recursive-monitor>
|
||||||
|
] [
|
||||||
|
check-inotify
|
||||||
|
IN_CHANGE_EVENTS swap add-watch
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
M: linux-monitor dispose ( monitor -- )
|
||||||
|
[ wd>> watches get delete-at ]
|
||||||
|
[ wd>> inotify-fd swap inotify_rm_watch io-error ] bi ;
|
||||||
|
|
||||||
|
: ignore-flags? ( mask -- ? )
|
||||||
|
{
|
||||||
|
IN_DELETE_SELF
|
||||||
|
IN_MOVE_SELF
|
||||||
|
IN_UNMOUNT
|
||||||
|
IN_Q_OVERFLOW
|
||||||
|
IN_IGNORED
|
||||||
|
} flags bitand 0 > ;
|
||||||
|
|
||||||
|
: parse-action ( mask -- changed )
|
||||||
|
[
|
||||||
|
IN_CREATE +add-file+ ?flag
|
||||||
|
IN_DELETE +remove-file+ ?flag
|
||||||
|
IN_MODIFY +modify-file+ ?flag
|
||||||
|
IN_ATTRIB +modify-file+ ?flag
|
||||||
|
IN_MOVED_FROM +rename-file-old+ ?flag
|
||||||
|
IN_MOVED_TO +rename-file-new+ ?flag
|
||||||
|
drop
|
||||||
|
] { } make prune ;
|
||||||
|
|
||||||
|
: parse-file-notify ( buffer -- path changed )
|
||||||
|
dup inotify-event-mask ignore-flags? [
|
||||||
|
drop f f
|
||||||
|
] [
|
||||||
|
[ inotify-event-name alien>char-string ]
|
||||||
|
[ inotify-event-mask parse-action ] bi
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: events-exhausted? ( i buffer -- ? )
|
||||||
|
fill>> >= ;
|
||||||
|
|
||||||
|
: inotify-event@ ( i buffer -- alien )
|
||||||
|
ptr>> <displaced-alien> ;
|
||||||
|
|
||||||
|
: next-event ( i buffer -- i buffer )
|
||||||
|
2dup inotify-event@
|
||||||
|
inotify-event-len "inotify-event" heap-size +
|
||||||
|
swap >r + r> ;
|
||||||
|
|
||||||
|
: parse-file-notifications ( i buffer -- )
|
||||||
|
2dup events-exhausted? [ 2drop ] [
|
||||||
|
2dup inotify-event@ dup inotify-event-wd wd>monitor
|
||||||
|
>r parse-file-notify r> queue-change
|
||||||
|
next-event parse-file-notifications
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: inotify-read-loop ( port -- )
|
||||||
|
dup wait-to-read1
|
||||||
|
0 over parse-file-notifications
|
||||||
|
0 over buffer-reset
|
||||||
|
inotify-read-loop ;
|
||||||
|
|
||||||
|
: inotify-read-thread ( port -- )
|
||||||
|
[ inotify-read-loop ] curry ignore-errors ;
|
||||||
|
|
||||||
|
M: linux init-monitors
|
||||||
|
H{ } clone watches set
|
||||||
|
<inotify> [
|
||||||
|
[ inotify set ]
|
||||||
|
[
|
||||||
|
[ inotify-read-thread ] curry
|
||||||
|
"Linux monitor thread" spawn drop
|
||||||
|
] bi
|
||||||
|
] [
|
||||||
|
"Linux kernel version is too old" throw
|
||||||
|
] if* ;
|
||||||
|
|
||||||
|
M: linux dispose-monitors
|
||||||
|
inotify get dispose ;
|
||||||
|
|
@ -1,23 +1,27 @@
|
||||||
USING: io.unix.bsd io.backend io.monitors io.monitors.private
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
continuations kernel core-foundation.fsevents sequences
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
namespaces arrays system ;
|
USING: io.unix.bsd io.backend io.monitors core-foundation.fsevents
|
||||||
|
continuations kernel sequences namespaces arrays system locals
|
||||||
|
accessors ;
|
||||||
IN: io.unix.macosx
|
IN: io.unix.macosx
|
||||||
|
|
||||||
macosx set-io-backend
|
TUPLE: macosx-monitor < monitor handle ;
|
||||||
|
|
||||||
TUPLE: macosx-monitor ;
|
|
||||||
|
|
||||||
: enqueue-notifications ( triples monitor -- )
|
: enqueue-notifications ( triples monitor -- )
|
||||||
tuck monitor-queue
|
[
|
||||||
[ [ first { +modify-file+ } swap changed-file ] each ] bind
|
>r first { +modify-file+ } r> queue-change
|
||||||
notify-callback ;
|
] curry each ;
|
||||||
|
|
||||||
M: macosx <monitor>
|
M: macosx init-monitors ;
|
||||||
drop
|
|
||||||
f macosx-monitor construct-simple-monitor
|
M: macosx dispose-monitors ;
|
||||||
|
|
||||||
|
M:: macosx (monitor) ( path recursive? mailbox -- monitor )
|
||||||
|
path mailbox macosx-monitor construct-monitor
|
||||||
dup [ enqueue-notifications ] curry
|
dup [ enqueue-notifications ] curry
|
||||||
rot 1array 0 0 <event-stream>
|
path 1array 0 0 <event-stream> >>handle ;
|
||||||
over set-simple-monitor-handle ;
|
|
||||||
|
|
||||||
M: macosx-monitor dispose
|
M: macosx-monitor dispose
|
||||||
dup simple-monitor-handle dispose delegate dispose ;
|
handle>> dispose ;
|
||||||
|
|
||||||
|
macosx set-io-backend
|
||||||
|
|
|
||||||
|
|
@ -29,7 +29,6 @@ TUPLE: select-mx read-fdset write-fdset ;
|
||||||
[ handle-fd ] 2curry assoc-each ;
|
[ handle-fd ] 2curry assoc-each ;
|
||||||
|
|
||||||
: init-fdset ( tasks fdset -- )
|
: init-fdset ( tasks fdset -- )
|
||||||
! dup clear-bits
|
|
||||||
[ >r drop t swap munge r> set-nth ] curry assoc-each ;
|
[ >r drop t swap munge r> set-nth ] curry assoc-each ;
|
||||||
|
|
||||||
: read-fdset/tasks
|
: read-fdset/tasks
|
||||||
|
|
@ -45,9 +44,9 @@ TUPLE: select-mx read-fdset write-fdset ;
|
||||||
[ reads>> max-fd ] [ writes>> max-fd ] bi max 1+ ;
|
[ reads>> max-fd ] [ writes>> max-fd ] bi max 1+ ;
|
||||||
|
|
||||||
: init-fdsets ( mx -- nfds read write except )
|
: init-fdsets ( mx -- nfds read write except )
|
||||||
[ num-fds ] keep
|
[ num-fds ]
|
||||||
[ read-fdset/tasks tuck init-fdset ] keep
|
[ read-fdset/tasks tuck init-fdset ]
|
||||||
write-fdset/tasks tuck init-fdset
|
[ write-fdset/tasks tuck init-fdset ] tri
|
||||||
f ;
|
f ;
|
||||||
|
|
||||||
M: select-mx wait-for-events ( ms mx -- )
|
M: select-mx wait-for-events ( ms mx -- )
|
||||||
|
|
|
||||||
|
|
@ -1,56 +1,109 @@
|
||||||
|
|
||||||
USING: kernel sequences assocs qualified circular ;
|
USING: kernel sequences assocs qualified circular ;
|
||||||
|
|
||||||
|
USING: math multi-methods ;
|
||||||
|
|
||||||
QUALIFIED: sequences
|
QUALIFIED: sequences
|
||||||
|
QUALIFIED: assocs
|
||||||
QUALIFIED: circular
|
QUALIFIED: circular
|
||||||
|
|
||||||
IN: newfx
|
IN: newfx
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
! Now, we can see a new world coming into view.
|
! Now, we can see a new world coming into view.
|
||||||
! A world in which there is the very real prospect of a new world order.
|
! A world in which there is the very real prospect of a new world order.
|
||||||
!
|
!
|
||||||
! - George Herbert Walker Bush
|
! - George Herbert Walker Bush
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
GENERIC: at ( col key -- val )
|
||||||
|
GENERIC: of ( key col -- val )
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
: nth-at ( seq i -- val ) swap nth ;
|
GENERIC: grab ( col key -- col val )
|
||||||
: nth-of ( i seq -- val ) nth ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
: nth-is ( seq i val -- seq ) swap pick set-nth ;
|
GENERIC: is ( col key val -- col )
|
||||||
: is-nth ( seq val i -- seq ) pick set-nth ;
|
GENERIC: as ( col val key -- col )
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
: nth-is-of ( i val seq -- seq ) dup >r swapd set-nth r> ;
|
GENERIC: is-of ( key val col -- col )
|
||||||
: is-nth-of ( val i seq -- seq ) dup >r set-nth r> ;
|
GENERIC: as-of ( val key col -- col )
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
: mutate-nth ( seq i val -- ) swap rot set-nth ;
|
GENERIC: mutate-at ( col key val -- )
|
||||||
: mutate-nth-at ( seq val i -- ) rot set-nth ;
|
GENERIC: mutate-as ( col val key -- )
|
||||||
|
|
||||||
: mutate-nth-of ( i val seq -- ) swapd set-nth ;
|
|
||||||
: mutate-nth-at-of ( val i seq -- ) set-nth ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
: at-key ( tbl key -- val ) swap at ;
|
GENERIC: at-mutate ( key val col -- )
|
||||||
: key-of ( key tbl -- val ) at ;
|
GENERIC: as-mutate ( val key col -- )
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
! sequence
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
METHOD: at { sequence number } swap nth ;
|
||||||
|
METHOD: of { number sequence } nth ;
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
: key-is ( tbl key val -- tbl ) swap pick set-at ;
|
METHOD: grab { sequence number } dupd swap nth ;
|
||||||
: is-key ( tbl val key -- tbl ) pick set-at ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
: mutate-key ( tbl key val -- ) swap rot set-at ;
|
METHOD: is { sequence number object } swap pick set-nth ;
|
||||||
: mutate-at-key ( tbl val key -- ) rot set-at ;
|
METHOD: as { sequence object number } pick set-nth ;
|
||||||
|
|
||||||
: mutate-key-of ( key val tbl -- ) swapd set-at ;
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
: mutate-at-key-of ( val key tbl -- ) set-at ;
|
|
||||||
|
METHOD: is-of { number object sequence } dup >r swapd set-nth r> ;
|
||||||
|
METHOD: as-of { object number sequence } dup >r set-nth r> ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
METHOD: mutate-at { sequence number object } swap rot set-nth ;
|
||||||
|
METHOD: mutate-as { sequence object number } rot set-nth ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
METHOD: at-mutate { number object sequence } swapd set-nth ;
|
||||||
|
METHOD: as-mutate { object number sequence } set-nth ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
! assoc
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
METHOD: at { assoc object } swap assocs:at ;
|
||||||
|
METHOD: of { object assoc } assocs:at ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
METHOD: grab { assoc object } dupd swap assocs:at ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
METHOD: is { assoc object object } swap pick set-at ;
|
||||||
|
METHOD: as { assoc object object } pick set-at ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
METHOD: is-of { object object assoc } dup >r swapd set-at r> ;
|
||||||
|
METHOD: as-of { object object assoc } dup >r set-at r> ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
METHOD: mutate-at { assoc object object } swap rot set-at ;
|
||||||
|
METHOD: mutate-as { assoc object object } rot set-at ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
METHOD: at-mutate { object object assoc } swapd set-at ;
|
||||||
|
METHOD: as-mutate { object object assoc } set-at ;
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,7 @@
|
||||||
USING: alien alien.syntax combinators kernel parser sequences
|
USING: alien alien.syntax combinators kernel parser sequences
|
||||||
system words namespaces hashtables init math arrays assocs
|
system words namespaces hashtables init math arrays assocs
|
||||||
continuations ;
|
continuations ;
|
||||||
|
IN: opengl.gl.extensions
|
||||||
|
|
||||||
ERROR: unknown-gl-platform ;
|
ERROR: unknown-gl-platform ;
|
||||||
<< {
|
<< {
|
||||||
|
|
@ -9,7 +10,6 @@ ERROR: unknown-gl-platform ;
|
||||||
{ [ os unix? ] [ "opengl.gl.unix" ] }
|
{ [ os unix? ] [ "opengl.gl.unix" ] }
|
||||||
[ unknown-gl-platform ]
|
[ unknown-gl-platform ]
|
||||||
} cond use+ >>
|
} cond use+ >>
|
||||||
IN: opengl.gl.extensions
|
|
||||||
|
|
||||||
SYMBOL: +gl-function-number-counter+
|
SYMBOL: +gl-function-number-counter+
|
||||||
SYMBOL: +gl-function-pointers+
|
SYMBOL: +gl-function-pointers+
|
||||||
|
|
|
||||||
|
|
@ -1,97 +0,0 @@
|
||||||
|
|
||||||
USING: help.syntax help.markup ;
|
|
||||||
|
|
||||||
IN: processing.gallery.bubble-chamber
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
HELP: muon
|
|
||||||
|
|
||||||
{ $class-description
|
|
||||||
"The muon is a colorful particle with an entangled friend."
|
|
||||||
"It draws both itself and its horizontally symmetric partner."
|
|
||||||
"A high range of speed and almost no speed decay allow the"
|
|
||||||
"muon to reach the extents of the window, often forming rings"
|
|
||||||
"where theta has decayed but speed remains stable. The result"
|
|
||||||
"is color almost everywhere in the general direction of collision,"
|
|
||||||
"stabilized into fuzzy rings." } ;
|
|
||||||
|
|
||||||
HELP: quark
|
|
||||||
|
|
||||||
{ $class-description
|
|
||||||
"The quark draws as a translucent black. Their large numbers"
|
|
||||||
"create fields of blackness overwritten only by the glowing shadows of "
|
|
||||||
"Hadrons. "
|
|
||||||
"quarks are allowed to accelerate away with speed decay values above 1.0. "
|
|
||||||
"Each quark has an entangled friend. Both particles are drawn identically,"
|
|
||||||
"mirrored along the y-axis." } ;
|
|
||||||
|
|
||||||
HELP: hadron
|
|
||||||
|
|
||||||
{ $class-description
|
|
||||||
"Hadrons collide from totally random directions. "
|
|
||||||
"Those hadrons that do not exit the drawing area, "
|
|
||||||
"tend to stabilize into perfect circular orbits. "
|
|
||||||
"Each hadron draws with a slight glowing emboss. "
|
|
||||||
"The hadron itself is not drawn." } ;
|
|
||||||
|
|
||||||
HELP: axion
|
|
||||||
|
|
||||||
{ $class-description
|
|
||||||
"The axion particle draws a bold black path. Axions exist "
|
|
||||||
"in a slightly higher dimension and as such are drawn with "
|
|
||||||
"elevated embossed shadows. Axions are quick to stabilize "
|
|
||||||
"and fall into single pixel orbits axions automatically "
|
|
||||||
"recollide themselves after stabilizing." } ;
|
|
||||||
|
|
||||||
{ muon quark hadron axion } related-words
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
ARTICLE: "bubble-chamber" "Bubble Chamber"
|
|
||||||
|
|
||||||
{ $subsection "bubble-chamber-introduction" }
|
|
||||||
{ $subsection "bubble-chamber-particles" }
|
|
||||||
{ $subsection "bubble-chamber-author" }
|
|
||||||
{ $subsection "bubble-chamber-running" } ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
ARTICLE: "bubble-chamber-introduction" "Introduction"
|
|
||||||
|
|
||||||
"The Bubble Chamber is a generative painting system of imaginary "
|
|
||||||
"colliding particles. A single super-massive collision produces a "
|
|
||||||
"discrete universe of four particle types. Particles draw their "
|
|
||||||
"positions over time as pixel exposures. " ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
ARTICLE: "bubble-chamber-particles" "Particles"
|
|
||||||
|
|
||||||
"Four types of particles exist. The behavior and graphic appearance of "
|
|
||||||
"each particle type is unique."
|
|
||||||
|
|
||||||
{ $subsection muon }
|
|
||||||
{ $subsection quark }
|
|
||||||
{ $subsection hadron }
|
|
||||||
{ $subsection axion } ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
ARTICLE: "bubble-chamber-author" "Author"
|
|
||||||
|
|
||||||
"Bubble Chamber was created by Jared Tarbell. "
|
|
||||||
"It was originally implemented in Processing. "
|
|
||||||
"It was ported to Factor by Eduardo Cavazos. "
|
|
||||||
"The original work is on display here: "
|
|
||||||
{ $url
|
|
||||||
"http://www.complexification.net/gallery/machines/bubblechamber/" } ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
ARTICLE: "bubble-chamber-running" "How to use"
|
|
||||||
|
|
||||||
"After you run the vocabulary, a window will appear. Click the "
|
|
||||||
"mouse in a random area to fire 11 particles of each type. "
|
|
||||||
"Another way to fire particles is to press the "
|
|
||||||
"spacebar. This fires all the particles." ;
|
|
||||||
|
|
@ -1,453 +0,0 @@
|
||||||
|
|
||||||
USING: kernel namespaces sequences combinators arrays threads
|
|
||||||
|
|
||||||
math
|
|
||||||
math.libm
|
|
||||||
math.vectors
|
|
||||||
math.ranges
|
|
||||||
math.constants
|
|
||||||
math.functions
|
|
||||||
math.points
|
|
||||||
|
|
||||||
ui
|
|
||||||
ui.gadgets
|
|
||||||
|
|
||||||
random accessors multi-methods
|
|
||||||
combinators.cleave
|
|
||||||
vars locals
|
|
||||||
|
|
||||||
newfx
|
|
||||||
|
|
||||||
processing
|
|
||||||
processing.gadget
|
|
||||||
processing.color ;
|
|
||||||
|
|
||||||
IN: processing.gallery.bubble-chamber
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
: move-by ( obj delta -- obj ) over pos>> v+ >>pos ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
: dim ( -- dim ) 1000 ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
VAR: collision-theta
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
VAR: boom
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
VARS: particles muons quarks hadrons axions ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
: good-colors ( -- seq )
|
|
||||||
{
|
|
||||||
T{ rgba f 0.23 0.14 0.17 1 }
|
|
||||||
T{ rgba f 0.23 0.14 0.15 1 }
|
|
||||||
T{ rgba f 0.21 0.14 0.15 1 }
|
|
||||||
T{ rgba f 0.51 0.39 0.33 1 }
|
|
||||||
T{ rgba f 0.49 0.33 0.20 1 }
|
|
||||||
T{ rgba f 0.55 0.45 0.32 1 }
|
|
||||||
T{ rgba f 0.69 0.63 0.51 1 }
|
|
||||||
T{ rgba f 0.64 0.39 0.18 1 }
|
|
||||||
T{ rgba f 0.73 0.42 0.20 1 }
|
|
||||||
T{ rgba f 0.71 0.45 0.29 1 }
|
|
||||||
T{ rgba f 0.79 0.45 0.22 1 }
|
|
||||||
T{ rgba f 0.82 0.56 0.34 1 }
|
|
||||||
T{ rgba f 0.88 0.72 0.49 1 }
|
|
||||||
T{ rgba f 0.85 0.69 0.40 1 }
|
|
||||||
T{ rgba f 0.96 0.92 0.75 1 }
|
|
||||||
T{ rgba f 0.99 0.98 0.87 1 }
|
|
||||||
T{ rgba f 0.85 0.82 0.69 1 }
|
|
||||||
T{ rgba f 0.99 0.98 0.87 1 }
|
|
||||||
T{ rgba f 0.82 0.82 0.79 1 }
|
|
||||||
T{ rgba f 0.65 0.69 0.67 1 }
|
|
||||||
T{ rgba f 0.53 0.60 0.55 1 }
|
|
||||||
T{ rgba f 0.57 0.53 0.68 1 }
|
|
||||||
T{ rgba f 0.47 0.42 0.56 1 }
|
|
||||||
} ;
|
|
||||||
|
|
||||||
: good-color ( i -- color ) good-colors nth-of ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
: x ( particle -- x ) pos>> first ;
|
|
||||||
: y ( particle -- x ) pos>> second ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
: out-of-bounds? ( particle -- particle ? )
|
|
||||||
dup
|
|
||||||
{ [ x dim neg < ] [ x dim 2 * > ] [ y dim neg < ] [ y dim 2 * > ] } cleave
|
|
||||||
or or or ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
TUPLE: particle pos vel speed speed-d theta theta-d theta-dd myc mya ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
: initialize-particle ( particle -- particle )
|
|
||||||
|
|
||||||
0 0 {2} >>pos
|
|
||||||
0 0 {2} >>vel
|
|
||||||
|
|
||||||
0 >>speed
|
|
||||||
0 >>speed-d
|
|
||||||
0 >>theta
|
|
||||||
0 >>theta-d
|
|
||||||
0 >>theta-dd
|
|
||||||
|
|
||||||
0 0 0 1 <rgba> >>myc
|
|
||||||
0 0 0 1 <rgba> >>mya ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
GENERIC: collide ( particle -- )
|
|
||||||
GENERIC: move ( particle -- )
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
TUPLE: muon < particle ;
|
|
||||||
|
|
||||||
: <muon> ( -- muon ) muon construct-empty initialize-particle ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
METHOD: collide { muon }
|
|
||||||
|
|
||||||
dim 2 / dup 2array >>pos
|
|
||||||
2 32 [a,b] random >>speed
|
|
||||||
0.0001 0.001 2random >>speed-d
|
|
||||||
|
|
||||||
collision-theta> -0.1 0.1 2random + >>theta
|
|
||||||
0 >>theta-d
|
|
||||||
0 >>theta-dd
|
|
||||||
|
|
||||||
[ dup theta-dd>> abs 0.001 < ]
|
|
||||||
[ -0.1 0.1 2random >>theta-dd ]
|
|
||||||
[ ]
|
|
||||||
while
|
|
||||||
|
|
||||||
dup theta>> pi +
|
|
||||||
2 pi * /
|
|
||||||
good-colors length 1 - *
|
|
||||||
[ ] [ good-colors length >= ] [ 0 < ] tri or
|
|
||||||
[ drop ]
|
|
||||||
[
|
|
||||||
[ good-color >>myc ]
|
|
||||||
[ good-colors length swap - 1 - good-color >>mya ]
|
|
||||||
bi
|
|
||||||
]
|
|
||||||
if
|
|
||||||
|
|
||||||
drop ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
METHOD: move { muon }
|
|
||||||
|
|
||||||
dup myc>> 0.16 >>alpha stroke
|
|
||||||
dup pos>> point
|
|
||||||
|
|
||||||
dup mya>> 0.16 >>alpha stroke
|
|
||||||
dup pos>> first2 >r dim swap - r> 2array point
|
|
||||||
|
|
||||||
dup
|
|
||||||
[ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
|
|
||||||
move-by
|
|
||||||
|
|
||||||
[ ] [ theta>> ] [ theta-d>> ] tri + >>theta
|
|
||||||
[ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
|
|
||||||
[ ] [ speed>> ] [ speed-d>> ] tri - >>speed
|
|
||||||
|
|
||||||
out-of-bounds?
|
|
||||||
[ collide ]
|
|
||||||
[ drop ]
|
|
||||||
if ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
TUPLE: quark < particle ;
|
|
||||||
|
|
||||||
: <quark> ( -- quark ) quark construct-empty initialize-particle ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
METHOD: collide { quark }
|
|
||||||
|
|
||||||
dim 2 / dup 2array >>pos
|
|
||||||
collision-theta> -0.11 0.11 2random + >>theta
|
|
||||||
0.5 3.0 2random >>speed
|
|
||||||
|
|
||||||
0.996 1.001 2random >>speed-d
|
|
||||||
0 >>theta-d
|
|
||||||
0 >>theta-dd
|
|
||||||
|
|
||||||
[ dup theta-dd>> abs 0.00001 < ]
|
|
||||||
[ -0.001 0.001 2random >>theta-dd ]
|
|
||||||
[ ]
|
|
||||||
while
|
|
||||||
|
|
||||||
drop ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
METHOD: move { quark }
|
|
||||||
|
|
||||||
dup myc>> 0.13 >>alpha stroke
|
|
||||||
dup pos>> point
|
|
||||||
|
|
||||||
dup pos>> first2 >r dim swap - r> 2array point
|
|
||||||
|
|
||||||
[ ] [ vel>> ] bi move-by
|
|
||||||
|
|
||||||
dup
|
|
||||||
[ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
|
|
||||||
>>vel
|
|
||||||
|
|
||||||
[ ] [ theta>> ] [ theta-d>> ] tri + >>theta
|
|
||||||
[ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
|
|
||||||
[ ] [ speed>> ] [ speed-d>> ] tri * >>speed
|
|
||||||
|
|
||||||
! 1000 random 997 >
|
|
||||||
3/1000 chance
|
|
||||||
[
|
|
||||||
dup speed>> neg >>speed
|
|
||||||
2 over speed-d>> - >>speed-d
|
|
||||||
]
|
|
||||||
when
|
|
||||||
|
|
||||||
out-of-bounds?
|
|
||||||
[ collide ]
|
|
||||||
[ drop ]
|
|
||||||
if ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
TUPLE: hadron < particle ;
|
|
||||||
|
|
||||||
: <hadron> ( -- hadron ) hadron construct-empty initialize-particle ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
METHOD: collide { hadron }
|
|
||||||
|
|
||||||
dim 2 / dup 2array >>pos
|
|
||||||
2 pi * 1random >>theta
|
|
||||||
0.5 3.5 2random >>speed
|
|
||||||
|
|
||||||
0.996 1.001 2random >>speed-d
|
|
||||||
0 >>theta-d
|
|
||||||
0 >>theta-dd
|
|
||||||
|
|
||||||
[ dup theta-dd>> abs 0.00001 < ]
|
|
||||||
[ -0.001 0.001 2random >>theta-dd ]
|
|
||||||
[ ]
|
|
||||||
while
|
|
||||||
|
|
||||||
0 1 0 <rgb> >>myc
|
|
||||||
|
|
||||||
drop ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
METHOD: move { hadron }
|
|
||||||
|
|
||||||
{ 1 0.11 } stroke
|
|
||||||
dup pos>> 1 v-y point
|
|
||||||
|
|
||||||
{ 0 0.11 } stroke
|
|
||||||
dup pos>> 1 v+y point
|
|
||||||
|
|
||||||
dup vel>> move-by
|
|
||||||
|
|
||||||
dup
|
|
||||||
[ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
|
|
||||||
>>vel
|
|
||||||
|
|
||||||
[ ] [ theta>> ] [ theta-d>> ] tri + >>theta
|
|
||||||
[ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
|
|
||||||
[ ] [ speed>> ] [ speed-d>> ] tri * >>speed
|
|
||||||
|
|
||||||
! 1000 random 997 >
|
|
||||||
3/1000 chance
|
|
||||||
[
|
|
||||||
1.0 >>speed-d
|
|
||||||
0.00001 >>theta-dd
|
|
||||||
|
|
||||||
! 100 random 70 >
|
|
||||||
30/100 chance
|
|
||||||
[
|
|
||||||
dim 2 / dup 2array >>pos
|
|
||||||
dup collide
|
|
||||||
]
|
|
||||||
when
|
|
||||||
]
|
|
||||||
when
|
|
||||||
|
|
||||||
out-of-bounds?
|
|
||||||
[ collide ]
|
|
||||||
[ drop ]
|
|
||||||
if ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
TUPLE: axion < particle ;
|
|
||||||
|
|
||||||
: <axion> ( -- axion ) axion construct-empty initialize-particle ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
METHOD: collide { axion }
|
|
||||||
|
|
||||||
dim 2 / dup 2array >>pos
|
|
||||||
2 pi * 1random >>theta
|
|
||||||
1.0 6.0 2random >>speed
|
|
||||||
|
|
||||||
0.998 1.000 2random >>speed-d
|
|
||||||
0 >>theta-d
|
|
||||||
0 >>theta-dd
|
|
||||||
|
|
||||||
[ dup theta-dd>> abs 0.00001 < ]
|
|
||||||
[ -0.001 0.001 2random >>theta-dd ]
|
|
||||||
[ ]
|
|
||||||
while
|
|
||||||
|
|
||||||
drop ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
METHOD: move { axion }
|
|
||||||
|
|
||||||
{ 0.06 0.59 } stroke
|
|
||||||
dup pos>> point
|
|
||||||
|
|
||||||
1 4 [a,b]
|
|
||||||
[| dy |
|
|
||||||
1 30 dy 6 * - 255.0 / 2array stroke
|
|
||||||
dup pos>> 0 dy neg 2array v+ point
|
|
||||||
] with-locals
|
|
||||||
each
|
|
||||||
|
|
||||||
1 4 [a,b]
|
|
||||||
[| dy |
|
|
||||||
0 30 dy 6 * - 255.0 / 2array stroke
|
|
||||||
dup pos>> dy v+y point
|
|
||||||
] with-locals
|
|
||||||
each
|
|
||||||
|
|
||||||
dup vel>> move-by
|
|
||||||
|
|
||||||
dup
|
|
||||||
[ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
|
|
||||||
>>vel
|
|
||||||
|
|
||||||
[ ] [ theta>> ] [ theta-d>> ] tri + >>theta
|
|
||||||
[ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
|
|
||||||
[ ] [ speed>> ] [ speed-d>> ] tri * >>speed
|
|
||||||
|
|
||||||
[ ] [ speed-d>> 0.9999 * ] bi >>speed-d
|
|
||||||
|
|
||||||
! 1000 random 996 >
|
|
||||||
4/1000 chance
|
|
||||||
[
|
|
||||||
dup speed>> neg >>speed
|
|
||||||
dup speed-d>> neg 2 + >>speed-d
|
|
||||||
|
|
||||||
! 100 random 30 >
|
|
||||||
70/100 chance
|
|
||||||
[
|
|
||||||
dim 2 / dup 2array >>pos
|
|
||||||
collide
|
|
||||||
]
|
|
||||||
[ drop ]
|
|
||||||
if
|
|
||||||
]
|
|
||||||
[ drop ]
|
|
||||||
if ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
! : draw ( -- )
|
|
||||||
|
|
||||||
! boom>
|
|
||||||
! [ particles> [ move ] each ]
|
|
||||||
! when ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
: collide-all ( -- )
|
|
||||||
|
|
||||||
2 pi * 1random >collision-theta
|
|
||||||
|
|
||||||
particles> [ collide ] each ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
: collide-one ( -- )
|
|
||||||
|
|
||||||
dim 2 / mouse-x - dim 2 / mouse-y - fatan2 >collision-theta
|
|
||||||
|
|
||||||
hadrons> random collide
|
|
||||||
quarks> random collide
|
|
||||||
muons> random collide ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
: mouse-pressed ( -- )
|
|
||||||
boom on
|
|
||||||
1 background ! kludge
|
|
||||||
11 [ drop collide-one ] each ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
: key-released ( -- )
|
|
||||||
key " " =
|
|
||||||
[
|
|
||||||
boom on
|
|
||||||
1 background
|
|
||||||
collide-all
|
|
||||||
]
|
|
||||||
when ;
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
: bubble-chamber ( -- )
|
|
||||||
|
|
||||||
1000 1000 size*
|
|
||||||
|
|
||||||
[
|
|
||||||
1 background
|
|
||||||
no-stroke
|
|
||||||
|
|
||||||
1789 [ drop <muon> ] map >muons
|
|
||||||
1300 [ drop <quark> ] map >quarks
|
|
||||||
1000 [ drop <hadron> ] map >hadrons
|
|
||||||
111 [ drop <axion> ] map >axions
|
|
||||||
|
|
||||||
muons> quarks> hadrons> axions> 3append append >particles
|
|
||||||
|
|
||||||
collide-one
|
|
||||||
] setup
|
|
||||||
|
|
||||||
[
|
|
||||||
boom>
|
|
||||||
[ particles> [ move ] each ]
|
|
||||||
when
|
|
||||||
] draw
|
|
||||||
|
|
||||||
[ mouse-pressed ] button-down
|
|
||||||
[ key-released ] key-up
|
|
||||||
|
|
||||||
;
|
|
||||||
|
|
||||||
: go ( -- ) [ bubble-chamber run ] with-ui ;
|
|
||||||
|
|
||||||
MAIN: go
|
|
||||||
|
|
@ -8,7 +8,7 @@ USING: kernel namespaces threads combinators sequences arrays
|
||||||
combinators
|
combinators
|
||||||
combinators.lib
|
combinators.lib
|
||||||
combinators.cleave
|
combinators.cleave
|
||||||
rewrite-closures fry accessors
|
rewrite-closures fry accessors newfx
|
||||||
processing.color
|
processing.color
|
||||||
processing.gadget ;
|
processing.gadget ;
|
||||||
|
|
||||||
|
|
@ -28,6 +28,14 @@ IN: processing
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
! : at-fraction ( seq fraction -- val ) over length 1- * nth-at ;
|
||||||
|
|
||||||
|
: at-fraction ( seq fraction -- val ) over length 1- * at ;
|
||||||
|
|
||||||
|
: at-fraction-of ( fraction seq -- val ) swap at-fraction ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
VAR: fill-color
|
VAR: fill-color
|
||||||
VAR: stroke-color
|
VAR: stroke-color
|
||||||
|
|
||||||
|
|
@ -282,7 +290,7 @@ VAR: frame-rate-value
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
VAR: slate
|
! VAR: slate
|
||||||
|
|
||||||
VAR: loop-flag
|
VAR: loop-flag
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,28 @@
|
||||||
|
USING: kernel math tools.test namespaces random
|
||||||
|
random.blum-blum-shub ;
|
||||||
|
IN: blum-blum-shub.tests
|
||||||
|
|
||||||
|
[ 887708070 ] [
|
||||||
|
T{ blum-blum-shub f 590695557939 811977232793 } random-32*
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
|
||||||
|
[ 887708070 ] [
|
||||||
|
T{ blum-blum-shub f 590695557939 811977232793 } [
|
||||||
|
32 random-bits
|
||||||
|
] with-random
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ 5726770047455156646 ] [
|
||||||
|
T{ blum-blum-shub f 590695557939 811977232793 } [
|
||||||
|
64 random-bits
|
||||||
|
] with-random
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ 3716213681 ]
|
||||||
|
[
|
||||||
|
100 T{ blum-blum-shub f 200352954495 846054538649 } tuck [
|
||||||
|
random-32* drop
|
||||||
|
] curry times
|
||||||
|
random-32*
|
||||||
|
] unit-test
|
||||||
|
|
@ -3,34 +3,26 @@ math.miller-rabin combinators.lib
|
||||||
math.functions accessors random ;
|
math.functions accessors random ;
|
||||||
IN: random.blum-blum-shub
|
IN: random.blum-blum-shub
|
||||||
|
|
||||||
! TODO: take (log log M) bits instead of 1 bit
|
! Blum Blum Shub, n = pq, x_i+1 = x_i ^ 2 mod n
|
||||||
! Blum Blum Shub, M = pq
|
! return low bit of x+1
|
||||||
TUPLE: blum-blum-shub x n ;
|
TUPLE: blum-blum-shub x n ;
|
||||||
|
|
||||||
C: <blum-blum-shub> blum-blum-shub
|
<PRIVATE
|
||||||
|
|
||||||
: generate-bbs-primes ( numbits -- p q )
|
: generate-bbs-primes ( numbits -- p q )
|
||||||
#! two primes congruent to 3 (mod 4)
|
|
||||||
[ [ random-prime ] curry [ 4 mod 3 = ] generate ] dup bi ;
|
[ [ random-prime ] curry [ 4 mod 3 = ] generate ] dup bi ;
|
||||||
|
|
||||||
IN: crypto
|
|
||||||
: <blum-blum-shub> ( numbits -- blum-blum-shub )
|
: <blum-blum-shub> ( numbits -- blum-blum-shub )
|
||||||
#! returns a Blum-Blum-Shub tuple
|
|
||||||
generate-bbs-primes *
|
generate-bbs-primes *
|
||||||
[ find-relative-prime ] keep
|
[ find-relative-prime ] keep
|
||||||
blum-blum-shub construct-boa ;
|
blum-blum-shub construct-boa ;
|
||||||
|
|
||||||
! 256 make-bbs blum-blum-shub set-global
|
|
||||||
|
|
||||||
: next-bbs-bit ( bbs -- bit )
|
: next-bbs-bit ( bbs -- bit )
|
||||||
#! x = x^2 mod n, return low bit of calculated x
|
[ [ x>> 2 ] [ n>> ] bi ^mod ] keep
|
||||||
[ [ x>> 2 ] [ n>> ] bi ^mod ]
|
over >>x drop 1 bitand ;
|
||||||
[ [ >>x ] keep x>> 1 bitand ] bi ;
|
|
||||||
|
|
||||||
IN: crypto
|
PRIVATE>
|
||||||
! : random ( n -- n )
|
|
||||||
! ! #! Cryptographically secure random number using Blum-Blum-Shub 256
|
|
||||||
! [ log2 1+ random-bits ] keep dupd >= [ -1 shift ] when ;
|
|
||||||
|
|
||||||
M: blum-blum-shub random-32* ( bbs -- r )
|
M: blum-blum-shub random-32* ( bbs -- r )
|
||||||
;
|
0 32 rot
|
||||||
|
[ next-bbs-bit swap 1 shift bitor ] curry times ;
|
||||||
|
|
|
||||||
|
|
@ -22,7 +22,7 @@ heaps.private system math math.parser ;
|
||||||
: threads. ( -- )
|
: threads. ( -- )
|
||||||
standard-table-style [
|
standard-table-style [
|
||||||
[
|
[
|
||||||
{ "ID" "Name" "Waiting on" "Remaining sleep" }
|
{ "ID:" "Name:" "Waiting on:" "Remaining sleep:" }
|
||||||
[ [ write ] with-cell ] each
|
[ [ write ] with-cell ] each
|
||||||
] with-row
|
] with-row
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -10,8 +10,7 @@ IN: tools.vocabs.monitor
|
||||||
{ { CHAR: / CHAR: . } { CHAR: \\ CHAR: . } } substitute ;
|
{ { CHAR: / CHAR: . } { CHAR: \\ CHAR: . } } substitute ;
|
||||||
|
|
||||||
: path>vocab-name ( path -- vocab )
|
: path>vocab-name ( path -- vocab )
|
||||||
dup ".factor" tail? [ parent-directory ] when
|
dup ".factor" tail? [ parent-directory ] when ;
|
||||||
;
|
|
||||||
|
|
||||||
: chop-vocab-root ( path -- path' )
|
: chop-vocab-root ( path -- path' )
|
||||||
"resource:" prepend-path (normalize-path)
|
"resource:" prepend-path (normalize-path)
|
||||||
|
|
@ -23,29 +22,32 @@ IN: tools.vocabs.monitor
|
||||||
: path>vocab ( path -- vocab )
|
: path>vocab ( path -- vocab )
|
||||||
chop-vocab-root path>vocab-name vocab-dir>vocab-name ;
|
chop-vocab-root path>vocab-name vocab-dir>vocab-name ;
|
||||||
|
|
||||||
: changed-vocab ( vocab -- )
|
: monitor-loop ( monitor -- )
|
||||||
dup vocab
|
|
||||||
[ dup changed-vocabs get-global set-at ] [ drop ] if ;
|
|
||||||
|
|
||||||
: monitor-thread ( monitor -- )
|
|
||||||
#! On OS X, monitors give us the full path, so we chop it
|
#! On OS X, monitors give us the full path, so we chop it
|
||||||
#! off if its there.
|
#! off if its there.
|
||||||
next-change drop path>vocab changed-vocab reset-cache ;
|
dup next-change drop path>vocab changed-vocab
|
||||||
|
reset-cache
|
||||||
|
monitor-loop ;
|
||||||
|
|
||||||
|
: monitor-thread ( -- )
|
||||||
|
[
|
||||||
|
[
|
||||||
|
"" resource-path t <monitor>
|
||||||
|
|
||||||
|
H{ } clone changed-vocabs set-global
|
||||||
|
vocabs [ changed-vocab ] each
|
||||||
|
|
||||||
|
monitor-loop
|
||||||
|
] with-monitors
|
||||||
|
] ignore-errors ;
|
||||||
|
|
||||||
: start-monitor-thread ( -- )
|
: start-monitor-thread ( -- )
|
||||||
#! Silently ignore errors during monitor creation since
|
#! Silently ignore errors during monitor creation since
|
||||||
#! monitors are not supported on all platforms.
|
#! monitors are not supported on all platforms.
|
||||||
[
|
[ monitor-thread ] "Vocabulary monitor" spawn drop ;
|
||||||
"" resource-path t <monitor> [ monitor-thread t ] curry
|
|
||||||
"Vocabulary monitor" spawn-server drop
|
|
||||||
|
|
||||||
H{ } clone changed-vocabs set-global
|
|
||||||
|
|
||||||
vocabs [ changed-vocab ] each
|
|
||||||
] ignore-errors ;
|
|
||||||
|
|
||||||
[
|
[
|
||||||
"-no-monitors" cli-args get member? [
|
"-no-monitors" cli-args member? [
|
||||||
start-monitor-thread
|
start-monitor-thread
|
||||||
] unless
|
] unless
|
||||||
] "tools.vocabs.monitor" add-init-hook
|
] "tools.vocabs.monitor" add-init-hook
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,9 @@
|
||||||
|
IN: tools.vocabs.tests
|
||||||
|
USING: tools.test tools.vocabs namespaces continuations ;
|
||||||
|
|
||||||
|
[ ] [
|
||||||
|
changed-vocabs get-global
|
||||||
|
f changed-vocabs set-global
|
||||||
|
[ t ] [ "kernel" changed-vocab? ] unit-test
|
||||||
|
[ "kernel" changed-vocab ] [ changed-vocabs set-global ] [ ] cleanup
|
||||||
|
] unit-test
|
||||||
|
|
@ -32,43 +32,6 @@ IN: tools.vocabs
|
||||||
[ vocab-tests % ] tri
|
[ vocab-tests % ] tri
|
||||||
] { } make ;
|
] { } make ;
|
||||||
|
|
||||||
: source-modified? ( path -- ? )
|
|
||||||
dup source-files get at [
|
|
||||||
dup source-file-path
|
|
||||||
dup exists? [
|
|
||||||
utf8 file-lines lines-crc32
|
|
||||||
swap source-file-checksum = not
|
|
||||||
] [
|
|
||||||
2drop f
|
|
||||||
] if
|
|
||||||
] [
|
|
||||||
exists?
|
|
||||||
] ?if ;
|
|
||||||
|
|
||||||
: modified ( seq quot -- seq )
|
|
||||||
[ dup ] swap compose { } map>assoc
|
|
||||||
[ nip ] assoc-subset
|
|
||||||
[ nip source-modified? ] assoc-subset keys ; inline
|
|
||||||
|
|
||||||
: modified-sources ( vocabs -- seq )
|
|
||||||
[ vocab-source-path ] modified ;
|
|
||||||
|
|
||||||
: modified-docs ( vocabs -- seq )
|
|
||||||
[ vocab-docs-path ] modified ;
|
|
||||||
|
|
||||||
SYMBOL: changed-vocabs
|
|
||||||
|
|
||||||
[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook
|
|
||||||
|
|
||||||
: filter-changed ( vocabs -- vocabs' )
|
|
||||||
changed-vocabs get [
|
|
||||||
[ delete-at* nip ] curry subset
|
|
||||||
] when* ;
|
|
||||||
|
|
||||||
: to-refresh ( prefix -- modified-sources modified-docs )
|
|
||||||
child-vocabs filter-changed
|
|
||||||
[ modified-sources ] [ modified-docs ] bi ;
|
|
||||||
|
|
||||||
: vocab-heading. ( vocab -- )
|
: vocab-heading. ( vocab -- )
|
||||||
nl
|
nl
|
||||||
"==== " write
|
"==== " write
|
||||||
|
|
@ -95,12 +58,88 @@ SYMBOL: failures
|
||||||
failures get
|
failures get
|
||||||
] with-compiler-errors ;
|
] with-compiler-errors ;
|
||||||
|
|
||||||
: do-refresh ( modified-sources modified-docs -- )
|
: source-modified? ( path -- ? )
|
||||||
|
dup source-files get at [
|
||||||
|
dup source-file-path
|
||||||
|
dup exists? [
|
||||||
|
utf8 file-lines lines-crc32
|
||||||
|
swap source-file-checksum = not
|
||||||
|
] [
|
||||||
|
2drop f
|
||||||
|
] if
|
||||||
|
] [
|
||||||
|
exists?
|
||||||
|
] ?if ;
|
||||||
|
|
||||||
|
SYMBOL: changed-vocabs
|
||||||
|
|
||||||
|
[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook
|
||||||
|
|
||||||
|
: changed-vocab ( vocab -- )
|
||||||
|
dup vocab changed-vocabs get and
|
||||||
|
[ dup changed-vocabs get set-at ] [ drop ] if ;
|
||||||
|
|
||||||
|
: unchanged-vocab ( vocab -- )
|
||||||
|
changed-vocabs get delete-at ;
|
||||||
|
|
||||||
|
: unchanged-vocabs ( vocabs -- )
|
||||||
|
[ unchanged-vocab ] each ;
|
||||||
|
|
||||||
|
: changed-vocab? ( vocab -- ? )
|
||||||
|
changed-vocabs get dup [ key? ] [ 2drop t ] if ;
|
||||||
|
|
||||||
|
: filter-changed ( vocabs -- vocabs' )
|
||||||
|
[ changed-vocab? ] subset ;
|
||||||
|
|
||||||
|
SYMBOL: modified-sources
|
||||||
|
SYMBOL: modified-docs
|
||||||
|
|
||||||
|
: (to-refresh) ( vocab variable loaded? path -- )
|
||||||
|
dup [
|
||||||
|
swap [
|
||||||
|
pick changed-vocab? [
|
||||||
|
source-modified? [ get push ] [ 2drop ] if
|
||||||
|
] [ 3drop ] if
|
||||||
|
] [ drop get push ] if
|
||||||
|
] [ 2drop 2drop ] if ;
|
||||||
|
|
||||||
|
: to-refresh ( prefix -- modified-sources modified-docs unchanged )
|
||||||
|
[
|
||||||
|
V{ } clone modified-sources set
|
||||||
|
V{ } clone modified-docs set
|
||||||
|
|
||||||
|
child-vocabs [
|
||||||
|
[
|
||||||
|
[
|
||||||
|
[ modified-sources ]
|
||||||
|
[ vocab-source-loaded? ]
|
||||||
|
[ vocab-source-path ]
|
||||||
|
tri (to-refresh)
|
||||||
|
] [
|
||||||
|
[ modified-docs ]
|
||||||
|
[ vocab-docs-loaded? ]
|
||||||
|
[ vocab-docs-path ]
|
||||||
|
tri (to-refresh)
|
||||||
|
] bi
|
||||||
|
] each
|
||||||
|
|
||||||
|
modified-sources get
|
||||||
|
modified-docs get
|
||||||
|
]
|
||||||
|
[ modified-sources get modified-docs get append swap seq-diff ] bi
|
||||||
|
] with-scope ;
|
||||||
|
|
||||||
|
: do-refresh ( modified-sources modified-docs unchanged -- )
|
||||||
|
unchanged-vocabs
|
||||||
[
|
[
|
||||||
[ [ f swap set-vocab-source-loaded? ] each ]
|
[ [ f swap set-vocab-source-loaded? ] each ]
|
||||||
[ [ f swap set-vocab-docs-loaded? ] each ] bi*
|
[ [ f swap set-vocab-docs-loaded? ] each ] bi*
|
||||||
]
|
]
|
||||||
[ append prune require-all load-failures. ] 2bi ;
|
[
|
||||||
|
append prune
|
||||||
|
[ unchanged-vocabs ]
|
||||||
|
[ require-all load-failures. ] bi
|
||||||
|
] 2bi ;
|
||||||
|
|
||||||
: refresh ( prefix -- ) to-refresh do-refresh ;
|
: refresh ( prefix -- ) to-refresh do-refresh ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -72,6 +72,7 @@ M: object add-breakpoint ;
|
||||||
{
|
{
|
||||||
{ [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
|
{ [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
|
||||||
{ [ dup standard-generic? ] [ effective-method (step-into-execute) ] }
|
{ [ dup standard-generic? ] [ effective-method (step-into-execute) ] }
|
||||||
|
{ [ dup hook-generic? ] [ effective-method (step-into-execute) ] }
|
||||||
{ [ dup primitive? ] [ execute break ] }
|
{ [ dup primitive? ] [ execute break ] }
|
||||||
[ word-def (step-into-quot) ]
|
[ word-def (step-into-quot) ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
|
||||||
|
|
@ -1,4 +1,27 @@
|
||||||
IN: ui.tools.interactor.tests
|
IN: ui.tools.interactor.tests
|
||||||
USING: ui.tools.interactor tools.test ;
|
USING: ui.tools.interactor ui.gadgets.panes namespaces
|
||||||
|
ui.gadgets.editors concurrency.promises threads listener
|
||||||
|
tools.test kernel calendar ;
|
||||||
|
|
||||||
\ <interactor> must-infer
|
\ <interactor> must-infer
|
||||||
|
|
||||||
|
[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "[ 1 2 3" "interactor" get set-editor-string ] unit-test
|
||||||
|
|
||||||
|
[ ] [ <promise> "promise" set ] unit-test
|
||||||
|
|
||||||
|
[
|
||||||
|
"interactor" get stream-read-quot "promise" get fulfill
|
||||||
|
] "Interactor test" spawn drop
|
||||||
|
|
||||||
|
! This should not throw an exception
|
||||||
|
[ ] [ "interactor" get evaluate-input ] unit-test
|
||||||
|
|
||||||
|
[ ] [ [ "interactor" get interactor-busy? ] [ yield ] [ ] while ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "[ 1 2 3 ]" "interactor" get set-editor-string ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "interactor" get evaluate-input ] unit-test
|
||||||
|
|
||||||
|
[ [ [ 1 2 3 ] ] ] [ "promise" get 5 seconds ?promise-timeout ] unit-test
|
||||||
|
|
|
||||||
|
|
@ -138,7 +138,9 @@ M: interactor stream-read-partial
|
||||||
drop parse-lines-interactive
|
drop parse-lines-interactive
|
||||||
] [
|
] [
|
||||||
2nip
|
2nip
|
||||||
dup delegate unexpected-eof? [ drop f ] when
|
dup parse-error? [
|
||||||
|
dup error>> unexpected-eof? [ drop f ] when
|
||||||
|
] when
|
||||||
] recover ;
|
] recover ;
|
||||||
|
|
||||||
: handle-interactive ( lines interactor -- quot/f ? )
|
: handle-interactive ( lines interactor -- quot/f ? )
|
||||||
|
|
|
||||||
|
|
@ -7,7 +7,7 @@ vectors words windows.kernel32 windows.gdi32 windows.user32
|
||||||
windows.opengl32 windows.messages windows.types windows.nt
|
windows.opengl32 windows.messages windows.types windows.nt
|
||||||
windows threads libc combinators continuations command-line
|
windows threads libc combinators continuations command-line
|
||||||
shuffle opengl ui.render unicode.case ascii math.bitfields
|
shuffle opengl ui.render unicode.case ascii math.bitfields
|
||||||
locals symbols ;
|
locals symbols accessors ;
|
||||||
IN: ui.windows
|
IN: ui.windows
|
||||||
|
|
||||||
SINGLETON: windows-ui-backend
|
SINGLETON: windows-ui-backend
|
||||||
|
|
@ -203,8 +203,18 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ;
|
||||||
wParam keystroke>gesture <key-up>
|
wParam keystroke>gesture <key-up>
|
||||||
hWnd window-focus send-gesture drop ;
|
hWnd window-focus send-gesture drop ;
|
||||||
|
|
||||||
|
: set-window-active ( hwnd uMsg wParam lParam ? -- n )
|
||||||
|
>r 4dup r> 2nip nip
|
||||||
|
swap window set-world-active? DefWindowProc ;
|
||||||
|
|
||||||
: handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
|
: handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
|
||||||
dup alpha? [ 4drop 0 ] [ DefWindowProc ] if ;
|
{
|
||||||
|
{ [ over SC_MINIMIZE = ] [ f set-window-active ] }
|
||||||
|
{ [ over SC_RESTORE = ] [ t set-window-active ] }
|
||||||
|
{ [ over SC_MAXIMIZE = ] [ t set-window-active ] }
|
||||||
|
{ [ dup alpha? ] [ 4drop 0 ] }
|
||||||
|
{ [ t ] [ DefWindowProc ] }
|
||||||
|
} cond ;
|
||||||
|
|
||||||
: cleanup-window ( handle -- )
|
: cleanup-window ( handle -- )
|
||||||
dup win-title [ free ] when*
|
dup win-title [ free ] when*
|
||||||
|
|
|
||||||
|
|
@ -61,6 +61,133 @@ LIBRARY: advapi32
|
||||||
: CRYPT_MACHINE_KEYSET HEX: 20 ; inline
|
: CRYPT_MACHINE_KEYSET HEX: 20 ; inline
|
||||||
: CRYPT_SILENT HEX: 40 ; inline
|
: CRYPT_SILENT HEX: 40 ; inline
|
||||||
|
|
||||||
|
C-STRUCT: ACL
|
||||||
|
{ "BYTE" "AclRevision" }
|
||||||
|
{ "BYTE" "Sbz1" }
|
||||||
|
{ "WORD" "AclSize" }
|
||||||
|
{ "WORD" "AceCount" }
|
||||||
|
{ "WORD" "Sbz2" } ;
|
||||||
|
|
||||||
|
TYPEDEF: ACL* PACL
|
||||||
|
|
||||||
|
: ACCESS_ALLOWED_ACE_TYPE 0 ; inline
|
||||||
|
: ACCESS_DENIED_ACE_TYPE 1 ; inline
|
||||||
|
: SYSTEM_AUDIT_ACE_TYPE 2 ; inline
|
||||||
|
: SYSTEM_ALARM_ACE_TYPE 3 ; inline
|
||||||
|
|
||||||
|
: OBJECT_INHERIT_ACE HEX: 1 ; inline
|
||||||
|
: CONTAINER_INHERIT_ACE HEX: 2 ; inline
|
||||||
|
: NO_PROPAGATE_INHERIT_ACE HEX: 4 ; inline
|
||||||
|
: INHERIT_ONLY_ACE HEX: 8 ; inline
|
||||||
|
: VALID_INHERIT_FLAGS HEX: f ; inline
|
||||||
|
|
||||||
|
C-STRUCT: ACE_HEADER
|
||||||
|
{ "BYTE" "AceType" }
|
||||||
|
{ "BYTE" "AceFlags" }
|
||||||
|
{ "WORD" "AceSize" } ;
|
||||||
|
|
||||||
|
TYPEDEF: ACE_HEADER* PACE_HEADER
|
||||||
|
|
||||||
|
C-STRUCT: ACCESS_ALLOWED_ACE
|
||||||
|
{ "ACE_HEADER" "Header" }
|
||||||
|
{ "DWORD" "Mask" }
|
||||||
|
{ "DWORD" "SidStart" } ;
|
||||||
|
|
||||||
|
TYPEDEF: ACCESS_ALLOWED_ACE* PACCESS_ALLOWED_ACE
|
||||||
|
|
||||||
|
C-STRUCT: ACCESS_DENIED_ACE
|
||||||
|
{ "ACE_HEADER" "Header" }
|
||||||
|
{ "DWORD" "Mask" }
|
||||||
|
{ "DWORD" "SidStart" } ;
|
||||||
|
TYPEDEF: ACCESS_DENIED_ACE* PACCESS_DENIED_ACE
|
||||||
|
|
||||||
|
|
||||||
|
C-STRUCT: SYSTEM_AUDIT_ACE
|
||||||
|
{ "ACE_HEADER" "Header" }
|
||||||
|
{ "DWORD" "Mask" }
|
||||||
|
{ "DWORD" "SidStart" } ;
|
||||||
|
|
||||||
|
TYPEDEF: SYSTEM_AUDIT_ACE* PSYSTEM_AUDIT_ACE
|
||||||
|
|
||||||
|
C-STRUCT: SYSTEM_ALARM_ACE
|
||||||
|
{ "ACE_HEADER" "Header" }
|
||||||
|
{ "DWORD" "Mask" }
|
||||||
|
{ "DWORD" "SidStart" } ;
|
||||||
|
|
||||||
|
TYPEDEF: SYSTEM_ALARM_ACE* PSYSTEM_ALARM_ACE
|
||||||
|
|
||||||
|
C-STRUCT: ACCESS_ALLOWED_CALLBACK_ACE
|
||||||
|
{ "ACE_HEADER" "Header" }
|
||||||
|
{ "DWORD" "Mask" }
|
||||||
|
{ "DWORD" "SidStart" } ;
|
||||||
|
|
||||||
|
TYPEDEF: ACCESS_ALLOWED_CALLBACK_ACE* PACCESS_ALLOWED_CALLBACK_ACE
|
||||||
|
|
||||||
|
|
||||||
|
! typedef enum _TOKEN_INFORMATION_CLASS {
|
||||||
|
: TokenUser 1 ; inline
|
||||||
|
: TokenGroups 2 ; inline
|
||||||
|
: TokenPrivileges 3 ; inline
|
||||||
|
: TokenOwner 4 ; inline
|
||||||
|
: TokenPrimaryGroup 5 ; inline
|
||||||
|
: TokenDefaultDacl 6 ; inline
|
||||||
|
: TokenSource 7 ; inline
|
||||||
|
: TokenType 8 ; inline
|
||||||
|
: TokenImpersonationLevel 9 ; inline
|
||||||
|
: TokenStatistics 10 ; inline
|
||||||
|
: TokenRestrictedSids 11 ; inline
|
||||||
|
: TokenSessionId 12 ; inline
|
||||||
|
: TokenGroupsAndPrivileges 13 ; inline
|
||||||
|
: TokenSessionReference 14 ; inline
|
||||||
|
: TokenSandBoxInert 15 ; inline
|
||||||
|
! } TOKEN_INFORMATION_CLASS;
|
||||||
|
|
||||||
|
: DELETE HEX: 00010000 ; inline
|
||||||
|
: READ_CONTROL HEX: 00020000 ; inline
|
||||||
|
: WRITE_DAC HEX: 00040000 ; inline
|
||||||
|
: WRITE_OWNER HEX: 00080000 ; inline
|
||||||
|
: SYNCHRONIZE HEX: 00100000 ; inline
|
||||||
|
: STANDARD_RIGHTS_REQUIRED HEX: 000f0000 ; inline
|
||||||
|
|
||||||
|
: STANDARD_RIGHTS_READ READ_CONTROL ; inline
|
||||||
|
: STANDARD_RIGHTS_WRITE READ_CONTROL ; inline
|
||||||
|
: STANDARD_RIGHTS_EXECUTE READ_CONTROL ; inline
|
||||||
|
|
||||||
|
: TOKEN_TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline
|
||||||
|
: TOKEN_ADJUST_GROUPS HEX: 0040 ; inline
|
||||||
|
: TOKEN_ADJUST_PRIVILEGES HEX: 0020 ; inline
|
||||||
|
: TOKEN_ADJUST_SESSIONID HEX: 0100 ; inline
|
||||||
|
: TOKEN_ASSIGN_PRIMARY HEX: 0001 ; inline
|
||||||
|
: TOKEN_DUPLICATE HEX: 0002 ; inline
|
||||||
|
: TOKEN_EXECUTE STANDARD_RIGHTS_EXECUTE ; inline
|
||||||
|
: TOKEN_IMPERSONATE HEX: 0004 ; inline
|
||||||
|
: TOKEN_QUERY HEX: 0008 ; inline
|
||||||
|
: TOKEN_QUERY_SOURCE HEX: 0010 ; inline
|
||||||
|
: TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline
|
||||||
|
: TOKEN_READ STANDARD_RIGHTS_READ TOKEN_QUERY bitor ;
|
||||||
|
|
||||||
|
: TOKEN_WRITE
|
||||||
|
{
|
||||||
|
STANDARD_RIGHTS_WRITE
|
||||||
|
TOKEN_ADJUST_PRIVILEGES
|
||||||
|
TOKEN_ADJUST_GROUPS
|
||||||
|
TOKEN_ADJUST_DEFAULT
|
||||||
|
} flags ; foldable
|
||||||
|
|
||||||
|
: TOKEN_ALL_ACCESS
|
||||||
|
{
|
||||||
|
STANDARD_RIGHTS_REQUIRED
|
||||||
|
TOKEN_ASSIGN_PRIMARY
|
||||||
|
TOKEN_DUPLICATE
|
||||||
|
TOKEN_IMPERSONATE
|
||||||
|
TOKEN_QUERY
|
||||||
|
TOKEN_QUERY_SOURCE
|
||||||
|
TOKEN_ADJUST_PRIVILEGES
|
||||||
|
TOKEN_ADJUST_GROUPS
|
||||||
|
TOKEN_ADJUST_SESSIONID
|
||||||
|
TOKEN_ADJUST_DEFAULT
|
||||||
|
} flags ; foldable
|
||||||
|
|
||||||
|
|
||||||
! : I_ScGetCurrentGroupStateW ;
|
! : I_ScGetCurrentGroupStateW ;
|
||||||
! : A_SHAFinal ;
|
! : A_SHAFinal ;
|
||||||
|
|
@ -85,7 +212,7 @@ LIBRARY: advapi32
|
||||||
! : AddAccessDeniedAce ;
|
! : AddAccessDeniedAce ;
|
||||||
! : AddAccessDeniedAceEx ;
|
! : AddAccessDeniedAceEx ;
|
||||||
! : AddAccessDeniedObjectAce ;
|
! : AddAccessDeniedObjectAce ;
|
||||||
! : AddAce ;
|
FUNCTION: BOOL AddAce ( PACL pAcl, DWORD dwAceRevision, DWORD dwStartingAceIndex, LPVOID pAceList, DWORD nAceListLength ) ;
|
||||||
! : AddAuditAccessAce ;
|
! : AddAuditAccessAce ;
|
||||||
! : AddAuditAccessAceEx ;
|
! : AddAuditAccessAceEx ;
|
||||||
! : AddAuditAccessObjectAce ;
|
! : AddAuditAccessObjectAce ;
|
||||||
|
|
@ -382,7 +509,7 @@ FUNCTION: BOOL GetUserNameW ( LPCTSTR lpBuffer, LPDWORD lpnSize ) ;
|
||||||
! : ImpersonateLoggedOnUser ;
|
! : ImpersonateLoggedOnUser ;
|
||||||
! : ImpersonateNamedPipeClient ;
|
! : ImpersonateNamedPipeClient ;
|
||||||
! : ImpersonateSelf ;
|
! : ImpersonateSelf ;
|
||||||
! : InitializeAcl ;
|
FUNCTION: BOOL InitializeAcl ( PACL pAcl, DWORD nAclLength, DWORD dwAclRevision ) ;
|
||||||
! : InitializeSecurityDescriptor ;
|
! : InitializeSecurityDescriptor ;
|
||||||
! : InitializeSid ;
|
! : InitializeSid ;
|
||||||
! : InitiateSystemShutdownA ;
|
! : InitiateSystemShutdownA ;
|
||||||
|
|
@ -508,70 +635,6 @@ FUNCTION: BOOL LookupPrivilegeValueW ( LPCTSTR lpSystemName,
|
||||||
! : OpenEventLogA ;
|
! : OpenEventLogA ;
|
||||||
! : OpenEventLogW ;
|
! : OpenEventLogW ;
|
||||||
|
|
||||||
! typedef enum _TOKEN_INFORMATION_CLASS {
|
|
||||||
: TokenUser 1 ;
|
|
||||||
: TokenGroups 2 ;
|
|
||||||
: TokenPrivileges 3 ;
|
|
||||||
: TokenOwner 4 ;
|
|
||||||
: TokenPrimaryGroup 5 ;
|
|
||||||
: TokenDefaultDacl 6 ;
|
|
||||||
: TokenSource 7 ;
|
|
||||||
: TokenType 8 ;
|
|
||||||
: TokenImpersonationLevel 9 ;
|
|
||||||
: TokenStatistics 10 ;
|
|
||||||
: TokenRestrictedSids 11 ;
|
|
||||||
: TokenSessionId 12 ;
|
|
||||||
: TokenGroupsAndPrivileges 13 ;
|
|
||||||
: TokenSessionReference 14 ;
|
|
||||||
: TokenSandBoxInert 15 ;
|
|
||||||
! } TOKEN_INFORMATION_CLASS;
|
|
||||||
|
|
||||||
: DELETE HEX: 00010000 ; inline
|
|
||||||
: READ_CONTROL HEX: 00020000 ; inline
|
|
||||||
: WRITE_DAC HEX: 00040000 ; inline
|
|
||||||
: WRITE_OWNER HEX: 00080000 ; inline
|
|
||||||
: SYNCHRONIZE HEX: 00100000 ; inline
|
|
||||||
: STANDARD_RIGHTS_REQUIRED HEX: 000f0000 ; inline
|
|
||||||
|
|
||||||
: STANDARD_RIGHTS_READ READ_CONTROL ; inline
|
|
||||||
: STANDARD_RIGHTS_WRITE READ_CONTROL ; inline
|
|
||||||
: STANDARD_RIGHTS_EXECUTE READ_CONTROL ; inline
|
|
||||||
|
|
||||||
: TOKEN_TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline
|
|
||||||
: TOKEN_ADJUST_GROUPS HEX: 0040 ; inline
|
|
||||||
: TOKEN_ADJUST_PRIVILEGES HEX: 0020 ; inline
|
|
||||||
: TOKEN_ADJUST_SESSIONID HEX: 0100 ; inline
|
|
||||||
: TOKEN_ASSIGN_PRIMARY HEX: 0001 ; inline
|
|
||||||
: TOKEN_DUPLICATE HEX: 0002 ; inline
|
|
||||||
: TOKEN_EXECUTE STANDARD_RIGHTS_EXECUTE ; inline
|
|
||||||
: TOKEN_IMPERSONATE HEX: 0004 ; inline
|
|
||||||
: TOKEN_QUERY HEX: 0008 ; inline
|
|
||||||
: TOKEN_QUERY_SOURCE HEX: 0010 ; inline
|
|
||||||
: TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline
|
|
||||||
: TOKEN_READ STANDARD_RIGHTS_READ TOKEN_QUERY bitor ;
|
|
||||||
|
|
||||||
: TOKEN_WRITE
|
|
||||||
{
|
|
||||||
STANDARD_RIGHTS_WRITE
|
|
||||||
TOKEN_ADJUST_PRIVILEGES
|
|
||||||
TOKEN_ADJUST_GROUPS
|
|
||||||
TOKEN_ADJUST_DEFAULT
|
|
||||||
} flags ; foldable
|
|
||||||
|
|
||||||
: TOKEN_ALL_ACCESS
|
|
||||||
{
|
|
||||||
STANDARD_RIGHTS_REQUIRED
|
|
||||||
TOKEN_ASSIGN_PRIMARY
|
|
||||||
TOKEN_DUPLICATE
|
|
||||||
TOKEN_IMPERSONATE
|
|
||||||
TOKEN_QUERY
|
|
||||||
TOKEN_QUERY_SOURCE
|
|
||||||
TOKEN_ADJUST_PRIVILEGES
|
|
||||||
TOKEN_ADJUST_GROUPS
|
|
||||||
TOKEN_ADJUST_SESSIONID
|
|
||||||
TOKEN_ADJUST_DEFAULT
|
|
||||||
} flags ; foldable
|
|
||||||
|
|
||||||
FUNCTION: BOOL OpenProcessToken ( HANDLE ProcessHandle,
|
FUNCTION: BOOL OpenProcessToken ( HANDLE ProcessHandle,
|
||||||
DWORD DesiredAccess,
|
DWORD DesiredAccess,
|
||||||
PHANDLE TokenHandle ) ;
|
PHANDLE TokenHandle ) ;
|
||||||
|
|
|
||||||
|
|
@ -1001,3 +1001,25 @@ windows-messages set-global
|
||||||
: LM_GETIDEALHEIGHT WM_USER HEX: 0301 + ; inline
|
: LM_GETIDEALHEIGHT WM_USER HEX: 0301 + ; inline
|
||||||
: LM_SETITEM WM_USER HEX: 0302 + ; inline
|
: LM_SETITEM WM_USER HEX: 0302 + ; inline
|
||||||
: LM_GETITEM WM_USER HEX: 0303 + ; inline
|
: LM_GETITEM WM_USER HEX: 0303 + ; inline
|
||||||
|
|
||||||
|
|
||||||
|
: WA_INACTIVE 0 ; inline
|
||||||
|
: WA_ACTIVE 1 ; inline
|
||||||
|
: WA_CLICKACTIVE 2 ; inline
|
||||||
|
|
||||||
|
: SC_SIZE HEX: f000 ; inline
|
||||||
|
: SC_MOVE HEX: f010 ; inline
|
||||||
|
: SC_MINIMIZE HEX: f020 ; inline
|
||||||
|
: SC_MAXIMIZE HEX: f030 ; inline
|
||||||
|
: SC_NEXTWINDOW HEX: f040 ; inline
|
||||||
|
: SC_PREVWINDOW HEX: f050 ; inline
|
||||||
|
: SC_CLOSE HEX: f060 ; inline
|
||||||
|
: SC_VSCROLL HEX: f070 ; inline
|
||||||
|
: SC_HSCROLL HEX: f080 ; inline
|
||||||
|
: SC_MOUSEMENU HEX: f090 ; inline
|
||||||
|
: SC_KEYMENU HEX: f100 ; inline
|
||||||
|
: SC_ARRANGE HEX: f110 ; inline
|
||||||
|
: SC_RESTORE HEX: f120 ; inline
|
||||||
|
: SC_TASKLIST HEX: f130 ; inline
|
||||||
|
: SC_SCREENSAVE HEX: f140 ; inline
|
||||||
|
: SC_HOTKEY HEX: f150 ; inline
|
||||||
|
|
|
||||||
|
|
@ -315,7 +315,7 @@ INLINE void* allot_object(CELL type, CELL a)
|
||||||
{
|
{
|
||||||
CELL *object;
|
CELL *object;
|
||||||
|
|
||||||
if(nursery->size - ALLOT_BUFFER_ZONE > a)
|
if(HAVE_NURSERY_P && nursery->size - ALLOT_BUFFER_ZONE > a)
|
||||||
{
|
{
|
||||||
/* If there is insufficient room, collect the nursery */
|
/* If there is insufficient room, collect the nursery */
|
||||||
if(nursery->here + ALLOT_BUFFER_ZONE + a > nursery->end)
|
if(nursery->here + ALLOT_BUFFER_ZONE + a > nursery->end)
|
||||||
|
|
|
||||||
|
|
@ -1,4 +1,12 @@
|
||||||
|
#include <ucontext.h>
|
||||||
|
|
||||||
#define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 1)
|
#define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 1)
|
||||||
|
|
||||||
|
INLINE void *ucontext_stack_pointer(void *uap)
|
||||||
|
{
|
||||||
|
ucontext_t *ucontext = (ucontext_t *)uap;
|
||||||
|
return (void *)ucontext->uc_mcontext.uc_regs->gregs[PT_R1];
|
||||||
|
}
|
||||||
|
|
||||||
#define UAP_PROGRAM_COUNTER(ucontext) \
|
#define UAP_PROGRAM_COUNTER(ucontext) \
|
||||||
(((ucontext_t *)(ucontext))->uc_mcontext.uc_regs->gregs[PT_NIP])
|
(((ucontext_t *)(ucontext))->uc_mcontext.uc_regs->gregs[PT_NIP])
|
||||||
|
|
|
||||||
|
|
@ -16,3 +16,9 @@ DLLEXPORT void c_to_factor_toplevel(CELL quot);
|
||||||
extern char ***_NSGetEnviron(void);
|
extern char ***_NSGetEnviron(void);
|
||||||
#define environ (*_NSGetEnviron())
|
#define environ (*_NSGetEnviron())
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
|
INLINE void *ucontext_stack_pointer(void *uap)
|
||||||
|
{
|
||||||
|
ucontext_t *ucontext = (ucontext_t *)uap;
|
||||||
|
return ucontext->uc_stack.ss_sp;
|
||||||
|
}
|
||||||
|
|
|
||||||
|
|
@ -1,7 +0,0 @@
|
||||||
#include <ucontext.h>
|
|
||||||
|
|
||||||
INLINE void *ucontext_stack_pointer(void *uap)
|
|
||||||
{
|
|
||||||
ucontext_t *ucontext = (ucontext_t *)uap;
|
|
||||||
return ucontext->uc_stack.ss_sp;
|
|
||||||
}
|
|
||||||
10
vm/os-unix.c
10
vm/os-unix.c
|
|
@ -85,6 +85,16 @@ DEFINE_PRIMITIVE(read_dir)
|
||||||
dpush(result);
|
dpush(result);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
DEFINE_PRIMITIVE(os_env)
|
||||||
|
{
|
||||||
|
char *name = unbox_char_string();
|
||||||
|
char *value = getenv(name);
|
||||||
|
if(value == NULL)
|
||||||
|
dpush(F);
|
||||||
|
else
|
||||||
|
box_char_string(value);
|
||||||
|
}
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(os_envs)
|
DEFINE_PRIMITIVE(os_envs)
|
||||||
{
|
{
|
||||||
GROWABLE_ARRAY(result);
|
GROWABLE_ARRAY(result);
|
||||||
|
|
|
||||||
|
|
@ -215,19 +215,34 @@ void sleep_millis(DWORD msec)
|
||||||
Sleep(msec);
|
Sleep(msec);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
DEFINE_PRIMITIVE(os_env)
|
||||||
|
{
|
||||||
|
F_CHAR *key = unbox_u16_string();
|
||||||
|
F_CHAR *value = safe_malloc(MAX_UNICODE_PATH);
|
||||||
|
int ret;
|
||||||
|
ret = GetEnvironmentVariable(key, value, MAX_UNICODE_PATH);
|
||||||
|
if(ret == 0)
|
||||||
|
dpush(F);
|
||||||
|
else
|
||||||
|
dpush(tag_object(from_u16_string(value)));
|
||||||
|
free(value);
|
||||||
|
}
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(set_os_env)
|
DEFINE_PRIMITIVE(set_os_env)
|
||||||
{
|
{
|
||||||
F_CHAR *key = unbox_u16_string();
|
F_CHAR *key = unbox_u16_string();
|
||||||
REGISTER_C_STRING(key);
|
REGISTER_C_STRING(key);
|
||||||
F_CHAR *value = unbox_u16_string();
|
F_CHAR *value = unbox_u16_string();
|
||||||
UNREGISTER_C_STRING(key);
|
UNREGISTER_C_STRING(key);
|
||||||
SetEnvironmentVariable(key, value);
|
if(!SetEnvironmentVariable(key, value))
|
||||||
|
general_error(ERROR_IO, tag_object(get_error_message()), F, NULL);
|
||||||
}
|
}
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(unset_os_env)
|
DEFINE_PRIMITIVE(unset_os_env)
|
||||||
{
|
{
|
||||||
F_CHAR *key = unbox_u16_string();
|
if(!SetEnvironmentVariable(unbox_u16_string(), NULL)
|
||||||
SetEnvironmentVariable(key, NULL);
|
&& GetLastError() != ERROR_ENVVAR_NOT_FOUND)
|
||||||
|
general_error(ERROR_IO, tag_object(get_error_message()), F, NULL);
|
||||||
}
|
}
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(set_os_envs)
|
DEFINE_PRIMITIVE(set_os_envs)
|
||||||
|
|
|
||||||
|
|
@ -27,7 +27,6 @@
|
||||||
#include "os-unix.h"
|
#include "os-unix.h"
|
||||||
|
|
||||||
#ifdef __APPLE__
|
#ifdef __APPLE__
|
||||||
#include "os-unix-ucontext.h"
|
|
||||||
#include "os-macosx.h"
|
#include "os-macosx.h"
|
||||||
#include "mach_signal.h"
|
#include "mach_signal.h"
|
||||||
|
|
||||||
|
|
@ -84,7 +83,6 @@
|
||||||
#if defined(FACTOR_X86)
|
#if defined(FACTOR_X86)
|
||||||
#include "os-linux-x86.32.h"
|
#include "os-linux-x86.32.h"
|
||||||
#elif defined(FACTOR_PPC)
|
#elif defined(FACTOR_PPC)
|
||||||
#include "os-unix-ucontext.h"
|
|
||||||
#include "os-linux-ppc.h"
|
#include "os-linux-ppc.h"
|
||||||
#elif defined(FACTOR_ARM)
|
#elif defined(FACTOR_ARM)
|
||||||
#include "os-linux-arm.h"
|
#include "os-linux-arm.h"
|
||||||
|
|
|
||||||
10
vm/run.c
10
vm/run.c
|
|
@ -280,16 +280,6 @@ DEFINE_PRIMITIVE(exit)
|
||||||
exit(to_fixnum(dpop()));
|
exit(to_fixnum(dpop()));
|
||||||
}
|
}
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(os_env)
|
|
||||||
{
|
|
||||||
char *name = unbox_char_string();
|
|
||||||
char *value = getenv(name);
|
|
||||||
if(value == NULL)
|
|
||||||
dpush(F);
|
|
||||||
else
|
|
||||||
box_char_string(value);
|
|
||||||
}
|
|
||||||
|
|
||||||
DEFINE_PRIMITIVE(eq)
|
DEFINE_PRIMITIVE(eq)
|
||||||
{
|
{
|
||||||
CELL lhs = dpop();
|
CELL lhs = dpop();
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue