+++ /dev/null
-USING: help.markup help.syntax calendar quotations system ;\r
-IN: alarms\r
-\r
-HELP: alarm\r
-{ $class-description "An alarm. Can be passed to " { $link stop-alarm } "." } ;\r
-\r
-HELP: start-alarm\r
-{ $values { "alarm" alarm } }\r
-{ $description "Starts an alarm." } ;\r
-\r
-HELP: restart-alarm\r
-{ $values { "alarm" alarm } }\r
-{ $description "Starts or restarts an alarm. Restarting an alarm causes the a sleep of initial delay nanoseconds before looping. An alarm's parameters may be modified and restarted with this word." } ;\r
-\r
-HELP: stop-alarm\r
-{ $values { "alarm" alarm } }\r
-{ $description "Prevents an alarm from calling its quotation again. Has no effect on alarms that are not currently running." } ;\r
-\r
-HELP: every\r
-{ $values\r
- { "quot" quotation } { "interval-duration" duration }\r
- { "alarm" alarm } }\r
-{ $description "Creates an alarm that calls the quotation repeatedly, using " { $snippet "duration" } " as the frequency. The first call of " { $snippet "quot" } " will happen immediately. If the quotation throws an exception, the alarm will stop." }\r
-{ $examples\r
- { $unchecked-example\r
- "USING: alarms io calendar ;"\r
- """[ "Hi Buddy." print flush ] 10 seconds every drop"""\r
- ""\r
- }\r
-} ;\r
-\r
-HELP: later\r
-{ $values { "quot" quotation } { "delay-duration" duration } { "alarm" alarm } }\r
-{ $description "Sleeps for " { $snippet "duration" } " and then calls a " { $snippet "quot" } ". The user may cancel the alarm before " { $snippet "quot" } " runs. This alarm is not repeated." }\r
-{ $examples\r
- { $unchecked-example\r
- "USING: alarms io calendar ;"\r
- """[ "Break's over!" print flush ] 15 minutes later drop"""\r
- ""\r
- }\r
-} ;\r
-\r
-HELP: delayed-every\r
-{ $values\r
- { "quot" quotation } { "duration" duration }\r
- { "alarm" alarm } }\r
-{ $description "Creates an alarm that calls " { $snippet "quot" } " repeatedly, waiting " { $snippet "duration" } " before calling " { $snippet "quot" } " the first time and then waiting " { $snippet "duration" } " between further calls. If the quotation throws an exception, the alarm will stop." }\r
-{ $examples\r
- { $unchecked-example\r
- "USING: alarms io calendar ;"\r
- """[ "Hi Buddy." print flush ] 10 seconds every drop"""\r
- ""\r
- }\r
-} ;\r
-\r
-ARTICLE: "alarms" "Alarms"\r
-"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks. Alarms run in a single green thread per alarm and consist of a quotation, a delay duration, and an interval duration. After starting an alarm, the alarm thread sleeps for the delay duration and calls the quotation. Then it waits out the interval duration and calls the quotation again until something stops the alarm. If a recurring alarm's quotation would be scheduled to run again before the previous quotation has finished processing, the alarm will be run again immediately afterwards. This may result in the alarm falling behind indefinitely, in which case the it will run as often as possible while still allowing other green threads to run. Recurring alarms that execute 'on time' or 'catch up' will always be scheduled for an exact multiple of the interval from the original starting time to prevent the alarm from drifting over time. Alarms use " { $link nano-count } " as the timing primitive, so they will continue to work across system clock changes." $nl\r
-"The alarm class:"\r
-{ $subsections alarm }\r
-"Create an alarm before starting it:"\r
-{ $subsections <alarm> }\r
-"Starting an alarm:"\r
-{ $subsections start-alarm restart-alarm }\r
-"Stopping an alarm:"\r
-{ $subsections stop-alarm }\r
-\r
-"A recurring alarm without an initial delay:"\r
-{ $subsections every }\r
-"A one-time alarm with an initial delay:"\r
-{ $subsections later }\r
-"A recurring alarm with an initial delay:"\r
-{ $subsections delayed-every } ;\r
-\r
-ABOUT: "alarms"\r
+++ /dev/null
-USING: alarms alarms.private calendar concurrency.count-downs\r
-concurrency.promises fry kernel math math.order sequences\r
-threads tools.test tools.time ;\r
-IN: alarms.tests\r
-\r
-[ ] [\r
- 1 <count-down>\r
- { f } clone 2dup\r
- [ first stop-alarm count-down ] 2curry 1 seconds later\r
- swap set-first\r
- await\r
-] unit-test\r
-\r
-[ ] [\r
- self [ resume ] curry instant later drop\r
- "test" suspend drop\r
-] unit-test\r
-\r
-[ t ] [\r
- [\r
- <promise>\r
- [ '[ t _ fulfill ] 2 seconds later drop ]\r
- [ 5 seconds ?promise-timeout drop ] bi\r
- ] benchmark 1,500,000,000 2,500,000,000 between?\r
-] unit-test\r
-\r
-[ { 3 } ] [\r
- { 3 } dup\r
- '[ 4 _ set-first ] 2 seconds later\r
- 1/2 seconds sleep\r
- stop-alarm\r
-] unit-test\r
-\r
-[ { 1 } ] [\r
- { 0 }\r
- dup '[ 0 _ [ 1 + ] change-nth ] 3 seconds later\r
- [ stop-alarm ] [ start-alarm ] bi\r
- 4 seconds sleep\r
-] unit-test\r
-\r
-[ { 0 } ] [\r
- { 0 }\r
- dup '[ 3 seconds sleep 1 _ set-first ] 1 seconds later\r
- 2 seconds sleep stop-alarm\r
- 1/2 seconds sleep\r
-] unit-test\r
-\r
-[ { 0 } ] [\r
- { 0 }\r
- dup '[ 1 _ set-first ] 300 milliseconds later\r
- 150 milliseconds sleep\r
- [ restart-alarm ] [ 200 milliseconds sleep stop-alarm ] bi\r
-] unit-test\r
-\r
-[ { 1 } ] [\r
- { 0 }\r
- dup '[ 0 _ [ 1 + ] change-nth ] 200 milliseconds later\r
- 100 milliseconds sleep restart-alarm 300 milliseconds sleep\r
-] unit-test\r
-\r
-[ { 4 } ] [\r
- { 0 }\r
- dup '[ 0 _ [ 1 + ] change-nth ] 300 milliseconds 300 milliseconds\r
- <alarm> dup start-alarm\r
- 700 milliseconds sleep dup restart-alarm\r
- 700 milliseconds sleep stop-alarm 500 milliseconds sleep\r
-] unit-test\r
-! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
+! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs calendar combinators.short-circuit fry
-heaps init kernel math math.functions math.parser namespaces
-quotations sequences system threads ;
+USING: ;
IN: alarms
-TUPLE: alarm
- { quot callable initial: [ ] }
- start-nanos
- delay-nanos
- interval-nanos
- iteration-start-nanos
- quotation-running?
- restart?
- thread ;
-
-<PRIVATE
-
-GENERIC: >nanoseconds ( obj -- duration/f )
-M: f >nanoseconds ;
-M: real >nanoseconds >integer ;
-M: duration >nanoseconds duration>nanoseconds >integer ;
-
-: set-next-alarm-time ( alarm -- alarm )
- ! start + delay + ceiling((now - (start + delay)) / interval) * interval
- nano-count
- over start-nanos>> -
- over delay-nanos>> [ - ] when*
- over interval-nanos>> / ceiling
- over interval-nanos>> *
- over start-nanos>> +
- over delay-nanos>> [ + ] when*
- >>iteration-start-nanos ;
-
-: stop-alarm? ( alarm -- ? )
- { [ thread>> self eq? not ] [ restart?>> ] } 1|| ;
-
-DEFER: call-alarm-loop
-
-: loop-alarm ( alarm -- )
- nano-count over
- [ iteration-start-nanos>> - ] [ interval-nanos>> ] bi <
- [ set-next-alarm-time ] dip
- [ dup iteration-start-nanos>> ] [ 0 ] if
- 0 or sleep-until call-alarm-loop ;
-
-: maybe-loop-alarm ( alarm -- )
- dup { [ stop-alarm? ] [ interval-nanos>> not ] } 1||
- [ drop ] [ loop-alarm ] if ;
-
-: call-alarm-loop ( alarm -- )
- dup stop-alarm? [
- drop
- ] [
- [
- [ t >>quotation-running? drop ]
- [ quot>> call( -- ) ]
- [ f >>quotation-running? drop ] tri
- ] keep
- maybe-loop-alarm
- ] if ;
-
-: sleep-delay ( alarm -- )
- dup stop-alarm? [
- drop
- ] [
- nano-count >>start-nanos
- delay-nanos>> [ sleep ] when*
- ] if ;
-
-: alarm-loop ( alarm -- )
- [ sleep-delay ]
- [ nano-count >>iteration-start-nanos call-alarm-loop ]
- [ dup restart?>> [ f >>restart? alarm-loop ] [ drop ] if ] tri ;
-
-PRIVATE>
-
-: <alarm> ( quot delay-duration/f interval-duration/f -- alarm )
- alarm new
- swap >nanoseconds >>interval-nanos
- swap >nanoseconds >>delay-nanos
- swap >>quot ; inline
-
-: start-alarm ( alarm -- )
- [
- '[ _ alarm-loop ] "Alarm execution" spawn
- ] keep thread<< ;
-
-: stop-alarm ( alarm -- )
- dup quotation-running?>> [
- f >>thread drop
- ] [
- [ [ interrupt ] when* f ] change-thread drop
- ] if ;
-
-: restart-alarm ( alarm -- )
- t >>restart?
- dup quotation-running?>> [
- drop
- ] [
- dup thread>> [ nip interrupt ] [ start-alarm ] if*
- ] if ;
-
-<PRIVATE
-
-: (start-alarm) ( quot start-duration interval-duration -- alarm )
- <alarm> [ start-alarm ] keep ;
-
-PRIVATE>
-
-: every ( quot interval-duration -- alarm )
- [ f ] dip (start-alarm) ;
-
-: later ( quot delay-duration -- alarm )
- f (start-alarm) ;
-
-: delayed-every ( quot duration -- alarm )
- dup (start-alarm) ;
+++ /dev/null
-One-time and recurring events
[ +gt+ ] [ 2005 1 1 12 30 0 instant <timestamp>
2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test
-[ t ] [ now timestamp>micros system-micros - 1000000 < ] unit-test
[ t ] [ 0 micros>timestamp unix-1970 = ] unit-test
[ t ] [ 123456789000000 [ micros>timestamp timestamp>micros ] keep = ] unit-test
[ t ] [ 123456789123456000 [ micros>timestamp timestamp>micros ] keep = ] unit-test
HOOK: gmt-offset os ( -- hours minutes seconds )
+HOOK: gmt os ( -- timestamp )
+
TUPLE: duration
{ year real }
{ month real }
: timestamp>micros ( timestamp -- n )
unix-1970 (time-) 1000000 * >integer ;
-: gmt ( -- timestamp )
- #! GMT time, right now
- unix-1970 system-micros microseconds time+ ;
-
: now ( -- timestamp ) gmt >local-time ;
: hence ( duration -- timestamp ) now swap time+ ;
: ago ( duration -- timestamp ) now swap time- ;
accessors classes.struct ;
IN: calendar.unix
-: timeval>seconds ( timeval -- seconds )
+: timeval>duration ( timeval -- duration )
[ sec>> seconds ] [ usec>> microseconds ] bi time+ ;
: timeval>unix-time ( timeval -- timestamp )
- timeval>seconds since-1970 ;
+ timeval>duration since-1970 ;
: timespec>seconds ( timespec -- seconds )
[ sec>> seconds ] [ nsec>> nanoseconds ] bi time+ ;
M: unix gmt-offset ( -- hours minutes seconds )
get-time gmtoff>> 3600 /mod 60 /mod ;
+
+: current-timeval ( -- timeval )
+ timeval <struct> f [ gettimeofday io-error ] 2keep drop ;
+
+: system-micros ( -- n )
+ current-timeval
+ [ sec>> 1,000,000 * ] [ usec>> ] bi + ;
+
+M: unix gmt
+ current-timeval timeval>unix-time ;
USING: calendar namespaces alien.c-types system
windows.kernel32 kernel math combinators windows.errors
-accessors classes.struct ;
+accessors classes.struct calendar.format math.functions ;
IN: calendar.windows
+: timestamp>SYSTEMTIME ( timestamp -- SYSTEMTIME )
+ {
+ [ year>> ]
+ [ month>> ]
+ [ day-of-week ]
+ [ day>> ]
+ [ hour>> ]
+ [ minute>> ]
+ [
+ second>> dup floor
+ [ nip >integer ]
+ [ - 1000 * >integer ] 2bi
+ ]
+ } cleave \ SYSTEMTIME <struct-boa> ;
+
+: SYSTEMTIME>timestamp ( SYSTEMTIME -- timestamp )
+ {
+ [ wYear>> ]
+ [ wMonth>> ]
+ [ wDay>> ]
+ [ wHour>> ]
+ [ wMinute>> ]
+ [ [ wSecond>> ] [ wMilliseconds>> 1000 / ] bi + ]
+ } cleave instant <timestamp> ;
+
M: windows gmt-offset ( -- hours minutes seconds )
TIME_ZONE_INFORMATION <struct>
dup GetTimeZoneInformation {
{ TIME_ZONE_ID_STANDARD [ Bias>> ] }
{ TIME_ZONE_ID_DAYLIGHT [ [ Bias>> ] [ DaylightBias>> ] bi + ] }
} case neg 60 /mod 0 ;
+
+M: windows gmt
+ SYSTEMTIME <struct> [ GetSystemTime ] keep SYSTEMTIME>timestamp ;
7 >>a
8 >>b
] unit-test
-
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel quotations math sequences
-stack-checker ;
+USING: classes.tuple help.markup help.syntax kernel math
+quotations sequences stack-checker ;
IN: combinators.smart
HELP: input<sequence
{ drop-outputs keep-inputs } related-words
+HELP: dropping
+{ $values
+ { "quot" quotation }
+ { "quot" quotation }
+}
+{ $description "Outputs a quotation that, when called, will have the effect of dropping the number of inputs to the original quotation." }
+{ $examples
+ { $example
+ """USING: combinators.smart math prettyprint ;
+[ + + ] dropping ."""
+"""[ 3 ndrop ]"""
+ }
+} ;
+
+HELP: input<sequence-unsafe
+{ $values
+ { "quot" quotation }
+ { "quot" quotation }
+}
+{ $description "An unsafe version of " { $link input<sequence-unsafe } "." } ;
+
+HELP: map-reduce-outputs
+{ $values
+ { "quot" quotation } { "mapper" quotation } { "reducer" quotation }
+ { "quot" quotation }
+}
+{ $description "Infers the number of outputs from " { $snippet "quot" } " and, treating those outputs as a sequence, calls " { $link map-reduce } " on them." }
+{ $examples
+ { $example
+"""USING: math combinators.smart prettyprint ;
+[ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ."""
+"14"
+ }
+} ;
+
+HELP: nullary
+{ $values
+ { "quot" quotation }
+ { "quot" quotation }
+}
+{ $description "Infers the number of inputs to a quotation and drops them from the stack." }
+{ $examples
+ { $example
+ """USING: combinators.smart kernel math ;
+1 2 [ + ] nullary"""
+""
+ }
+} ;
+
+HELP: preserving
+{ $values
+ { "quot" quotation }
+ { "quot" quotation }
+}
+{ $description "Calls a quotation and leaves any consumed inputs on the stack beneath the quotation's outputs." }
+{ $examples
+ { $example
+ """USING: combinators.smart kernel math prettyprint ;
+1 2 [ + ] preserving [ . ] tri@"""
+"""1
+2
+3"""
+ }
+} ;
+
+HELP: smart-apply
+{ $values
+ { "quot" quotation } { "n" integer }
+ { "quot" quotation }
+}
+{ $description "Applies a quotation to the datastack " { $snippet "n" } " times, starting lower on the stack and working up in increments of the number of inferred inputs to the quotation." }
+{ $examples
+ { $example
+ """USING: combinators.smart prettyprint math kernel ;
+1 2 3 4 [ + ] 2 smart-apply [ . ] bi@"""
+"""3
+7"""
+ }
+} ;
+
+HELP: smart-if
+{ $values
+ { "pred" quotation } { "true" quotation } { "false" quotation }
+ { "quot" quotation }
+}
+{ $description "A version of " { $link if } " that takes three quotations, where the first quotation is a predicate that preserves any inputs it consumes." } ;
+
+HELP: smart-if*
+{ $values
+ { "pred" quotation } { "true" quotation } { "false" quotation }
+ { "quot" quotation }
+}
+{ $description "A version of " { $link if } " that takes three quotations, where the first quotation is a predicate that preserves any inputs it consumes, the second is the " { $snippet "true" } " branch, and the third is the " { $snippet "false" } " branch. If the " { $snippet "true" } " branch is taken, the values are left on the stack and the quotation is called. If the " { $snippet "false" } " branch is taken, the number of inputs inferred from predicate quotation is dropped and the quotation is called." } ;
+
+HELP: smart-unless
+{ $values
+ { "pred" quotation } { "false" quotation }
+ { "quot" quotation }
+}
+{ $description "A version of " { $link unless } " that takes two quotations, where the first quotation is a predicate that preserves any inputs it consumes and the second is the " { $snippet "false" } " branch." } ;
+
+HELP: smart-unless*
+{ $values
+ { "pred" quotation } { "false" quotation }
+ { "quot" quotation }
+}
+{ $description "A version of " { $link unless } " that takes two quotations, where the first quotation is a predicate that preserves any inputs it consumes and the second is the " { $snippet "false" } " branch. If the " { $snippet "true" } " branch is taken, the values are left on the stack. If the " { $snippet "false" } " branch is taken, the number of inputs inferred from predicate quotation is dropped and the quotation is called." } ;
+
+HELP: smart-when
+{ $values
+ { "pred" quotation } { "true" quotation }
+ { "quot" quotation }
+}
+{ $description "A version of " { $link when } " that takes two quotations, where the first quotation is a predicate that preserves any inputs it consumes and the second is the " { $snippet "true" } " branch." } ;
+
+HELP: smart-when*
+{ $values
+ { "pred" quotation } { "true" quotation }
+ { "quot" quotation }
+}
+{ $description "A version of " { $link when } " that takes two quotations, where the first quotation is a predicate that preserves any inputs it consumes and the second is the " { $snippet "true" } " branch. If the " { $snippet "true" } " branch is taken, the values are left on the stack and the quotation is called. If the " { $snippet "false" } " branch is taken, the number of inputs inferred from predicate quotation is dropped." } ;
+
ARTICLE: "combinators.smart" "Smart combinators"
"A " { $emphasis "smart combinator" } " is a macro which reflects on the stack effect of an input quotation. The " { $vocab-link "combinators.smart" } " vocabulary implements a few simple smart combinators which look at the static stack effects of input quotations and generate code which produces or consumes the relevant number of stack values." $nl
-"Call a quotation and discard all output values or preserve all input values:"
+"Take all input values from a sequence:"
{ $subsections
- drop-outputs
- keep-inputs
+ input<sequence
+ input<sequence-unsafe
}
-"Take all input values from a sequence:"
-{ $subsections input<sequence }
"Store all output values to a sequence:"
{ $subsections
output>sequence
output>array
}
"Reducing the set of output values:"
-{ $subsections reduce-outputs }
+{ $subsections
+ reduce-outputs
+ map-reduce-outputs
+}
+"Applying a quotation to groups of elements on the stack:"
+{ $subsections smart-apply }
"Summing output values:"
{ $subsections sum-outputs }
"Concatenating output values:"
append-outputs
append-outputs-as
}
+"Drop the outputs after calling a quotation:"
+{ $subsections drop-outputs }
+"Cause a quotation to act as a no-op and drop the inputs:"
+{ $subsection nullary }
+"Preserve the inputs below or above the outputs of the quotation:"
+{ $subsections preserving keep-inputs }
+"Versions of if that infer how many inputs to keep from the predicate quotation:"
+{ $subsections smart-if smart-when smart-unless }
+"Versions of if* that infer how many inputs to keep from the predicate quotation:"
+{ $subsections smart-if* smart-when* smart-unless* }
"New smart combinators can be created by defining " { $link "macros" } " which call " { $link infer } "." ;
ABOUT: "combinators.smart"
MACRO: preserving ( quot -- )
[ inputs ] keep '[ _ ndup @ ] ;
-MACRO: nullary ( quot -- quot' )
- dup outputs '[ @ _ ndrop ] ;
-
MACRO: dropping ( quot -- quot' )
inputs '[ [ _ ndrop ] ] ;
-MACRO: balancing ( quot -- quot' )
- '[ _ [ preserving ] [ dropping ] bi ] ;
+MACRO: nullary ( quot -- quot' ) dropping ;
MACRO: smart-if ( pred true false -- quot )
'[ _ preserving _ _ if ] ;
'[ _ [ ] _ smart-if ] ;
MACRO: smart-if* ( pred true false -- quot )
- '[ _ balancing _ swap _ compose if ] ;
+ '[ _ [ preserving ] [ dropping ] bi _ swap _ compose if ] ;
MACRO: smart-when* ( pred true -- quot )
'[ _ _ [ ] smart-if* ] ;
T{ ##compare f 6 5 1 cc= }
} test-alias-analysis
] unit-test
+
+! We can't make any assumptions about heap-ac between alien
+! calls, since they might callback into Factor code
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f "free" }
+ T{ ##slot-imm f 2 0 1 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f "free" }
+ T{ ##slot-imm f 2 0 1 0 }
+ } test-alias-analysis
+] unit-test
+
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f "free" }
+ T{ ##slot-imm f 2 0 1 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f "free" }
+ T{ ##slot-imm f 2 0 1 0 }
+ } test-alias-analysis
+] unit-test
+
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f "free" }
+ T{ ##set-slot-imm f 2 0 1 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f "free" }
+ T{ ##set-slot-imm f 2 0 1 0 }
+ } test-alias-analysis
+] unit-test
+
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f "free" }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f "free" }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ } test-alias-analysis
+] unit-test
slot# vreg kill-constant-set-slot
] [ vreg kill-computed-set-slot ] if ;
+: init-alias-analysis ( -- )
+ H{ } clone vregs>acs set
+ H{ } clone acs>vregs set
+ H{ } clone live-slots set
+ H{ } clone copies set
+ H{ } clone recent-stores set
+ HS{ } clone dead-stores set
+ 0 ac-counter set ;
+
GENERIC: insn-slot# ( insn -- slot#/f )
GENERIC: insn-object ( insn -- vreg )
analyze-aliases
] when ;
-GENERIC: eliminate-dead-stores ( insn -- ? )
-
-M: ##set-slot-imm eliminate-dead-stores
- insn#>> dead-stores get in? not ;
-
-M: insn eliminate-dead-stores drop t ;
-
-: init-alias-analysis ( -- )
- H{ } clone vregs>acs set
- H{ } clone acs>vregs set
- H{ } clone live-slots set
- H{ } clone copies set
- H{ } clone recent-stores set
- HS{ } clone dead-stores set
- 0 ac-counter set ;
-
: reset-alias-analysis ( -- )
recent-stores get clear-assoc
vregs>acs get clear-assoc
\ ##vm-field set-new-ac
\ ##alien-global set-new-ac ;
+M: factor-call-insn analyze-aliases
+ heap-ac get ac>vregs [
+ [ live-slots get at clear-assoc ]
+ [ recent-stores get at clear-assoc ] bi
+ ] each ;
+
+GENERIC: eliminate-dead-stores ( insn -- ? )
+
+M: ##set-slot-imm eliminate-dead-stores
+ insn#>> dead-stores get in? not ;
+
+M: insn eliminate-dead-stores drop t ;
+
: alias-analysis-step ( insns -- insns' )
reset-alias-analysis
[ local-live-in [ set-heap-ac ] each ]
! Copyright (C) 2009, 2010 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.short-circuit kernel
-math math.order sequences assocs namespaces vectors fry arrays
-splitting compiler.cfg.def-use compiler.cfg compiler.cfg.rpo
-compiler.cfg.predecessors compiler.cfg.renaming
+locals math math.order sequences assocs namespaces vectors fry
+arrays splitting compiler.cfg.def-use compiler.cfg
+compiler.cfg.rpo compiler.cfg.predecessors compiler.cfg.renaming
compiler.cfg.instructions compiler.cfg.utilities ;
IN: compiler.cfg.branch-splitting
1vector >>predecessors
] with map ;
-: update-predecessor-successor ( pred copy old-bb -- )
- '[
- [ _ _ 3dup nip eq? [ drop nip ] [ 2drop ] if ] map
- ] change-successors drop ;
-
: update-predecessor-successors ( copies old-bb -- )
[ predecessors>> swap ] keep
- '[ _ update-predecessor-successor ] 2each ;
+ '[ [ _ ] 2dip update-predecessors ] 2each ;
-: update-successor-predecessor ( copies old-bb succ -- )
- [
- swap 1array split swap join V{ } like
- ] change-predecessors drop ;
+:: update-successor-predecessor ( copies old-bb succ -- )
+ succ
+ [ { old-bb } split copies join V{ } like ] change-predecessors
+ drop ;
: update-successor-predecessors ( copies old-bb -- )
- dup successors>> [
- update-successor-predecessor
- ] with with each ;
+ dup successors>>
+ [ update-successor-predecessor ] with with each ;
: split-branch ( bb -- )
[ new-blocks ] keep
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs arrays layouts math math.order math.parser
-combinators combinators.short-circuit fry make sequences
-sequences.generalizations alien alien.private alien.strings
-alien.c-types alien.libraries classes.struct namespaces kernel
-strings libc locals quotations words cpu.architecture
-compiler.utilities compiler.tree compiler.cfg
+USING: accessors assocs arrays layouts math math.order
+math.parser combinators combinators.short-circuit fry make
+sequences sequences.generalizations alien alien.private
+alien.strings alien.c-types alien.libraries classes.struct
+namespaces kernel strings libc locals quotations words
+cpu.architecture compiler.utilities compiler.tree compiler.cfg
compiler.cfg.builder compiler.cfg.builder.alien.params
compiler.cfg.builder.alien.boxing compiler.cfg.builder.blocks
compiler.cfg.instructions compiler.cfg.stack-frame
-compiler.cfg.stacks compiler.cfg.registers compiler.cfg.hats ;
+compiler.cfg.stacks compiler.cfg.stacks.local
+compiler.cfg.registers compiler.cfg.hats ;
FROM: compiler.errors => no-such-symbol no-such-library ;
IN: compiler.cfg.builder.alien
: unbox-parameters ( parameters -- vregs reps )
[
[ length iota <reversed> ] keep
- [ [ <ds-loc> ^^peek ] [ base-type ] bi* unbox-parameter ]
+ [ [ <ds-loc> peek-loc ] [ base-type ] bi* unbox-parameter ]
2 2 mnmap [ concat ] bi@
]
- [ length neg ##inc-d ] bi ;
+ [ length neg inc-d ] bi ;
: prepare-struct-caller ( vregs reps return -- vregs' reps' return-vreg/f )
dup large-struct? [
struct-return-area set ;
: box-return* ( node -- )
- return>> [ ] [ base-type box-return 1 ##inc-d D 0 ##replace ] if-void ;
+ return>> [ ] [ base-type box-return ds-push ] if-void ;
GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
[ library>> load-library ]
bi 2dup check-dlsym ;
-: alien-node-height ( params -- )
- [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
-
-: emit-alien-block ( node quot: ( params -- ) -- )
- '[
- make-kill-block
- params>>
- _ [ alien-node-height ] bi
- ] emit-trivial-block ; inline
-
: emit-stack-frame ( stack-size params -- )
[ [ return>> ] [ abi>> ] bi stack-cleanup ##cleanup ]
[ drop ##stack-frame ]
2bi ;
M: #alien-invoke emit-node
- [
- {
- [ caller-parameters ]
- [ ##prepare-var-args alien-invoke-dlsym <gc-map> ##alien-invoke ]
- [ emit-stack-frame ]
- [ box-return* ]
- } cleave
- ] emit-alien-block ;
-
-M:: #alien-indirect emit-node ( node -- )
- node [
- D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr :> src
- [ caller-parameters src <gc-map> ##alien-indirect ]
+ params>>
+ {
+ [ caller-parameters ]
+ [ ##prepare-var-args alien-invoke-dlsym <gc-map> ##alien-invoke ]
[ emit-stack-frame ]
[ box-return* ]
- tri
- ] emit-alien-block ;
+ } cleave ;
-M: #alien-assembly emit-node
+M: #alien-indirect emit-node ( node -- )
+ params>>
[
- {
- [ caller-parameters ]
- [ quot>> ##alien-assembly ]
- [ emit-stack-frame ]
- [ box-return* ]
- } cleave
- ] emit-alien-block ;
+ ds-pop ^^unbox-any-c-ptr
+ [ caller-parameters ] dip
+ <gc-map> ##alien-indirect
+ ]
+ [ emit-stack-frame ]
+ [ box-return* ]
+ tri ;
+
+M: #alien-assembly emit-node
+ params>> {
+ [ caller-parameters ]
+ [ quot>> <gc-map> ##alien-assembly ]
+ [ emit-stack-frame ]
+ [ box-return* ]
+ } cleave ;
: callee-parameter ( rep on-stack? -- dst insn )
[ next-vreg dup ] 2dip
bi ;
: box-parameters ( vregs reps params -- )
- ##begin-callback
- next-vreg next-vreg ##restore-context
- [
- next-vreg next-vreg ##save-context
- box-parameter
- 1 ##inc-d D 0 ##replace
- ] 3each ;
+ ##begin-callback [ box-parameter ds-push ] 3each ;
: callee-parameters ( params -- stack-size )
[ abi>> ] [ return>> ] [ parameters>> ] tri
cfg get t >>frame-pointer? drop ;
M: #alien-callback emit-node
- dup params>> xt>> dup
+ params>> dup xt>> dup
[
needs-frame-pointer
- ##prologue
- [
- {
- [ callee-parameters ]
- [ quot>> ##alien-callback ]
+ begin-word
+
+ {
+ [ callee-parameters ]
+ [
[
- return>> [ ##end-callback ] [
- [ D 0 ^^peek ] dip
- ##end-callback
- base-type unbox-return
- ] if-void
- ]
- [ callback-stack-cleanup ]
- } cleave
- ] emit-alien-block
- ##epilogue
- ##return
+ make-kill-block
+ quot>> ##alien-callback
+ ] emit-trivial-block
+ ]
+ [
+ return>> [ ##end-callback ] [
+ [ ds-pop ] dip
+ ##end-callback
+ base-type unbox-return
+ ] if-void
+ ]
+ [ callback-stack-cleanup ]
+ } cleave
+
+ end-word
] with-cfg-builder ;
: set-successors ( branches -- )
! Set the successor of each branch's final basic block to the
! current block.
- basic-block get dup [
- '[ [ [ _ ] dip first successors>> push ] when* ] each
- ] [ 2drop ] if ;
-
-: merge-heights ( branches -- )
- ! If all elements are f, that means every branch ended with a backward
- ! jump so the height is irrelevant since this block is unreachable.
- [ ] find nip [ second current-height set ] [ end-basic-block ] if* ;
+ [ [ [ basic-block get ] dip first successors>> push ] when* ] each ;
: emit-conditional ( branches -- )
! branches is a sequence of pairs as above
end-basic-block
- [ merge-heights begin-basic-block ]
- [ set-successors ]
- bi ;
-
+ dup [ ] find nip dup [
+ second current-height set
+ begin-basic-block
+ set-successors
+ ] [ 2drop ] if ;
dup dup [ mapping>> ] [ make-input-map ] bi load-shuffle store-shuffle ;
! #return
-: emit-return ( -- )
+: end-word ( -- )
##branch
begin-basic-block
make-kill-block
##epilogue
##return ;
-M: #return emit-node drop emit-return ;
+M: #return emit-node drop end-word ;
M: #return-recursive emit-node
- label>> id>> loops get key? [ emit-return ] unless ;
+ label>> id>> loops get key? [ end-word ] unless ;
! #terminate
M: #terminate emit-node drop ##no-tco end-basic-block ;
: finalize-cfg ( cfg -- cfg' )
select-representations
- schedule-instructions
+ ! schedule-instructions
insert-gc-checks
dup compute-uninitialized-sets
insert-save-contexts
compiler.cfg.registers compiler.cfg.instructions compiler.cfg
compiler.cfg.predecessors compiler.cfg.rpo cpu.architecture
tools.test kernel vectors namespaces accessors sequences alien
-memory classes make combinators.short-circuit byte-arrays ;
+memory classes make combinators.short-circuit byte-arrays
+compiler.cfg.comparisons ;
IN: compiler.cfg.gc-checks.tests
+[ { } ] [
+ V{
+ T{ ##inc-d }
+ T{ ##peek }
+ T{ ##add }
+ T{ ##branch }
+ } gc-check-offsets
+] unit-test
+
+[ { } ] [
+ V{
+ T{ ##inc-d }
+ T{ ##peek }
+ T{ ##alien-invoke }
+ T{ ##add }
+ T{ ##branch }
+ } gc-check-offsets
+] unit-test
+
+[ { 0 } ] [
+ V{
+ T{ ##inc-d }
+ T{ ##peek }
+ T{ ##allot }
+ T{ ##alien-invoke }
+ T{ ##add }
+ T{ ##branch }
+ } gc-check-offsets
+] unit-test
+
+[ { 0 } ] [
+ V{
+ T{ ##inc-d }
+ T{ ##peek }
+ T{ ##allot }
+ T{ ##allot }
+ T{ ##add }
+ T{ ##branch }
+ } gc-check-offsets
+] unit-test
+
+[ { 0 4 } ] [
+ V{
+ T{ ##inc-d }
+ T{ ##peek }
+ T{ ##allot }
+ T{ ##alien-invoke }
+ T{ ##allot }
+ T{ ##add }
+ T{ ##sub }
+ T{ ##branch }
+ } gc-check-offsets
+] unit-test
+
+[ { 3 } ] [
+ V{
+ T{ ##inc-d }
+ T{ ##peek }
+ T{ ##alien-invoke }
+ T{ ##allot }
+ T{ ##add }
+ T{ ##branch }
+ } gc-check-offsets
+] unit-test
+
+[ { { "a" } } ] [ { "a" } { } split-instructions ] unit-test
+
+[ { { } { "a" } } ] [ { "a" } { 0 } split-instructions ] unit-test
+
+[ { { "a" } { } } ] [ { "a" } { 1 } split-instructions ] unit-test
+
+[ { { "a" } { "b" } } ] [ { "a" "b" } { 1 } split-instructions ] unit-test
+
+[ { { } { "a" } { "b" "c" } } ] [ { "a" "b" "c" } { 0 1 } split-instructions ] unit-test
+
: test-gc-checks ( -- )
H{ } clone representations set
cfg new 0 get >>entry cfg set ;
[ t ] [ cfg get blocks-with-gc 1 get 1array sequence= ] unit-test
-[ ] [ 1 get allocation-size 123 <alien> size assert= ] unit-test
+[ ] [ 1 get
instructions>> allocation-size 123 <alien> size assert= ] unit-test
2 \ vreg-counter set-global
[ first ##check-nursery-branch? ]
} 1&& ;
-[ t ] [ V{ } 100 <gc-check> gc-check? ] unit-test
-
-4 \ vreg-counter set-global
-
-[
+: gc-call? ( bb -- ? )
+ instructions>>
V{
T{ ##call-gc f T{ gc-map } }
T{ ##branch }
- }
-]
-[
- <gc-call> instructions>>
-] unit-test
-
-30 \ vreg-counter set-global
-
-V{
- T{ ##branch }
-} 0 test-bb
+ } = ;
-V{
- T{ ##branch }
-} 1 test-bb
-
-V{
- T{ ##branch }
-} 2 test-bb
-
-V{
- T{ ##branch }
-} 3 test-bb
-
-V{
- T{ ##branch }
-} 4 test-bb
-
-0 { 1 2 } edges
-1 3 edge
-2 3 edge
-3 4 edge
-
-[ ] [ test-gc-checks ] unit-test
-
-[ ] [ cfg get needs-predecessors drop ] unit-test
-
-[ ] [ V{ } 31337 3 get (insert-gc-check) ] unit-test
-
-[ t ] [ 1 get successors>> first gc-check? ] unit-test
-
-[ t ] [ 2 get successors>> first gc-check? ] unit-test
+4 \ vreg-counter set-global
-[ t ] [ 3 get predecessors>> first gc-check? ] unit-test
+[ t ] [ <gc-call> gc-call? ] unit-test
30 \ vreg-counter set-global
[ ] [ cfg get insert-gc-checks drop ] unit-test
+[ ] [ 1 get successors>> first successors>> first 2 set ] unit-test
+
[ 2 ] [ 2 get predecessors>> length ] unit-test
[ t ] [ 1 get successors>> first gc-check? ] unit-test
} representations set
[ ] [ cfg get insert-gc-checks drop ] unit-test
+[ ] [ 1 get successors>> first successors>> first 3 set ] unit-test
[ t ] [ 2 get successors>> first instructions>> first ##phi? ] unit-test
[ 2 ] [ 3 get instructions>> length ] unit-test
+
+! GC check in a block that is its own successor
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##allot f 1 64 byte-array }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 2 test-bb
+
+0 1 edge
+1 { 1 2 } edges
+
+[ ] [ test-gc-checks ] unit-test
+
+[ ] [ cfg get insert-gc-checks drop ] unit-test
+
+[ ] [
+ 0 get successors>> first predecessors>>
+ [ first 0 get assert= ]
+ [ second 1 get [ instructions>> ] bi@ assert= ] bi
+] unit-test
+
+[ ] [
+ 0 get successors>> first successors>>
+ [ first 1 get [ instructions>> ] bi@ assert= ]
+ [ second gc-call? t assert= ] bi
+] unit-test
+
+[ ] [
+ 2 get predecessors>> first predecessors>>
+ [ first gc-check? t assert= ]
+ [ second gc-call? t assert= ] bi
+] unit-test
+
+! Brave new world of calls in the middle of BBs
+
+! call then allot
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##alien-invoke f "malloc" f T{ gc-map } }
+ T{ ##allot f 1 64 byte-array }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 2 test-bb
+
+0 1 edge
+1 2 edge
+
+2 \ vreg-counter set-global
+
+[ ] [ test-gc-checks ] unit-test
+
+[ ] [ cfg get insert-gc-checks drop ] unit-test
+
+! The GC check should come after the alien-invoke
+[
+ V{
+ T{ ##alien-invoke f "malloc" f T{ gc-map } }
+ T{ ##check-nursery-branch f 64 cc<= 3 4 }
+ }
+] [ 0 get successors>> first instructions>> ] unit-test
+
+! call then allot then call then allot
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##alien-invoke f "malloc" f T{ gc-map } }
+ T{ ##allot f 1 64 byte-array }
+ T{ ##alien-invoke f "malloc" f T{ gc-map } }
+ T{ ##allot f 2 64 byte-array }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 2 test-bb
+
+0 1 edge
+1 2 edge
+
+2 \ vreg-counter set-global
+
+[ ] [ test-gc-checks ] unit-test
+
+[ ] [ cfg get insert-gc-checks drop ] unit-test
+
+[
+ V{
+ T{ ##alien-invoke f "malloc" f T{ gc-map } }
+ T{ ##check-nursery-branch f 64 cc<= 3 4 }
+ }
+] [
+ 0 get
+ successors>> first
+ instructions>>
+] unit-test
+
+[
+ V{
+ T{ ##allot f 1 64 byte-array }
+ T{ ##alien-invoke f "malloc" f T{ gc-map } }
+ T{ ##check-nursery-branch f 64 cc<= 5 6 }
+ }
+] [
+ 0 get
+ successors>> first
+ successors>> first
+ instructions>>
+] unit-test
+
+[
+ V{
+ T{ ##allot f 2 64 byte-array }
+ T{ ##branch }
+ }
+] [
+ 0 get
+ successors>> first
+ successors>> first
+ successors>> first
+ instructions>>
+] unit-test
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators fry kernel layouts locals
-math make namespaces sequences cpu.architecture
+USING: accessors assocs combinators fry grouping kernel layouts
+locals math make namespaces sequences cpu.architecture
compiler.cfg
compiler.cfg.rpo
compiler.cfg.hats
compiler.cfg.predecessors ;
IN: compiler.cfg.gc-checks
-<PRIVATE
-
! Garbage collection check insertion. This pass runs after
! representation selection, since it needs to know which vregs
! can contain tagged pointers.
+<PRIVATE
+
: insert-gc-check? ( bb -- ? )
dup kill-block?>>
[ drop f ] [ instructions>> [ ##allocation? ] any? ] if ;
: blocks-with-gc ( cfg -- bbs )
post-order [ insert-gc-check? ] filter ;
-! A GC check for bb consists of two new basic blocks, gc-check
-! and gc-call:
-!
-! gc-check
-! / \
-! | gc-call
-! \ /
-! bb
-
-! Any ##phi instructions at the start of bb are transplanted
-! into the gc-check block.
-
-: <gc-check> ( phis size -- bb )
- [ <basic-block> ] 2dip
- [
- [ % ]
- [
- cc<= int-rep next-vreg-rep int-rep next-vreg-rep
- ##check-nursery-branch
- ] bi*
- ] V{ } make >>instructions ;
-
-: <gc-call> ( -- bb )
- <basic-block>
- [ <gc-map> ##call-gc ##branch ] V{ } make
- >>instructions t >>unlikely? ;
-
-:: insert-guard ( body check bb -- )
- bb predecessors>> check predecessors<<
- V{ bb body } check successors<<
-
- V{ check } body predecessors<<
- V{ bb } body successors<<
+GENERIC# gc-check-offsets* 1 ( call-index seen-allocation? insn n -- call-index seen-allocation? )
- V{ check body } bb predecessors<<
+:: gc-check-here ( call-index seen-allocation? insn insn-index -- call-index seen-allocation? )
+ seen-allocation? [ call-index , ] when
+ insn-index 1 + f ;
- check predecessors>> [ bb check update-successors ] each ;
+M: ##phi gc-check-offsets* gc-check-here ;
+M: gc-map-insn gc-check-offsets* gc-check-here ;
+M: ##allocation gc-check-offsets* 3drop t ;
+M: insn gc-check-offsets* 2drop ;
-: (insert-gc-check) ( phis size bb -- )
- [ [ <gc-call> ] 2dip <gc-check> ] dip insert-guard ;
+: gc-check-offsets ( insns -- seq )
+ ! A basic block is divided into sections by call and phi
+ ! instructions. For every section with at least one
+ ! allocation, record the offset of its first instruction
+ ! in a sequence.
+ [
+ [ 0 f ] dip
+ [ gc-check-offsets* ] each-index
+ [ , ] [ drop ] if
+ ] { } make ;
+
+:: split-instructions ( insns seq -- insns-seq )
+ ! Divide a basic block into sections, where every section
+ ! other than the first requires a GC check.
+ [
+ insns 0 seq [| insns from to |
+ from to insns subseq ,
+ insns to
+ ] each
+ tail ,
+ ] { } make ;
GENERIC: allocation-size* ( insn -- n )
M: ##box-displaced-alien allocation-size* drop 5 cells ;
-: allocation-size ( bb -- n )
- instructions>>
+: allocation-size ( insns -- n )
[ ##allocation? ] filter
[ allocation-size* data-alignment get align ] map-sum ;
-: remove-phis ( bb -- phis )
- [ [ ##phi? ] partition ] change-instructions drop ;
+: add-gc-checks ( insns-seq -- )
+ ! Insert a GC check at the end of every chunk but the last
+ ! one. This ensures that every section other than the first
+ ! has a GC check in the section immediately preceeding it.
+ 2 <clumps> [
+ first2 allocation-size
+ cc<= int-rep next-vreg-rep int-rep next-vreg-rep
+ \ ##check-nursery-branch new-insn
+ swap push
+ ] each ;
+
+: make-blocks ( insns-seq -- bbs )
+ [ <basic-block> swap >>instructions ] map ;
-: insert-gc-check ( bb -- )
- [ remove-phis ] [ allocation-size ] [ ] tri (insert-gc-check) ;
+: <gc-call> ( -- bb )
+ <basic-block>
+ [ <gc-map> ##call-gc ##branch ] V{ } make
+ >>instructions t >>unlikely? ;
+
+:: connect-gc-checks ( bbs -- )
+ ! Every basic block but the last has two successors:
+ ! the next block, and a GC call.
+ ! Every basic block but the first has two predecessors:
+ ! the previous block, and the previous block's GC call.
+ bbs length 1 - :> len
+ len [ <gc-call> ] replicate :> gc-calls
+ len [| n |
+ n bbs nth :> bb
+ n 1 + bbs nth :> next-bb
+ n gc-calls nth :> gc-call
+ V{ next-bb gc-call } bb successors<<
+ V{ next-bb } gc-call successors<<
+ V{ bb } gc-call predecessors<<
+ V{ bb gc-call } next-bb predecessors<<
+ ] each-integer ;
+
+:: update-predecessor-phis ( from to bb -- )
+ to [
+ [
+ [
+ [ dup from eq? [ drop bb ] when ] dip
+ ] assoc-map
+ ] change-inputs drop
+ ] each-phi ;
+
+:: (insert-gc-checks) ( bb bbs -- )
+ bb predecessors>> bbs first predecessors<<
+ bb successors>> bbs last successors<<
+ bb predecessors>> [ bb bbs first update-successors ] each
+ bb successors>> [
+ [ bb ] dip bbs last
+ [ update-predecessors ]
+ [ update-predecessor-phis ] 3bi
+ ] each ;
+
+: process-block ( bb -- )
+ dup instructions>> dup gc-check-offsets split-instructions
+ [ add-gc-checks ] [ make-blocks dup connect-gc-checks ] bi
+ (insert-gc-checks) ;
PRIVATE>
: insert-gc-checks ( cfg -- cfg' )
dup blocks-with-gc [
[ needs-predecessors ] dip
- [ insert-gc-check ] each
+ [ process-block ] each
cfg-changed
] unless-empty ;
--- /dev/null
+USING: compiler.cfg.height compiler.cfg.instructions\r
+compiler.cfg.registers tools.test ;\r
+IN: compiler.cfg.height.tests\r
+\r
+[\r
+ V{\r
+ T{ ##inc-r f -1 f }\r
+ T{ ##inc-d f 4 f }\r
+ T{ ##peek f 0 D 4 f }\r
+ T{ ##peek f 1 D 0 f }\r
+ T{ ##replace f 0 R -1 f }\r
+ T{ ##replace f 1 R 0 f }\r
+ T{ ##peek f 2 D 0 f }\r
+ }\r
+] [\r
+ V{\r
+ T{ ##peek f 0 D 0 }\r
+ T{ ##inc-d f 3 }\r
+ T{ ##peek f 1 D -1 }\r
+ T{ ##replace f 0 R 0 }\r
+ T{ ##inc-r f -1 }\r
+ T{ ##replace f 1 R 0 }\r
+ T{ ##inc-d f 1 }\r
+ T{ ##peek f 2 D 0 }\r
+ } height-step\r
+] unit-test\r
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors math namespaces sequences kernel fry
compiler.cfg compiler.cfg.registers compiler.cfg.instructions
SYMBOL: ds-height
SYMBOL: rs-height
-GENERIC: compute-heights ( insn -- )
-
-M: ##inc-d compute-heights n>> ds-height [ + ] change ;
-M: ##inc-r compute-heights n>> rs-height [ + ] change ;
-M: insn compute-heights drop ;
+: init-height ( -- )
+ 0 ds-height set
+ 0 rs-height set ;
-GENERIC: normalize-height* ( insn -- insn' )
+GENERIC: visit-insn ( insn -- )
-: normalize-inc-d/r ( insn stack -- insn' )
- swap n>> '[ _ - ] change f ; inline
+: normalize-inc-d/r ( insn stack -- )
+ swap n>> '[ _ + ] change ; inline
-M: ##inc-d normalize-height* ds-height normalize-inc-d/r ;
-M: ##inc-r normalize-height* rs-height normalize-inc-d/r ;
+M: ##inc-d visit-insn ds-height normalize-inc-d/r ;
+M: ##inc-r visit-insn rs-height normalize-inc-d/r ;
GENERIC: loc-stack ( loc -- stack )
M: ds-loc <loc> drop <ds-loc> ;
M: rs-loc <loc> drop <rs-loc> ;
-: normalize-peek/replace ( insn -- insn' )
- [ [ [ n>> ] [ loc-stack get ] bi + ] keep <loc> ] change-loc ; inline
+: normalize-peek/replace ( insn -- )
+ [ [ [ n>> ] [ loc-stack get ] bi + ] keep <loc> ] change-loc
+ drop ; inline
-M: ##peek normalize-height* normalize-peek/replace ;
-M: ##replace normalize-height* normalize-peek/replace ;
+M: ##peek visit-insn normalize-peek/replace ;
+M: ##replace visit-insn normalize-peek/replace ;
-M: insn normalize-height* ;
+M: insn visit-insn drop ;
: height-step ( insns -- insns' )
- 0 ds-height set
- 0 rs-height set
- [ [ compute-heights ] each ]
- [ [ [ normalize-height* ] map sift ] with-scope ] bi
- ds-height get dup 0 = [ drop ] [ \ ##inc-d new-insn prefix ] if
- rs-height get dup 0 = [ drop ] [ \ ##inc-r new-insn prefix ] if ;
+ init-height
+ [ <reversed> [ visit-insn ] each ]
+ [
+ [ [ ##inc-d? ] [ ##inc-r? ] bi or not ] filter!
+ ds-height get [ \ ##inc-d new-insn prefix ] unless-zero
+ rs-height get [ \ ##inc-r new-insn prefix ] unless-zero
+ ] bi ;
: normalize-height ( cfg -- cfg' )
dup [ height-step ] simple-optimization ;
literal: gc-map ;
INSN: ##alien-assembly
-literal: quot ;
+literal: quot gc-map ;
INSN: ##begin-callback ;
INSN: ##save-context
temp: temp1/int-rep temp2/int-rep ;
-INSN: ##restore-context
-temp: temp1/int-rep temp2/int-rep ;
-
! GC checks
INSN: ##check-nursery-branch
literal: size cc
UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
+! Instructions that contain subroutine calls to functions which
+! can callback arbitrary Factor code
+UNION: factor-call-insn
+##alien-invoke
+##alien-indirect
+##alien-assembly ;
+
! Instructions that contain subroutine calls to functions which
! allocate memory
UNION: gc-map-insn
##call-gc
-##alien-invoke
-##alien-indirect
##box
##box-long-long
-##allot-byte-array ;
+##allot-byte-array
+factor-call-insn ;
M: gc-map-insn clone call-next-method [ clone ] change-gc-map ;
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors assocs sequences sets
+USING: kernel accessors assocs namespaces sequences sets
compiler.cfg.def-use compiler.cfg.dataflow-analysis
compiler.cfg.instructions compiler.cfg.registers
cpu.architecture ;
M: vreg-insn visit-insn [ kill-defs ] [ gen-uses ] bi ;
: fill-gc-map ( live-set insn -- live-set )
- gc-map>> over keys [ rep-of tagged-rep? ] filter >>gc-roots drop ;
+ representations get [
+ gc-map>> over keys
+ [ rep-of tagged-rep? ] filter
+ >>gc-roots
+ ] when
+ drop ;
M: gc-map-insn visit-insn
[ kill-defs ] [ fill-gc-map ] [ gen-uses ] tri ;
USING: accessors compiler.cfg.debugger
compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.save-contexts kernel namespaces tools.test ;
+compiler.cfg.save-contexts kernel namespaces tools.test
+cpu.x86.assembler.operands cpu.architecture ;
IN: compiler.cfg.save-contexts.tests
0 vreg-counter set-global
] [
0 get instructions>>
] unit-test
+
+4 vreg-counter set-global
+
+V{
+ T{ ##inc-d f 3 }
+ T{ ##load-reg-param f 0 RCX int-rep }
+ T{ ##load-reg-param f 1 RDX int-rep }
+ T{ ##load-reg-param f 2 R8 int-rep }
+ T{ ##begin-callback }
+ T{ ##box f 4 3 "from_signed_4" int-rep
+ T{ gc-map { scrub-d B{ 0 0 0 } } { scrub-r B{ } } { gc-roots { } } }
+ }
+} 0 test-bb
+
+0 get insert-save-context
+
+[
+ V{
+ T{ ##inc-d f 3 }
+ T{ ##load-reg-param f 0 RCX int-rep }
+ T{ ##load-reg-param f 1 RDX int-rep }
+ T{ ##load-reg-param f 2 R8 int-rep }
+ T{ ##save-context f 5 6 }
+ T{ ##begin-callback }
+ T{ ##box f 4 3 "from_signed_4" int-rep
+ T{ gc-map { scrub-d B{ 0 0 0 } } { scrub-r B{ } } { gc-roots { } } }
+ }
+ }
+] [
+ 0 get instructions>>
+] unit-test
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators.short-circuit
-compiler.cfg.instructions compiler.cfg.registers
+USING: accessors compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.rpo cpu.architecture kernel sequences vectors ;
IN: compiler.cfg.save-contexts
! Insert context saves.
-: needs-save-context? ( insns -- ? )
- [
- {
- [ ##unary-float-function? ]
- [ ##binary-float-function? ]
- [ ##alien-invoke? ]
- [ ##alien-indirect? ]
- [ ##alien-assembly? ]
- } 1||
- ] any? ;
+GENERIC: needs-save-context? ( insn -- ? )
+
+M: ##unary-float-function needs-save-context? drop t ;
+M: ##binary-float-function needs-save-context? drop t ;
+M: gc-map-insn needs-save-context? drop t ;
+M: insn needs-save-context? drop f ;
+
+: bb-needs-save-context? ( insn -- ? )
+ instructions>> [ needs-save-context? ] any? ;
+
+GENERIC: modifies-context? ( insn -- ? )
+
+M: ##inc-d modifies-context? drop t ;
+M: ##inc-r modifies-context? drop t ;
+M: ##load-reg-param modifies-context? drop t ;
+M: insn modifies-context? drop f ;
+
+: save-context-offset ( bb -- n )
+ ! ##save-context must be placed after instructions that
+ ! modify the context, or instructions that read parameter
+ ! registers.
+ instructions>> [ modifies-context? not ] find drop ;
: insert-save-context ( bb -- )
- dup instructions>> dup needs-save-context? [
- tagged-rep next-vreg-rep
- tagged-rep next-vreg-rep
- \ ##save-context new-insn prefix
- >>instructions drop
- ] [ 2drop ] if ;
+ dup bb-needs-save-context? [
+ [
+ int-rep next-vreg-rep
+ int-rep next-vreg-rep
+ \ ##save-context new-insn
+ ] dip
+ [ save-context-offset ] keep
+ [ insert-nth ] change-instructions drop
+ ] [ drop ] if ;
: insert-save-contexts ( cfg -- cfg' )
dup [ insert-save-context ] each-basic-block ;
H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
:: update-predecessors ( from to bb -- )
- ! Update 'to' predecessors for insertion of 'bb' between
- ! 'from' and 'to'.
+ ! Whenever 'from' appears in the list of predecessors of 'to'
+ ! replace it with 'bb'.
to predecessors>> [ dup from eq? [ drop bb ] when ] map! drop ;
:: update-successors ( from to bb -- )
- ! Update 'from' successors for insertion of 'bb' between
- ! 'from' and 'to'.
+ ! Whenever 'to' appears in the list of successors of 'from'
+ ! replace it with 'bb'.
from successors>> [ dup to eq? [ drop bb ] when ] map! drop ;
:: insert-basic-block ( from to insns -- )
CODEGEN: ##compare-float-ordered %compare-float-ordered
CODEGEN: ##compare-float-unordered %compare-float-unordered
CODEGEN: ##save-context %save-context
-CODEGEN: ##restore-context %restore-context
CODEGEN: ##vm-field %vm-field
CODEGEN: ##set-vm-field %set-vm-field
CODEGEN: ##alien-global %alien-global
CODEGEN: ##alien-callback %alien-callback
CODEGEN: ##end-callback %end-callback
-M: ##alien-assembly generate-insn quot>> call( -- ) ;
+M: ##alien-assembly generate-insn
+ [ gc-map>> gc-map set ] [ quot>> call( -- ) ] bi ;
quotations classes classes.algebra classes.tuple.private
continuations growable namespaces hints alien.accessors
compiler.tree.builder compiler.tree.optimizer sequences.deep
-compiler.test definitions generic.single shuffle math.order ;
+compiler.test definitions generic.single shuffle math.order
+compiler.cfg.debugger ;
IN: compiler.tests.optimizer
GENERIC: xyz ( obj -- obj )
] keep ;
[ { 0.5 } ] [ grid-mesh-test-case ] unit-test
+
+[ { 1 } "bar" ] [ { 1 } [ [ [ [ "foo" throw ] [ "bar" throw ] recover ] attempt-all f ] [ ] recover ] compile-call ] unit-test
+
+GENERIC: bad-push-test-case ( a -- b )
+M: object bad-push-test-case "foo" throw ; inline
+[ { 1 } "bar" ] [ { 1 } [ [ [ [ bad-push-test-case ] [ "bar" throw ] recover ] attempt-all f ] [ ] recover ] compile-call ] unit-test
[ t ] [
[
- { integer } declare [ 256 rem ] map
+ { iota } declare [ 256 rem ] map
] { mod fixnum-mod rem } inlined?
] unit-test
] keep bitxor >fixnum
] with each
] { + bignum+ fixnum-shift bitxor bignum-bitxor } inlined?
-] unit-test
\ No newline at end of file
+] unit-test
! Copyright (C) 2008, 2010 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: deques threads kernel arrays sequences alarms fry ;\r
+USING: deques threads kernel arrays sequences timers fry ;\r
IN: concurrency.conditions\r
\r
: notify-1 ( deque -- )\r
: notify-all ( deque -- )\r
[ resume-now ] slurp-deque ; inline\r
\r
-: queue-timeout ( queue timeout -- alarm )\r
- #! Add an alarm which removes the current thread from the\r
+: queue-timeout ( queue timeout -- timer )\r
+ #! Add an timer which removes the current thread from the\r
#! queue, and resumes it, passing it a value of t.\r
[\r
[ self swap push-front* ] keep '[\r
: wait ( queue timeout status -- )\r
over [\r
[ queue-timeout ] dip suspend\r
- [ wait-timeout ] [ stop-alarm ] if\r
+ [ wait-timeout ] [ stop-timer ] if\r
] [\r
[ drop queue ] dip suspend drop\r
] if ; inline\r
! Copyright (C) 2008, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types alien.syntax kernel math
-namespaces sequences destructors combinators threads heaps
-deques calendar system core-foundation core-foundation.strings
-core-foundation.file-descriptors core-foundation.timers
-core-foundation.time ;
+USING: accessors alien alien.c-types alien.syntax calendar
+classes.struct combinators core-foundation
+core-foundation.file-descriptors core-foundation.strings
+core-foundation.time core-foundation.timers deques destructors
+heaps kernel math namespaces sequences system threads unix
+unix.time ;
+FROM: calendar.unix => system-micros ;
IN: core-foundation.run-loop
CONSTANT: kCFRunLoopRunFinished 1
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.syntax system math kernel calendar
-core-foundation core-foundation.time ;
+core-foundation core-foundation.time calendar.unix ;
IN: core-foundation.timers
TYPEDEF: void* CFRunLoopTimerRef
HOOK: %allot-byte-array cpu ( dst size gc-map -- )
-HOOK: %restore-context cpu ( temp1 temp2 -- )
-
HOOK: %save-context cpu ( temp1 temp2 -- )
HOOK: %prepare-var-args cpu ( -- )
: nv-reg ( -- reg ) ESI ;
: ds-reg ( -- reg ) ESI ;
: rs-reg ( -- reg ) EDI ;
+: link-reg ( -- reg ) EBX ;
: fixnum>slot@ ( -- ) temp0 2 SAR ;
: rex-length ( -- n ) 0 ;
ESP 4 [+] EAX MOV
"begin_callback" jit-call
- jit-load-vm
- jit-load-context
- jit-restore-context
-
jit-call-quot
jit-load-vm
- jit-save-context
-
ESP [] vm-reg MOV
"end_callback" jit-call
] \ c-to-factor define-sub-primitive
: nv-reg ( -- reg ) RBX ;
: stack-reg ( -- reg ) RSP ;
: frame-reg ( -- reg ) RBP ;
+: link-reg ( -- reg ) R11 ;
: ctx-reg ( -- reg ) R12 ;
: vm-reg ( -- reg ) R13 ;
: ds-reg ( -- reg ) R14 ;
arg1 vm-reg MOV
"begin_callback" jit-call
- jit-load-context
- jit-restore-context
-
! call the quotation
arg1 return-reg MOV
jit-call-quot
- jit-save-context
-
arg1 vm-reg MOV
"end_callback" jit-call
] \ c-to-factor define-sub-primitive
! Save C callstack pointer
nv-reg context-callstack-save-offset [+] stack-reg MOV
- ! Load Factor callstack pointer
+ ! Load Factor stack pointers
stack-reg nv-reg context-callstack-bottom-offset [+] MOV
-
nv-reg jit-update-tib
jit-install-seh
+ rs-reg nv-reg context-retainstack-offset [+] MOV
+ ds-reg nv-reg context-datastack-offset [+] MOV
+
! Call into Factor code
- nv-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel
- nv-reg CALL
+ link-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel
+ link-reg CALL
! Load VM into vm-reg; only needed on x86-32, but doesn't
! hurt on x86-64
M: x86 %loop-entry 16 alignment [ NOP ] times ;
-M:: x86 %restore-context ( temp1 temp2 -- )
- #! Load Factor stack pointers on entry from C to Factor.
- temp1 %context
- temp2 stack-reg cell neg [+] LEA
- temp1 "callstack-top" context-field-offset [+] temp2 MOV
- ds-reg temp1 "datastack" context-field-offset [+] MOV
- rs-reg temp1 "retainstack" context-field-offset [+] MOV ;
-
M:: x86 %save-context ( temp1 temp2 -- )
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences db.tuples alarms calendar db fry
+USING: kernel sequences db.tuples timers calendar db fry
furnace.db
furnace.cache
furnace.asides
: expire-state ( class -- )
new
- -1/0. system-micros [a,b] >>expires
+ -1/0. gmt timestamp>micros [a,b] >>expires
delete-tuples ;
TUPLE: server-state-manager < filter-responder timeout ;
USING: assocs kernel math.intervals math.parser namespaces
strings random accessors quotations hashtables sequences
continuations fry calendar combinators combinators.short-circuit
-destructors alarms io.sockets db db.tuples db.types
+destructors io.sockets db db.tuples db.types
http http.server http.server.dispatchers http.server.filters
furnace.cache furnace.scopes furnace.utilities ;
IN: furnace.sessions
--- /dev/null
+Joe Groff\r
--- /dev/null
+! (c)2010 Joe Groff bsd license\r
+USING: assocs hashtables.identity kernel literals tools.test ;\r
+IN: hashtables.identity.tests\r
+\r
+CONSTANT: the-real-slim-shady "marshall mathers"\r
+\r
+CONSTANT: will\r
+ IH{\r
+ { $ the-real-slim-shady t }\r
+ { "marshall mathers" f }\r
+ }\r
+\r
+: please-stand-up ( assoc key -- value )\r
+ swap at ;\r
+\r
+[ t ] [ will the-real-slim-shady please-stand-up ] unit-test\r
+[ t ] [ will clone the-real-slim-shady please-stand-up ] unit-test\r
+\r
+[ 2 ] [ will assoc-size ] unit-test\r
+[ { { "marshall mathers" f } } ] [\r
+ the-real-slim-shady will clone\r
+ [ delete-at ] [ >alist ] bi\r
+] unit-test\r
+[ t ] [\r
+ t the-real-slim-shady identity-associate\r
+ t the-real-slim-shady identity-associate =\r
+] unit-test\r
+[ f ] [\r
+ t the-real-slim-shady identity-associate\r
+ t "marshall mathers" identity-associate =\r
+] unit-test\r
--- /dev/null
+! (c)2010 Joe Groff bsd license\r
+USING: accessors arrays assocs fry hashtables kernel parser\r
+sequences vocabs.loader ;\r
+IN: hashtables.identity\r
+\r
+TUPLE: identity-wrapper\r
+ { underlying read-only } ;\r
+C: <identity-wrapper> identity-wrapper\r
+\r
+M: identity-wrapper equal?\r
+ over identity-wrapper?\r
+ [ [ underlying>> ] bi@ eq? ]\r
+ [ 2drop f ] if ; inline\r
+\r
+M: identity-wrapper hashcode*\r
+ nip underlying>> identity-hashcode ; inline\r
+\r
+TUPLE: identity-hashtable\r
+ { underlying hashtable read-only } ;\r
+\r
+: <identity-hashtable> ( n -- ihash )\r
+ <hashtable> identity-hashtable boa ; inline\r
+\r
+<PRIVATE\r
+: identity@ ( key ihash -- ikey hash )\r
+ [ <identity-wrapper> ] [ underlying>> ] bi* ; inline\r
+PRIVATE>\r
+\r
+M: identity-hashtable at*\r
+ identity@ at* ; inline\r
+\r
+M: identity-hashtable clear-assoc\r
+ underlying>> clear-assoc ; inline\r
+\r
+M: identity-hashtable delete-at\r
+ identity@ delete-at ; inline\r
+\r
+M: identity-hashtable assoc-size\r
+ underlying>> assoc-size ; inline\r
+\r
+M: identity-hashtable set-at\r
+ identity@ set-at ; inline\r
+\r
+: identity-associate ( value key -- hash )\r
+ 2 <identity-hashtable> [ set-at ] keep ; inline\r
+\r
+M: identity-hashtable >alist\r
+ underlying>> >alist [ [ first underlying>> ] [ second ] bi 2array ] map ;\r
+ \r
+M: identity-hashtable clone\r
+ underlying>> clone identity-hashtable boa ; inline\r
+\r
+M: identity-hashtable equal?\r
+ over identity-hashtable? [ [ underlying>> ] bi@ = ] [ 2drop f ] if ;\r
+\r
+: >identity-hashtable ( assoc -- ihashtable )\r
+ dup assoc-size <identity-hashtable> [ '[ swap _ set-at ] assoc-each ] keep ;\r
+\r
+SYNTAX: IH{ \ } [ >identity-hashtable ] parse-literal ;\r
+\r
+{ "hashtables.identity" "prettyprint" } "hashtables.identity.prettyprint" require-when\r
+{ "hashtables.identity" "mirrors" } "hashtables.identity.mirrors" require-when\r
--- /dev/null
+USING: hashtables.identity mirrors ;\r
+IN: hashtables.identity.mirrors\r
+\r
+M: identity-hashtable make-mirror ;\r
--- /dev/null
+! (c)2010 Joe Groff bsd license\r
+USING: assocs continuations hashtables.identity kernel\r
+namespaces prettyprint.backend prettyprint.config\r
+prettyprint.custom ;\r
+IN: hashtables.identity.prettyprint\r
+\r
+M: identity-hashtable >pprint-sequence >alist ;\r
+M: identity-hashtable pprint-delims drop \ IH{ \ } ;\r
+\r
+M: identity-hashtable pprint*\r
+ nesting-limit inc\r
+ [ pprint-object ] [ nesting-limit dec ] [ ] cleanup ;\r
--- /dev/null
+Hashtables keyed by object identity (eq?) rather than by logical value (=)\r
: :lint-failures ( -- ) lint-failures get values errors. ;
-: unlinked-words ( words -- seq )
- all-word-help [ article-parent not ] filter ;
+: unlinked-words ( vocab -- seq )
+ words all-word-help [ article-parent not ] filter ;
: linked-undocumented-words ( -- seq )
all-words
{ $notes "Instead of using this word, it is better to use " { $vocab-link "furnace.actions" } " and the associated validation machinery, which allows you to access values using " { $link "html.forms.values" } " words." } ;
ARTICLE: "http.server.requests" "HTTP request variables"
-"The following variables are set by the HTTP server at the beginning of a request."
+"The following variables are set by the HTTP server at the beginning of a request. Responder implementations may access these variables."
{ $subsections
request
url
- post-request?
responder-nesting
params
}
"Utility words:"
{ $subsections
+ post-request?
param
set-param
request-params
}
-"Additional vocabularies may be set by vocabularies such as " { $vocab-link "html.forms" } " and " { $vocab-link "furnace.sessions" } "." ;
+"Additional variables may be set by vocabularies such as " { $vocab-link "html.forms" } " and " { $vocab-link "furnace.sessions" } "." ;
ARTICLE: "http.server.responders" "HTTP server responders"
+"Responders process requests and output " { $link "http.responses" } ". To implement a responder, define a new class and implement a method on the following generic word:"
+{ $subsections call-responder* }
"The HTTP server dispatches requests to a main responder:"
{ $subsections main-responder }
-"The main responder may in turn dispatch it a subordinate dispatcher, and so on."
-$nl
-"Responders process requests and output " { $link "http.responses" } "; concretely are instances of classes which implement a generic word:"
-{ $subsections call-responder* }
-"To actually call a subordinate responder, use the following word instead:"
+"The main responder may in turn dispatch it a subordinate dispatcher, and so on. To call a subordinate responder, use the following word:"
{ $subsections call-responder }
"A simple implementation of a responder which always outputs the same response:"
{ $subsections
trivial-responder
<trivial-responder>
}
-{ $vocab-subsection "Furnace actions" "furnace.actions" }
-"In particular, writing new responders by hand is rarely necessary, because in most cases it is easier to use " { $vocab-link "furnace.actions" } " instead." ;
+"Writing new responders by hand is rarely necessary, because in most cases it is easier to use " { $vocab-link "furnace.actions" } " instead."
+{ $vocab-subsection "Furnace actions" "furnace.actions" } ;
ARTICLE: "http.server.variables" "HTTP server variables"
"The following global variables control the behavior of the HTTP server. Both are off by default."
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators continuations fry io io.backend
io.directories io.directories.hierarchy io.files io.pathnames
-kernel math math.bitwise math.parser namespaces random
+kernel locals math math.bitwise math.parser namespaces random
sequences system vocabs.loader ;
IN: io.files.unique
: temporary-file ( -- path ) "" unique-file ;
-: with-working-directory ( path quot -- )
- over make-directories
- dupd '[ _ _ with-temporary-directory ] with-directory ; inline
+:: cleanup-unique-working-directory ( quot -- )
+ unique-directory :> path
+ path [ path quot with-temporary-directory ] with-directory
+ path delete-tree ; inline
{
{ [ os unix? ] [ "io.files.unique.unix" ] }
'[ _ call( -- result ) ] with-streams*
] with-destructors ;
-: <pipes> ( n -- pipes )
+GENERIC: <pipes> ( obj -- pipes )
+
+M: integer <pipes> ( n -- pipes )
[
[ (pipe) |dispose ] replicate
T{ pipe } [ prefix ] [ suffix ] bi
2 <clumps>
] with-destructors ;
+M: sequence <pipes>
+ [ { } ] [ length 1 - <pipes> ] if-empty ;
+
PRIVATE>
: run-pipeline ( seq -- results )
- [ length dup zero? [ drop { } ] [ 1 - <pipes> ] if ] keep
+ [ <pipes> ] keep
[
[ [ first in>> ] [ second out>> ] bi ] dip
run-pipeline-element
! Copyright (C) 2008 Slava Pestov, Doug Coleman\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel calendar alarms io io.encodings accessors\r
+USING: kernel calendar timers io io.encodings accessors\r
namespaces fry io.streams.null ;\r
IN: io.timeouts\r
\r
\r
GENERIC: cancel-operation ( obj -- )\r
\r
-: queue-timeout ( obj timeout -- alarm )\r
+: queue-timeout ( obj timeout -- timer )\r
[ '[ _ cancel-operation ] ] dip later ;\r
\r
: with-timeout* ( obj timeout quot -- )\r
- 3dup drop queue-timeout [ nip call ] dip stop-alarm ;\r
+ 3dup drop queue-timeout [ nip call ] dip stop-timer ;\r
inline\r
\r
: with-timeout ( obj quot -- )\r
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: logging.analysis logging.server logging smtp kernel\r
-io.files io.streams.string namespaces make alarms assocs\r
+io.files io.streams.string namespaces make timers assocs\r
io.encodings.utf8 accessors calendar sequences ;\r
QUALIFIED: io.sockets\r
IN: logging.insomniac\r
[ t ] [ { 1 1 1 } { 1 1 1 } p= ] unit-test
[ { 0 0 } { 1 1 } ] [ { 1 1 1 1 } { 1 1 } pgcd ] unit-test
+[ { 10 200 3000 } ] [ { 1 10 100 1000 } pdiff ] unit-test
+
[ V{ 0 } clone V{ 1 } clone ] 2dip swap (pgcd) [ >array ] bi@ ;
: pdiff ( p -- p' )
- dup length v* { 0 } ?head drop ;
+ dup length iota v* unclip drop ;
: polyval ( x p -- p[x] )
[ length swap powers ] [ nip ] 2bi v. ;
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors alarms fry kernel models ;\r
+USING: accessors timers fry kernel models ;\r
IN: models.delay\r
\r
-TUPLE: delay < model model timeout alarm ;\r
+TUPLE: delay < model model timeout timer ;\r
\r
: update-delay-model ( delay -- )\r
[ model>> value>> ] keep set-model ;\r
[ add-dependency ] keep ;\r
\r
: stop-delay ( delay -- )\r
- alarm>> [ stop-alarm ] when* ;\r
+ timer>> [ stop-timer ] when* ;\r
\r
: start-delay ( delay -- )\r
dup\r
- [ '[ _ f >>alarm update-delay-model ] ] [ timeout>> ] bi\r
+ [ '[ _ f >>timer update-delay-model ] ] [ timeout>> ] bi\r
later\r
- >>alarm drop ;\r
+ >>timer drop ;\r
\r
M: delay model-changed nip dup stop-delay start-delay ;\r
\r
USING: help.syntax help.markup kernel math classes classes.tuple
-calendar ;
+calendar sequences growable ;
IN: models
HELP: model
{ $values { "value" object } { "model" model } }
{ $description "Changes the value of a model and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;
-{ set-model change-model (change-model) } related-words
+{ set-model change-model change-model* (change-model) push-model pop-model } related-words
HELP: change-model
-{ $values { "model" model } { "quot" { $quotation "( obj -- newobj )" } } }
+{ $values { "model" model } { "quot" { $quotation "( ..a obj -- ..b newobj )" } } }
{ $description "Applies the quotation to the current value of the model to yield a new value, then changes the value of the model to the new value, and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;
+HELP: change-model*
+{ $values { "model" model } { "quot" { $quotation "( ..a obj -- ..b )" } } }
+{ $description "Applies the quotation to the current value of the model and calls " { $link model-changed } " on all observers registered with " { $link add-connection } " without actually changing the value of the model. This is useful for notifying observers of operations that mutate a value, as in " { $link push-model } " and " { $link pop-model } "." } ;
+
HELP: (change-model)
-{ $values { "model" model } { "quot" { $quotation "( obj -- newobj )" } } }
+{ $values { "model" model } { "quot" { $quotation "( ..a obj -- ..b newobj )" } } }
{ $description "Applies the quotation to the current value of the model to yield a new value, then changes the value of the model to the new value without notifying any observers registered with " { $link add-connection } "." }
{ $notes "There are very few reasons for user code to call this word. Instead, call " { $link change-model } ", which notifies observers." } ;
+HELP: push-model
+{ $values { "value" object } { "model" model } }
+{ $description { $link push } "es " { $snippet "value" } " onto the " { $link growable } " sequence stored as the value of " { $snippet "model" } " and calls " { $link model-changed } " on all observers registered for the model with " { $link add-connection } "." } ;
+
+HELP: pop-model
+{ $values { "model" model } { "value" object } }
+{ $description { $link pop } "s the topmost " { $snippet "value" } " off of the " { $link growable } " sequence stored as the value of " { $snippet "model" } " and calls " { $link model-changed } " on all observers registered for the model with " { $link add-connection } "." } ;
+
HELP: range-value
{ $values { "model" model } { "value" object } }
{ $contract "Outputs the current value of a range model." } ;
[ T{ model-tester f t } ]
[
- T{ model-tester f f } 3 <model> 2dup add-connection
+ T{ model-tester f f } clone 3 <model> 2dup add-connection
5 swap set-model
] unit-test
"tester" get
"model-c" get value>>
] unit-test
+
+[ T{ model-tester f t } V{ 5 } ]
+[
+ T{ model-tester f f } clone V{ } clone <model> 2dup add-connection
+ 5 swap [ push-model ] [ value>> ] bi
+] unit-test
+
+[ T{ model-tester f t } 5 V{ } ]
+[
+ T{ model-tester f f } clone V{ 5 } clone <model> 2dup add-connection
+ [ pop-model ] [ value>> ] bi
+] unit-test
+
: ((change-model)) ( model quot -- newvalue model )
over [ [ value>> ] dip call ] dip ; inline
-: change-model ( model quot -- )
+: change-model ( ..a model quot: ( ..a obj -- ..b newobj ) -- ..b )
((change-model)) set-model ; inline
-: (change-model) ( model quot -- )
+: (change-model) ( ..a model quot: ( ..a obj -- ..b newobj ) -- ..b )
((change-model)) value<< ; inline
GENERIC: range-value ( model -- value )
: clamp-value ( value range -- newvalue )
[ range-min-value ] [ range-max-value* ] bi clamp ;
+
+: change-model* ( ..a model quot: ( ..a obj -- ..b ) -- ..b )
+ '[ _ keep ] change-model ; inline
+
+: push-model ( value model -- )
+ [ push ] change-model* ;
+
+: pop-model ( model -- value )
+ [ pop ] change-model* ;
+
M: object pprint* pprint-object ;
M: vector pprint* pprint-object ;
M: byte-vector pprint* pprint-object ;
+
+: with-extra-nesting-level ( quot -- )
+ nesting-limit [ dup [ 1 + ] [ f ] if* ] change
+ [ nesting-limit set ] curry [ ] cleanup ; inline
+
M: hashtable pprint*
- nesting-limit inc
- [ pprint-object ] [ nesting-limit dec ] [ ] cleanup ;
+ [ pprint-object ] with-extra-nesting-level ;
M: curry pprint* pprint-object ;
M: compose pprint* pprint-object ;
M: hash-set pprint* pprint-object ;
] [
[ \ final-tuple see ] with-string-writer "\n" split
] unit-test
+
+[ "H{ { 1 2 } }\n" ] [ [ H{ { 1 2 } } short. ] with-string-writer ] unit-test
+
+[ "H{ { 1 ~array~ } }\n" ] [ [ H{ { 1 { 2 } } } short. ] with-string-writer ] unit-test
+
+[ "{ ~array~ }\n" ] [ [ { { 1 2 } } short. ] with-string-writer ] unit-test
+
+[ "H{ { 1 { 2 3 } } }\n" ] [
+ f nesting-limit [
+ [ H{ { 1 { 2 3 } } } . ] with-string-writer
+ ] with-variable
+] unit-test
+
!
USING: namespaces sequences kernel math io math.functions
io.binary strings classes words sbufs classes.tuple arrays
-vectors byte-arrays quotations hashtables assocs help.syntax
-help.markup splitting io.streams.byte-array io.encodings.string
-io.encodings.utf8 io.encodings.binary combinators accessors
-locals prettyprint compiler.units sequences.private
-classes.tuple.private vocabs.loader ;
+vectors byte-arrays quotations hashtables hashtables.identity
+assocs help.syntax help.markup splitting io.streams.byte-array
+io.encodings.string io.encodings.utf8 io.encodings.binary
+combinators accessors locals prettyprint compiler.units
+sequences.private classes.tuple.private vocabs.loader ;
IN: serialize
GENERIC: (serialize) ( obj -- )
! Variable holding a assoc of objects already serialized
SYMBOL: serialized
-TUPLE: id obj ;
-
-C: <id> id
-
-M: id hashcode* nip obj>> identity-hashcode ;
-
-M: id equal? over id? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
-
: add-object ( obj -- )
#! Add an object to the sequence of already serialized
#! objects.
- serialized get [ assoc-size swap <id> ] keep set-at ;
+ serialized get [ assoc-size swap ] keep set-at ;
: object-id ( obj -- id )
#! Return the id of an already serialized object
- <id> serialized get at ;
+ serialized get at ;
! Numbers are serialized as follows:
! 0 => B{ 0 }
[ (deserialize) ] with-variable ;
: serialize ( obj -- )
- H{ } clone serialized [ (serialize) ] with-variable ;
+ IH{ } clone serialized [ (serialize) ] with-variable ;
: bytes>object ( bytes -- obj )
binary [ deserialize ] with-byte-reader ;
"<" %
64 random-bits #
"-" %
- system-micros #
+ gmt timestamp>micros #
"@" %
smtp-domain get [ host-name ] unless* %
">" %
word>> name>> "Cannot compile call to “" "”" surround ;
M: unbalanced-branches-error summary
- word>> name>>
- "The input quotations to “" "” don't match their expected effects" surround ;
+ [ word>> name>> ] [ quots>> length 1 = ] bi
+ [ "The input quotation to “" "” doesn't match its expected effect" ]
+ [ "The input quotations to “" "” don't match their expected effects" ] if
+ surround ;
M: unbalanced-branches-error error.
dup summary print
\ quot-compiled? { quotation } { object } define-primitive
\ quotation-code { quotation } { integer integer } define-primitive \ quotation-code make-flushable
\ reset-dispatch-stats { } { } define-primitive
-\ resize-array { integer array } { array } define-primitive \ resize-array make-flushable
-\ resize-byte-array { integer byte-array } { byte-array } define-primitive \ resize-byte-array make-flushable
-\ resize-string { integer string } { string } define-primitive \ resize-string make-flushable
+\ resize-array { integer array } { array } define-primitive
+\ resize-byte-array { integer byte-array } { byte-array } define-primitive
+\ resize-string { integer string } { string } define-primitive
\ retainstack { } { array } define-primitive \ retainstack make-flushable
\ retainstack-for { c-ptr } { array } define-primitive \ retainstack-for make-flushable
\ set-alien-cell { c-ptr c-ptr integer } { } define-primitive
\ special-object { fixnum } { object } define-primitive \ special-object make-flushable
\ string-nth-fast { fixnum string } { fixnum } define-primitive \ string-nth-fast make-flushable
\ strip-stack-traces { } { } define-primitive
-\ system-micros { } { integer } define-primitive \ system-micros make-flushable
\ tag { object } { fixnum } define-primitive \ tag make-foldable
\ unimplemented { } { } define-primitive
\ word-code { word } { integer integer } define-primitive \ word-code make-flushable
:: (effect-here) ( inner-d old-meta-d-length old-input-count -- effect )
old-meta-d-length inner-d - input-count get old-input-count - +
- meta-d length inner-d -
- [ "x" <array> ] bi@ terminated? get <terminated-effect> ; inline
+ terminated? get [ [ 0 ] [ meta-d length inner-d - ] if [ "x" <array> ] bi@ ] keep
+ <terminated-effect> ; inline
: with-effect-here ( quot -- effect )
meta-d length input-count get
--- /dev/null
+Doug Coleman
--- /dev/null
+One-time and recurring timers for relative time offsets
--- /dev/null
+USING: help.markup help.syntax calendar quotations system ;\r
+IN: timers\r
+\r
+HELP: timer\r
+{ $class-description "A timer. Can be passed to " { $link stop-timer } "." } ;\r
+\r
+HELP: start-timer\r
+{ $values { "timer" timer } }\r
+{ $description "Starts a timer." } ;\r
+\r
+HELP: restart-timer\r
+{ $values { "timer" timer } }\r
+{ $description "Starts or restarts a timer. Restarting a timer causes the a sleep of initial delay nanoseconds before looping. An timer's parameters may be modified and restarted with this word." } ;\r
+\r
+HELP: stop-timer\r
+{ $values { "timer" timer } }\r
+{ $description "Prevents a timer from calling its quotation again. Has no effect on timers that are not currently running." } ;\r
+\r
+HELP: every\r
+{ $values\r
+ { "quot" quotation } { "interval-duration" duration }\r
+ { "timer" timer } }\r
+{ $description "Creates a timer that calls the quotation repeatedly, using " { $snippet "duration" } " as the frequency. The first call of " { $snippet "quot" } " will happen immediately. If the quotation throws an exception, the timer will stop." }\r
+{ $examples\r
+ { $unchecked-example\r
+ "USING: timers io calendar ;"\r
+ """[ "Hi Buddy." print flush ] 10 seconds every drop"""\r
+ ""\r
+ }\r
+} ;\r
+\r
+HELP: later\r
+{ $values { "quot" quotation } { "delay-duration" duration } { "timer" timer } }\r
+{ $description "Sleeps for " { $snippet "duration" } " and then calls a " { $snippet "quot" } ". The user may cancel the timer before " { $snippet "quot" } " runs. This timer is not repeated." }\r
+{ $examples\r
+ { $unchecked-example\r
+ "USING: timers io calendar ;"\r
+ """[ "Break's over!" print flush ] 15 minutes later drop"""\r
+ ""\r
+ }\r
+} ;\r
+\r
+HELP: delayed-every\r
+{ $values\r
+ { "quot" quotation } { "duration" duration }\r
+ { "timer" timer } }\r
+{ $description "Creates a timer that calls " { $snippet "quot" } " repeatedly, waiting " { $snippet "duration" } " before calling " { $snippet "quot" } " the first time and then waiting " { $snippet "duration" } " between further calls. If the quotation throws an exception, the timer will stop." }\r
+{ $examples\r
+ { $unchecked-example\r
+ "USING: timers io calendar ;"\r
+ """[ "Hi Buddy." print flush ] 10 seconds every drop"""\r
+ ""\r
+ }\r
+} ;\r
+\r
+ARTICLE: "timers" "Alarms"\r
+"The " { $vocab-link "timers" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks. Alarms run in a single green thread per timer and consist of a quotation, a delay duration, and an interval duration. After starting a timer, the timer thread sleeps for the delay duration and calls the quotation. Then it waits out the interval duration and calls the quotation again until something stops the timer. If a recurring timer's quotation would be scheduled to run again before the previous quotation has finished processing, the timer will be run again immediately afterwards. This may result in the timer falling behind indefinitely, in which case the it will run as often as possible while still allowing other green threads to run. Recurring timers that execute 'on time' or 'catch up' will always be scheduled for an exact multiple of the interval from the original starting time to prevent the timer from drifting over time. Alarms use " { $link nano-count } " as the timing primitive, so they will continue to work across system clock changes." $nl\r
+"The timer class:"\r
+{ $subsections timer }\r
+"Create a timer before starting it:"\r
+{ $subsections <timer> }\r
+"Starting a timer:"\r
+{ $subsections start-timer restart-timer }\r
+"Stopping a timer:"\r
+{ $subsections stop-timer }\r
+\r
+"A recurring timer without an initial delay:"\r
+{ $subsections every }\r
+"A one-time timer with an initial delay:"\r
+{ $subsections later }\r
+"A recurring timer with an initial delay:"\r
+{ $subsections delayed-every } ;\r
+\r
+ABOUT: "timers"\r
--- /dev/null
+USING: timers timers.private calendar concurrency.count-downs\r
+concurrency.promises fry kernel math math.order sequences\r
+threads tools.test tools.time ;\r
+IN: timers.tests\r
+\r
+[ ] [\r
+ 1 <count-down>\r
+ { f } clone 2dup\r
+ [ first stop-timer count-down ] 2curry 1 seconds later\r
+ swap set-first\r
+ await\r
+] unit-test\r
+\r
+[ ] [\r
+ self [ resume ] curry instant later drop\r
+ "test" suspend drop\r
+] unit-test\r
+\r
+[ t ] [\r
+ [\r
+ <promise>\r
+ [ '[ t _ fulfill ] 2 seconds later drop ]\r
+ [ 5 seconds ?promise-timeout drop ] bi\r
+ ] benchmark 1,500,000,000 2,500,000,000 between?\r
+] unit-test\r
+\r
+[ { 3 } ] [\r
+ { 3 } dup\r
+ '[ 4 _ set-first ] 2 seconds later\r
+ 1/2 seconds sleep\r
+ stop-timer\r
+] unit-test\r
+\r
+[ { 1 } ] [\r
+ { 0 }\r
+ dup '[ 0 _ [ 1 + ] change-nth ] 3 seconds later\r
+ [ stop-timer ] [ start-timer ] bi\r
+ 4 seconds sleep\r
+] unit-test\r
+\r
+[ { 0 } ] [\r
+ { 0 }\r
+ dup '[ 3 seconds sleep 1 _ set-first ] 1 seconds later\r
+ 2 seconds sleep stop-timer\r
+ 1/2 seconds sleep\r
+] unit-test\r
+\r
+[ { 0 } ] [\r
+ { 0 }\r
+ dup '[ 1 _ set-first ] 300 milliseconds later\r
+ 150 milliseconds sleep\r
+ [ restart-timer ] [ 200 milliseconds sleep stop-timer ] bi\r
+] unit-test\r
+\r
+[ { 1 } ] [\r
+ { 0 }\r
+ dup '[ 0 _ [ 1 + ] change-nth ] 200 milliseconds later\r
+ 100 milliseconds sleep restart-timer 300 milliseconds sleep\r
+] unit-test\r
+\r
+[ { 4 } ] [\r
+ { 0 }\r
+ dup '[ 0 _ [ 1 + ] change-nth ] 300 milliseconds 300 milliseconds\r
+ <timer> dup start-timer\r
+ 700 milliseconds sleep dup restart-timer\r
+ 700 milliseconds sleep stop-timer 500 milliseconds sleep\r
+] unit-test\r
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs calendar combinators.short-circuit fry
+heaps init kernel math math.functions math.parser namespaces
+quotations sequences system threads ;
+IN: timers
+
+TUPLE: timer
+ { quot callable initial: [ ] }
+ start-nanos
+ delay-nanos
+ interval-nanos
+ iteration-start-nanos
+ quotation-running?
+ restart?
+ thread ;
+
+<PRIVATE
+
+GENERIC: >nanoseconds ( obj -- duration/f )
+M: f >nanoseconds ;
+M: real >nanoseconds >integer ;
+M: duration >nanoseconds duration>nanoseconds >integer ;
+
+: set-next-timer-time ( timer -- timer )
+ ! start + delay + ceiling((now - (start + delay)) / interval) * interval
+ nano-count
+ over start-nanos>> -
+ over delay-nanos>> [ - ] when*
+ over interval-nanos>> / ceiling
+ over interval-nanos>> *
+ over start-nanos>> +
+ over delay-nanos>> [ + ] when*
+ >>iteration-start-nanos ;
+
+: stop-timer? ( timer -- ? )
+ { [ thread>> self eq? not ] [ restart?>> ] } 1|| ;
+
+DEFER: call-timer-loop
+
+: loop-timer ( timer -- )
+ nano-count over
+ [ iteration-start-nanos>> - ] [ interval-nanos>> ] bi <
+ [ set-next-timer-time ] dip
+ [ dup iteration-start-nanos>> ] [ 0 ] if
+ 0 or sleep-until call-timer-loop ;
+
+: maybe-loop-timer ( timer -- )
+ dup { [ stop-timer? ] [ interval-nanos>> not ] } 1||
+ [ drop ] [ loop-timer ] if ;
+
+: call-timer-loop ( timer -- )
+ dup stop-timer? [
+ drop
+ ] [
+ [
+ [ t >>quotation-running? drop ]
+ [ quot>> call( -- ) ]
+ [ f >>quotation-running? drop ] tri
+ ] keep
+ maybe-loop-timer
+ ] if ;
+
+: sleep-delay ( timer -- )
+ dup stop-timer? [
+ drop
+ ] [
+ nano-count >>start-nanos
+ delay-nanos>> [ sleep ] when*
+ ] if ;
+
+: timer-loop ( timer -- )
+ [ sleep-delay ]
+ [ nano-count >>iteration-start-nanos call-timer-loop ]
+ [ dup restart?>> [ f >>restart? timer-loop ] [ drop ] if ] tri ;
+
+PRIVATE>
+
+: <timer> ( quot delay-duration/f interval-duration/f -- timer )
+ timer new
+ swap >nanoseconds >>interval-nanos
+ swap >nanoseconds >>delay-nanos
+ swap >>quot ; inline
+
+: start-timer ( timer -- )
+ [
+ '[ _ timer-loop ] "Alarm execution" spawn
+ ] keep thread<< ;
+
+: stop-timer ( timer -- )
+ dup quotation-running?>> [
+ f >>thread drop
+ ] [
+ [ [ interrupt ] when* f ] change-thread drop
+ ] if ;
+
+: restart-timer ( timer -- )
+ t >>restart?
+ dup quotation-running?>> [
+ drop
+ ] [
+ dup thread>> [ nip interrupt ] [ start-timer ] if*
+ ] if ;
+
+<PRIVATE
+
+: (start-timer) ( quot start-duration interval-duration -- timer )
+ <timer> [ start-timer ] keep ;
+
+PRIVATE>
+
+: every ( quot interval-duration -- timer )
+ [ f ] dip (start-timer) ;
+
+: later ( quot delay-duration -- timer )
+ f (start-timer) ;
+
+: delayed-every ( quot duration -- timer )
+ dup (start-timer) ;
+
+: nanos-since ( nano-count -- nanos )
+ [ nano-count ] dip - ;
HELP: deploy-threads?
{ $description "Deploy flag. If set, thread support will be included in the final image."
$nl
-"On by default. Most programs depend on libraries which use threads even if they don't use threads directly; for example, alarms, non-blocking I/O, and the UI are built on top of threads. If after testing your program still works without threads, you can disable this feature to save some space." } ;
+"On by default. Most programs depend on libraries which use threads even if they don't use threads directly; for example, timers, non-blocking I/O, and the UI are built on top of threads. If after testing your program still works without threads, you can disable this feature to save some space." } ;
HELP: deploy-ui?
{ $description "Deploy flag. If set, the Factor UI will be included in the deployed image."
strip-io? [ io-backend , ] when
{ } {
- "alarms"
+ "timers"
"tools"
"io.launcher"
"random"
f <model> (error-list-model) set-global
(error-list-model) get-global 100 milliseconds <delay> error-list-model set-global
updater add-error-observer
-] "ui.tools.error-list" add-startup-hook
-
+] "tools.errors.model" add-startup-hook
vocabs.loader vocabs.metadata io combinators calendar accessors
math.parser io.streams.string ui.tools.operations quotations
strings arrays prettyprint words vocabs sorting sets classes
-math alien urls splitting ascii combinators.short-circuit alarms
+math alien urls splitting ascii combinators.short-circuit timers
words.symbol system summary ;
IN: tools.scaffold
<PRIVATE
-: vocab-root? ( string -- ? ) vocab-roots get member? ;
+: vocab-root? ( string -- ? )
+ trim-tail-separators
+ vocab-roots get member? ;
: contains-dot? ( string -- ? ) ".." swap subseq? ;
{ "ch" "a character" }
{ "word" word }
{ "array" array }
- { "alarm" alarm }
+ { "timers" timer }
{ "duration" duration }
{ "path" "a pathname string" }
{ "vocab" "a vocabulary specifier" }
{ $values { "quot" quotation } }
{ $description "Runs a quotation, gathering statistics about method dispatch and garbage collection, and then prints the total run time." } ;
-{ benchmark system-micros time } related-words
+{ benchmark time } related-words
HELP: collect-gc-events
{ $values { "quot" quotation } { "gc-events" "a sequence of " { $link gc-event } " instances" } }
}
: validate-action ( world selector -- ? validated? )
- selector>action at
- [ swap world-focus parents-handle-gesture? t ] [ drop f f ] if* ;
+ selector>action at
+ [ swap world-focus parents-handle-gesture? t ] [ drop f f ] if* ;
CLASS: {
{ +superclass+ "NSOpenGLView" }
]
}
-! "rotateWithEvent:" void { id SEL id }}
-
{ "acceptsFirstResponder" char { id SEL }
[ 2drop 1 ]
}
{ "dealloc" void { id SEL }
[
drop
- [ unregister-window ]
[ remove-observer ]
[ SUPER-> dealloc ]
- tri
+ bi
]
} ;
[
forget-rollover
2nip -> object -> contentView
- dup -> isInFullScreenMode zero?
- [ window unfocus-world ]
+ dup -> isInFullScreenMode 0 =
+ [ window [ unfocus-world ] when* ]
[ drop ] if
]
}
{ "windowWillClose:" void { id SEL id }
[
- 2nip -> object -> contentView window ungraft
+ 2nip -> object -> contentView
+ [ window ungraft ] [ unregister-window ] bi
]
} ;
[ [ execute( -- wm ) add-wm-handler ] with each ]
[ wm-handlers get-global set-at ] if ;
+: remove-wm-handler ( wm -- )
+ wm-handlers get-global delete-at ;
+
[ handle-wm-close 0 ] WM_CLOSE add-wm-handler
[ 4dup handle-wm-paint DefWindowProc ] WM_PAINT add-wm-handler
! Copyright (C) 2006, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alarms arrays assocs calendar colors.constants
+USING: accessors timers arrays assocs calendar colors.constants
combinators combinators.short-circuit documents
documents.elements fry grouping kernel locals make math
math.functions math.order math.ranges math.rectangles
TUPLE: editor < line-gadget
caret-color
caret mark
-focused? blink blink-alarm ;
+focused? blink blink-timer ;
<PRIVATE
750 milliseconds blink-interval set-global
: stop-blinking ( editor -- )
- blink-alarm>> [ stop-alarm ] when* ;
+ blink-timer>> [ stop-timer ] when* ;
: start-blinking ( editor -- )
t >>blink
- blink-alarm>> [ restart-alarm ] when* ;
+ blink-timer>> [ restart-timer ] when* ;
: restart-blinking ( editor -- )
dup focused?>> [
[ dup mark>> activate-editor-model ]
[
[
- '[ _ blink-caret ] blink-interval get dup <alarm>
- ] keep blink-alarm<<
+ '[ _ blink-caret ] blink-interval get dup <timer>
+ ] keep blink-timer<<
] tri ;
M: editor ungraft*
- [ [ stop-blinking ] [ f >>blink-alarm drop ] bi ]
+ [ [ stop-blinking ] [ f >>blink-timer drop ] bi ]
[ dup caret>> deactivate-editor-model ]
[ dup mark>> deactivate-editor-model ] tri ;
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs continuations kernel math models
-namespaces opengl opengl.textures sequences io colors combinators
-combinators.short-circuit fry math.vectors math.rectangles cache
-ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
-ui.pixel-formats destructors literals strings ;
+USING: accessors arrays assocs cache colors combinators
+combinators.short-circuit concurrency.promises continuations
+destructors fry io kernel literals math math.rectangles
+math.vectors models namespaces opengl opengl.textures sequences
+strings ui.backend ui.gadgets ui.gadgets.tracks ui.gestures
+ui.pixel-formats ui.render ;
IN: ui.gadgets.worlds
SYMBOLS:
window-loc
pixel-format-attributes
background-color
+ promise
window-controls
window-resources ;
f >>active?
{ 0 0 } >>window-loc
f >>grab-input?
- V{ } clone >>window-resources ;
+ V{ } clone >>window-resources
+ <promise> >>promise ;
: initial-background-color ( attributes -- color )
window-controls>> textured-background swap member-eq?
{ $var-description "Global variable. The mouse button most recently pressed." } ;
HELP: hand-last-time
-{ $var-description "Global variable. The timestamp of the most recent mouse button click. This timestamp has the same format as the output value of " { $link system-micros } "." } ;
+{ $var-description "Global variable. The timestamp of the most recent mouse button click. This timestamp has the same format as the output value of " { $link nano-count } "." } ;
HELP: hand-buttons
{ $var-description "Global variable. A vector of mouse buttons currently held down." } ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs kernel math math.order models
namespaces make sequences words strings system hashtables math.parser
-math.vectors classes.tuple classes boxes calendar alarms combinators
+math.vectors classes.tuple classes boxes calendar timers combinators
sets columns fry deques ui.gadgets ui.gadgets.private ascii
combinators.short-circuit ;
FROM: namespaces => set ;
[ drag-gesture ]
300 milliseconds
100 milliseconds
- <alarm>
+ <timer>
[ drag-timer get-global >box ]
- [ start-alarm ] bi
+ [ start-timer ] bi
] when ;
: stop-drag-timer ( -- )
hand-buttons get-global empty? [
drag-timer get-global ?box
- [ stop-alarm ] [ drop ] if
+ [ stop-timer ] [ drop ] if
] when ;
: fire-motion ( -- )
error-list-model get-global [ drop all-errors ] <arrow>
<error-list-gadget> ;
+[ \ error-list-gadget reset-memoized ] "ui.tools.error-list" add-startup-hook
+
: show-error-list ( -- )
[ error-list-gadget eq? ] find-window
[ raise-window ] [ error-list-gadget "Errors" open-status-window ] if* ;
-! Copyright (C) 2006, 2009 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors continuations kernel models namespaces arrays
-fry prettyprint ui ui.commands ui.gadgets ui.gadgets.labeled assocs
+fry prettyprint sequences inspector models.arrow fonts ui
+ui.commands ui.gadgets ui.gadgets.labeled assocs
ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes
ui.gadgets.status-bar ui.gadgets.scrollers ui.gadgets.borders
-ui.gadgets.tables ui.gestures sequences inspector
-models.arrow fonts ;
+ui.gadgets.tables ui.gestures ui.tools.common ;
QUALIFIED-WITH: ui.tools.inspector i
IN: ui.tools.traceback
: <retainstack-display> ( model -- gadget )
[ retain>> ] "Retain stack" <stack-display> ;
-TUPLE: traceback-gadget < track ;
+TUPLE: traceback-gadget < tool ;
: <traceback-gadget> ( model -- gadget )
[
! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs boxes io kernel math models namespaces make
-dlists deques sequences threads words continuations init
-combinators combinators.short-circuit hashtables
-concurrency.flags sets accessors calendar fry destructors
-ui.gadgets ui.gadgets.private ui.gadgets.worlds
-ui.gadgets.tracks ui.gestures ui.backend ui.render strings
-classes.tuple classes.tuple.parser lexer vocabs.parser parser ;
+USING: accessors arrays assocs boxes classes.tuple
+classes.tuple.parser combinators combinators.short-circuit
+concurrency.flags concurrency.promises continuations deques
+destructors dlists fry init kernel lexer make math namespaces
+parser sequences sets strings threads ui.backend ui.gadgets
+ui.gadgets.private ui.gadgets.worlds ui.gestures vocabs.parser
+words ;
IN: ui
<PRIVATE
[ [ <reversed> [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ]
[ [ (close-window) f ] change-handle drop ]
[ unfocus-world ]
+ [ promise>> t swap fulfill ]
} cleave ;
: init-ui ( -- )
FUNCTION: int getgrgid_r ( gid_t gid, group* grp, c-string buffer, size_t bufsize, group** result ) ;
FUNCTION: int getgrnam_r ( c-string name, group* grp, c-string buffer, size_t bufsize, group** result ) ;
FUNCTION: passwd* getpwent ( ) ;
+FUNCTION: void setpwent ( ) ;
+FUNCTION: void setpassent ( int stayopen ) ;
FUNCTION: passwd* getpwuid ( uid_t uid ) ;
FUNCTION: passwd* getpwnam ( c-string login ) ;
FUNCTION: int getpwnam_r ( c-string login, passwd* pwd, c-string buffer, size_t bufsize, passwd** result ) ;
FUNCTION: int setpriority ( int which, id_t who, int prio ) ;
FUNCTION: int getrusage ( int who, rusage* r_usage ) ;
FUNCTION: group* getgrent ;
+FUNCTION: void endgrent ( ) ;
FUNCTION: int gethostname ( c-string name, int len ) ;
FUNCTION: int getsockname ( int socket, sockaddr* address, socklen_t* address_len ) ;
FUNCTION: int getpeername ( int socket, sockaddr* address, socklen_t* address_len ) ;
FUNCTION: ushort htons ( ushort n ) ;
! FUNCTION: int issetugid ;
FUNCTION: int isatty ( int fildes ) ;
-FUNCTION: int ioctl ( int fd, ulong request, c-string argp ) ;
+FUNCTION: int ioctl ( int fd, ulong request, void* argp ) ;
FUNCTION: int lchown ( c-string path, uid_t owner, gid_t group ) ;
FUNCTION: int listen ( int s, int backlog ) ;
FUNCTION: off_t lseek ( int fildes, off_t offset, int whence ) ;
HELP: with-effective-group
{ $values
- { "string/id" "a string or a group id" } { "quot" quotation } }
-{ $description "Sets the effective group name and calls the quotation. Restors the effective group name on success or on error after the call." } ;
+ { "string/id/f" "a string, a group id, or f" } { "quot" quotation } }
+{ $description "Sets the effective group name and calls the quotation. Restors the effective group name on success or on error after the call. If the first parameter is " { $link f } ", the quotation is called as the current user." } ;
HELP: with-group-cache
{ $values
HELP: with-real-group
{ $values
- { "string/id" "a string or a group id" } { "quot" quotation } }
-{ $description "Sets the real group name and calls the quotation. Restores the current group name on success or on error after the call." } ;
+ { "string/id/f" "a string or a group id" } { "quot" quotation } }
+{ $description "Sets the real group name and calls the quotation. Restores the current group name on success or on error after the call. If the first parameter is " { $link f } ", the quotation is called as the current user." } ;
+
+HELP: ?group-id
+{ $values
+ { "string" string }
+ { "id" "a group id" }
+}
+{ $description "Returns a group id or throws an exception." } ;
+
+HELP: all-group-names
+{ $values
+
+ { "seq" sequence }
+}
+{ $description "Returns a sequence of group names as strings." } ;
+
+HELP: group-exists?
+{ $values
+ { "name/id" "a name or a group id" }
+ { "?" boolean }
+}
+{ $description "Returns a boolean representing the group's existence." } ;
ARTICLE: "unix.groups" "Unix groups"
"The " { $vocab-link "unix.groups" } " vocabulary contains words that return information about Unix groups."
$nl
-"Listing all groups:"
+"Listing all group structures:"
{ $subsections all-groups }
-"Real groups:"
+"Listing all group names:"
+{ $subsections all-group-names }
+"Checking if a group exists:"
+{ $subsections group-exists? }
+"Querying/setting the current real group:"
{ $subsections
real-group-name
real-group-id
set-real-group
}
-"Effective groups:"
+"Querying/setting the current effective group:"
{ $subsections
effective-group-name
effective-group-id
set-effective-group
}
+"Getting a group id from a group name or id:"
+{ $subsections
+ ?group-id
+}
"Combinators to change groups:"
{ $subsections
with-real-group
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test unix.groups kernel strings math ;
+USING: kernel math sequences strings tools.test unix.groups ;
IN: unix.groups.tests
[ ] [ all-groups drop ] unit-test
[ ] [ real-group-id group-name drop ] unit-test
[ "888888888888888" ] [ 888888888888888 group-name ] unit-test
+[ f ] [ "please-oh-please-don't-have-a-group-named-this123lalala" group-struct ] unit-test
+[ f ] [ "please-oh-please-don't-have-a-group-named-this123lalala" group-exists? ] unit-test
+[ "please-oh-please-don't-have-a-group-named-this123lalala" ?group-id ] must-fail
+
+[ 3 ] [ f [ 3 ] with-effective-group ] unit-test
+[ 3 ] [ f [ 3 ] with-real-group ] unit-test
+
+[ f ]
+[ all-groups drop all-groups empty? ] unit-test
+
[ f ]
-[ "please-oh-please-don't-have-a-group-named-this123lalala" group-struct ] unit-test
+[ all-group-names drop all-group-names empty? ] unit-test
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings io.encodings.utf8
-io.backend.unix kernel math sequences splitting strings
-combinators.short-circuit byte-arrays combinators
-accessors math.parser fry assocs namespaces continuations
-unix.users unix.utilities classes.struct unix ;
-IN: unix.groups
-
+USING: accessors alien alien.c-types alien.strings assocs
+byte-arrays classes.struct combinators
+combinators.short-circuit continuations fry io.backend.unix
+io.encodings.utf8 kernel math math.parser namespaces sequences
+splitting strings unix unix.ffi unix.users unix.utilities ;
QUALIFIED: unix.ffi
-
QUALIFIED: grouping
+IN: unix.groups
TUPLE: group id name passwd members ;
: group-id ( string -- id/f )
group-struct dup [ gr_gid>> ] when ;
+ERROR: no-group string ;
+
+: ?group-id ( string -- id )
+ dup group-struct [ nip gr_gid>> ] [ no-group ] if* ;
+
<PRIVATE
: >groups ( byte-array n -- groups )
user-name (user-groups) ;
: all-groups ( -- seq )
- [ unix.ffi:getgrent dup ] [ group-struct>group ] produce nip ;
+ [ unix.ffi:getgrent dup ] [ group-struct>group ] produce nip
+ endgrent ;
+
+: all-group-names ( -- seq )
+ all-groups [ name>> ] map ;
: <group-cache> ( -- assoc )
all-groups [ [ id>> ] keep ] H{ } map>assoc ;
: effective-group-name ( -- string )
effective-group-id group-name ; inline
+: group-exists? ( name/id -- ? ) group-id >boolean ;
+
GENERIC: set-real-group ( obj -- )
GENERIC: set-effective-group ( obj -- )
-: with-real-group ( string/id quot -- )
+: (with-real-group) ( string/id quot -- )
'[ _ set-real-group @ ]
real-group-id '[ _ set-real-group ] [ ] cleanup ; inline
-: with-effective-group ( string/id quot -- )
+: with-real-group ( string/id/f quot -- )
+ over [ (with-real-group) ] [ nip call ] if ; inline
+
+: (with-effective-group) ( string/id quot -- )
'[ _ set-effective-group @ ]
effective-group-id '[ _ set-effective-group ] [ ] cleanup ; inline
+: with-effective-group ( string/id/f quot -- )
+ over [ (with-effective-group) ] [ nip call ] if ; inline
+
<PRIVATE
: (set-real-group) ( id -- )
PRIVATE>
-M: string set-real-group ( string -- )
- group-id (set-real-group) ;
-
M: integer set-real-group ( id -- )
(set-real-group) ;
+M: string set-real-group ( string -- )
+ ?group-id (set-real-group) ;
+
M: integer set-effective-group ( id -- )
(set-effective-group) ;
M: string set-effective-group ( string -- )
- group-id (set-effective-group) ;
+ ?group-id (set-effective-group) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel alien.syntax alien.c-types math unix.types
-classes.struct accessors ;
+USING: accessors alien.c-types alien.syntax
+classes.struct kernel math unix.types ;
IN: unix.time
STRUCT: timeval
swap >>nsec
swap >>sec ;
+STRUCT: timezone
+ { tz_minuteswest int }
+ { tz_dsttime int } ;
+
STRUCT: tm
{ sec int }
{ min int }
FUNCTION: time_t time ( time_t* t ) ;
FUNCTION: tm* localtime ( time_t* clock ) ;
FUNCTION: int gettimeofday ( timespec* TP, void* TZP ) ;
+FUNCTION: int settimeofday ( timeval* TP, timezone* TZP ) ;
+FUNCTION: int adjtime ( timeval* delta, timeval* olddelta ) ;
{ freebsd [ "unix.types.freebsd" require ] }
{ openbsd [ "unix.types.openbsd" require ] }
{ netbsd [ "unix.types.netbsd" require ] }
- { winnt [ ] }
} case
-
HELP: with-effective-user
{ $values
- { "string/id" "a string or a uid" } { "quot" quotation } }
-{ $description "Sets the effective user-name and calls the quotation. Restores the current user-name on success or on error after the call." } ;
+ { "string/id/f" "a string, a uid, or f" } { "quot" quotation } }
+{ $description "Sets the effective user-name and calls the quotation. Restores the current user-name on success or on error after the call. If the first parameter is " { $link f } ", the quotation is called as the current user." } ;
HELP: with-user-cache
{ $values
HELP: with-real-user
{ $values
- { "string/id" "a string or a uid" } { "quot" quotation } }
-{ $description "Sets the real user-name and calls the quotation. Restores the current user-name on success or on error after the call." } ;
+ { "string/id/f" "a string, a uid, or f" } { "quot" quotation } }
+{ $description "Sets the real user-name and calls the quotation. Restores the current user-name on success or on error after the call. If the first parameter is " { $link f } ", the quotation is called as the current user." } ;
{
real-user-name real-user-id set-real-user
set-effective-user
} related-words
+HELP: ?user-id
+{ $values
+ { "string" string }
+ { "id/f" "an integer or " { $link f } }
+}
+{ $description "Returns a group id or throws an exception." } ;
+
+HELP: all-user-names
+{ $values
+
+ { "seq" sequence }
+}
+{ $description "Returns a sequence of group names as strings." } ;
+
+HELP: user-exists?
+{ $values
+ { "name/id" "a string or an integer" }
+ { "?" boolean }
+}
+{ $description "Returns a boolean representing the user's existence." } ;
+
ARTICLE: "unix.users" "Unix users"
"The " { $vocab-link "unix.users" } " vocabulary contains words that return information about Unix users."
$nl
"Listing all users:"
{ $subsections all-users }
-"Real user:"
+"Listing all user names:"
+{ $subsections all-user-names }
+"Checking if a user exists:"
+{ $subsections user-exists? }
+"Querying/setting the current real user:"
{ $subsections
real-user-name
real-user-id
set-real-user
}
-"Effective user:"
+"Querying/setting the current effective user:"
{ $subsections
effective-user-name
effective-user-id
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test unix.users kernel strings math ;
+USING: tools.test unix.users kernel strings math sequences ;
IN: unix.users.tests
[ ] [ all-users drop ] unit-test
[ f ] [ 89898989898989898989898989898 user-passwd ] unit-test
[ f ] [ "thisusershouldnotexistabcdefg12345asdfasdfasdfasdfasdfasdfasdf" user-id ] unit-test
+[ f ] [ "thisusershouldnotexistabcdefg12345asdfasdfasdfasdfasdfasdfasdf" user-exists? ] unit-test
+[ "thisusershouldnotexistabcdefg12345asdfasdfasdfasdfasdfasdfasdf" ?user-id ] must-fail
+
+[ 3 ] [ f [ 3 ] with-effective-user ] unit-test
+[ 3 ] [ f [ 3 ] with-real-user ] unit-test
+
+[ f ]
+[ all-users drop all-users empty? ] unit-test
+
+[ f ]
+[ all-user-names drop all-user-names empty? ] unit-test
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings io.encodings.utf8
-io.backend.unix kernel math sequences splitting strings
-combinators.short-circuit grouping byte-arrays combinators
-accessors math.parser fry assocs namespaces continuations
-vocabs.loader system classes.struct unix ;
-IN: unix.users
+USING: accessors alien alien.c-types alien.strings assocs
+byte-arrays classes.struct combinators
+combinators.short-circuit continuations fry grouping
+io.backend.unix io.encodings.utf8 kernel math math.parser
+namespaces sequences splitting strings system unix unix.ffi
+vocabs.loader ;
QUALIFIED: unix.ffi
+IN: unix.users
TUPLE: passwd user-name password uid gid gecos dir shell ;
} cleave ;
: with-pwent ( quot -- )
+ setpwent
[ unix.ffi:endpwent ] [ ] cleanup ; inline
PRIVATE>
[ unix.ffi:getpwent dup ] [ passwd>new-passwd ] produce nip
] with-pwent ;
+: all-user-names ( -- seq )
+ all-users [ user-name>> ] map ;
+
SYMBOL: user-cache
: <user-cache> ( -- assoc )
: user-id ( string -- id/f )
user-passwd dup [ uid>> ] when ;
+ERROR: no-user string ;
+
+: ?user-id ( string -- id/f )
+ dup user-passwd [ nip uid>> ] [ no-user ] if* ;
+
: real-user-id ( -- id )
unix.ffi:getuid ; inline
: effective-user-name ( -- string )
effective-user-id user-name ; inline
+: user-exists? ( name/id -- ? ) user-id >boolean ;
+
GENERIC: set-real-user ( string/id -- )
GENERIC: set-effective-user ( string/id -- )
-: with-real-user ( string/id quot -- )
+: (with-real-user) ( string/id quot -- )
'[ _ set-real-user @ ]
real-user-id '[ _ set-real-user ]
[ ] cleanup ; inline
-: with-effective-user ( string/id quot -- )
+: with-real-user ( string/id/f quot -- )
+ over [ (with-real-user) ] [ nip call ] if ; inline
+
+: (with-effective-user) ( string/id quot -- )
'[ _ set-effective-user @ ]
effective-user-id '[ _ set-effective-user ]
[ ] cleanup ; inline
+: with-effective-user ( string/id/f quot -- )
+ over [ (with-effective-user) ] [ nip call ] if ; inline
+
<PRIVATE
: (set-real-user) ( id -- )
PRIVATE>
-M: string set-real-user ( string -- )
- user-id (set-real-user) ;
-
M: integer set-real-user ( id -- )
(set-real-user) ;
+M: string set-real-user ( string -- )
+ ?user-id (set-real-user) ;
+
M: integer set-effective-user ( id -- )
(set-effective-user) ;
M: string set-effective-user ( string -- )
- user-id (set-effective-user) ;
+ ?user-id (set-effective-user) ;
os {
{ [ dup bsd? ] [ drop "unix.users.bsd" require ] }
! Copyright (C) 2008 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
-USING: byte-arrays checksums checksums.md5 checksums.sha
-kernel math math.parser math.ranges random unicode.case
-sequences strings system io.binary ;
-
-IN: uuid
+USING: byte-arrays calendar checksums checksums.md5
+checksums.sha io.binary kernel math math.parser math.ranges
+random sequences strings system unicode.case ;
+IN: uuid
<PRIVATE
! 0x01b21dd213814000L is the number of 100-ns intervals
! between the UUID epoch 1582-10-15 00:00:00 and the
! Unix epoch 1970-01-01 00:00:00.
- system-micros 10 * HEX: 01b21dd213814000 +
+ gmt timestamp>micros 10 * HEX: 01b21dd213814000 +
[ -48 shift HEX: 0fff bitand ]
[ -32 shift HEX: ffff bitand ]
[ HEX: ffffffff bitand ]
! FUNCTION: SetProcessWorkingSetSize
! FUNCTION: SetStdHandle
! FUNCTION: SetSystemPowerState
-! FUNCTION: SetSystemTime
+FUNCTION: BOOL SetSystemTime ( SYSTEMTIME* lpSystemTime ) ;
! FUNCTION: SetSystemTimeAdjustment
! FUNCTION: SetTapeParameters
! FUNCTION: SetTapePosition
3array
4array
}
+"Resizing arrays:"
+{ $subsections resize-array }
"The class of two-element arrays:"
{ $subsections pair }
"Arrays can be accessed without bounds checks in a pointer unsafe way."
{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "array" array } }
{ $description "Create a new array with four elements, with " { $snippet "w" } " appearing first." } ;
-HELP: resize-array ( n array -- newarray )
-{ $values { "n" "a non-negative integer" } { "array" array } { "newarray" "a new array" } }
-{ $description "Creates a new array of " { $snippet "n" } " elements. The contents of the existing array are copied into the new array; if the new array is shorter, only an initial segment is copied, and if the new array is longer the remaining space is filled in with "{ $link f } "." } ;
+HELP: resize-array ( n array -- new-array )
+{ $values { "n" "a non-negative integer" } { "array" array } { "new-array" array } }
+{ $description "Resizes the array to have a length of " { $snippet "n" } " elements. When making the array shorter, this word may either create a new array or modify the existing array in place. When making the array longer, this word always allocates a new array, filling remaining space with " { $link f } "." }
+{ $side-effects "array" } ;
HELP: pair
{ $class-description "The class of two-element arrays, known as pairs." } ;
{ "dll-valid?" "alien.libraries" "primitive_dll_validp" (( dll -- ? )) }
{ "current-callback" "alien.private" "primitive_current_callback" (( -- n )) }
{ "<array>" "arrays" "primitive_array" (( n elt -- array )) }
- { "resize-array" "arrays" "primitive_resize_array" (( n array -- newarray )) }
+ { "resize-array" "arrays" "primitive_resize_array" (( n array -- new-array )) }
{ "(byte-array)" "byte-arrays" "primitive_uninitialized_byte_array" (( n -- byte-array )) }
{ "<byte-array>" "byte-arrays" "primitive_byte_array" (( n -- byte-array )) }
- { "resize-byte-array" "byte-arrays" "primitive_resize_byte_array" (( n byte-array -- newbyte-array )) }
+ { "resize-byte-array" "byte-arrays" "primitive_resize_byte_array" (( n byte-array -- new-byte-array )) }
{ "<tuple-boa>" "classes.tuple.private" "primitive_tuple_boa" (( slots... layout -- tuple )) }
{ "<tuple>" "classes.tuple.private" "primitive_tuple" (( layout -- tuple )) }
{ "modify-code-heap" "compiler.units" "primitive_modify_code_heap" (( alist update-existing? reset-pics? -- )) }
{ "set-string-nth-fast" "strings.private" "primitive_set_string_nth_fast" (( ch n string -- )) }
{ "(exit)" "system" "primitive_exit" (( n -- * )) }
{ "nano-count" "system" "primitive_nano_count" (( -- ns )) }
- { "system-micros" "system" "primitive_system_micros" (( -- us )) }
{ "(sleep)" "threads.private" "primitive_sleep" (( nanos -- )) }
{ "callstack-for" "threads.private" "primitive_callstack_for" (( context -- array )) }
{ "context-object-for" "threads.private" "primitive_context_object_for" (( n context -- obj )) }
3byte-array
4byte-array
}
-"Resizing byte-arrays:"
+"Resizing byte arrays:"
{ $subsections resize-byte-array } ;
ABOUT: "byte-arrays"
{ 1byte-array 2byte-array 3byte-array 4byte-array } related-words
-HELP: resize-byte-array ( n byte-array -- newbyte-array )
-{ $values { "n" "a non-negative integer" } { "byte-array" byte-array }
- { "newbyte-array" byte-array } }
-{ $description "Creates a new byte-array of n elements. The contents of the existing byte-array are copied into the new byte-array; if the new byte-array is shorter, only an initial segment is copied, and if the new byte-array is longer the remaining space is filled in with 0." } ;
+HELP: resize-byte-array ( n byte-array -- new-byte-array )
+{ $values { "n" "a non-negative integer" } { "byte-array" byte-array } { "new-byte-array" byte-array } }
+{ $description "Resizes the byte array to have a length of " { $snippet "n" } " elements. When making the byte array shorter, this word may either create a new byte array or modify the existing byte array in place. When making the byte array longer, this word always allocates a new byte array, filling remaining space with zeroes." }
+{ $side-effects "byte-array" } ;
}
"Creating a string from a single character:"
{ $subsections 1string }
+"Resizing strings:"
+{ $subsections resize-string }
{ $see-also "syntax-strings" "sbufs" "unicode" "io.encodings" } ;
ABOUT: "strings"
HELP: resize-string ( n str -- newstr )
{ $values { "n" "a non-negative integer" } { "str" string } { "newstr" string } }
-{ $description "Creates a new string " { $snippet "n" } " characters long The contents of the existing string are copied into the new string; if the new string is shorter, only an initial segment is copied, and if the new string is longer the remaining space is filled with " { $snippet "\\u000000" } "." } ;
+{ $description "Resizes the string to have a length of " { $snippet "n" } " elements. When making the string shorter, this word may either create a new string or modify the existing string in place. When making the string longer, this word always allocates a new string, filling remaining space with zeroes." }
+{ $side-effects "str" } ;
vm
image
}
-"Getting the current time:"
-{ $subsections
- system-micros
-}
"Getting a monotonically increasing nanosecond count:"
{ $subsections nano-count }
"Exiting the Factor VM:"
{ $values { "n" "an integer exit code" } }
{ $description "Exits the Factor process." } ;
-HELP: system-micros ( -- us )
-{ $values { "us" integer } }
-{ $description "Outputs the number of microseconds elapsed since midnight January 1, 1970." }
-{ $notes "This is a low-level word. The " { $vocab-link "calendar" } " vocabulary provides features for date/time arithmetic and formatting. For timing code, use " { $link nano-count } "." } ;
-
HELP: nano-count ( -- ns )
{ $values { "ns" integer } }
{ $description "Outputs a monotonically increasing count of nanoseconds elapsed since an arbitrary starting time. The difference of two calls to this word allows timing. This word is unaffected by system clock changes." }
-{ $notes "This is a low-level word. The " { $vocab-link "tools.time" } " vocabulary defines words to time code execution time. For system time, use " { $link system-micros } "." } ;
+{ $notes "This is a low-level word. The " { $vocab-link "tools.time" } " vocabulary defines words to time code execution time." } ;
HELP: image
{ $values { "path" "a pathname string" } }
] "vocabs.loader" add-startup-hook
: add-vocab-root ( root -- )
+ trim-tail-separators
[ vocab-roots get adjoin ]
[ add-vocab-root-hook get-global call( root -- ) ] bi ;
! (c)2009 Joe Groff bsd license
-USING: accessors alien audio classes.struct fry calendar alarms
+USING: accessors alien audio classes.struct fry calendar timers
combinators combinators.short-circuit destructors generalizations
kernel literals locals math openal sequences
sequences.generalizations specialized-arrays strings ;
listener
{ next-source integer }
clips
- update-alarm ;
+ update-timer ;
TUPLE: audio-clip < disposable
{ audio-engine audio-engine }
: start-audio ( audio-engine -- )
dup start-audio*
- dup '[ _ update-audio ] 20 milliseconds every >>update-alarm
+ dup '[ _ update-audio ] 20 milliseconds every >>update-timer
drop ;
: stop-audio ( audio-engine -- )
dup al-sources>> [
{
[ make-engine-current ]
- [ update-alarm>> [ stop-alarm ] when* ]
+ [ update-timer>> [ stop-timer ] when* ]
[ clips>> clone [ dispose ] each ]
[ al-sources>> free-sources ]
[
f >>al-sources
f >>clips
- f >>update-alarm
+ f >>update-timer
drop
]
[ al-context>> alcSuspendContext ]
! (c)2009 Joe Groff bsd license
-USING: accessors alarms audio audio.engine audio.loader calendar
+USING: accessors timers audio audio.engine audio.loader calendar
destructors io kernel locals math math.functions math.ranges specialized-arrays
sequences random math.vectors ;
FROM: alien.c-types => short ;
] when
engine update-audio
- ] 20 milliseconds every :> alarm
+ ] 20 milliseconds every :> timer
"Press Enter to stop the test." print
readln drop
- alarm stop-alarm
+ timer stop-timer
engine dispose ;
MAIN: audio-engine-test
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types classes.struct kernel memory
+system vm ;
+IN: benchmark.struct
+
+STRUCT: benchmark-data
+ { time ulonglong }
+ { data-room data-heap-room }
+ { code-room mark-sweep-sizes } ;
+
+STRUCT: benchmark-data-pair
+ { start benchmark-data }
+ { stop benchmark-data } ;
+
+: <benchmark-data> ( -- benchmark-data )
+ \ benchmark-data <struct>
+ nano-count >>time
+ code-room >>code-room
+ data-room >>data-room ; inline
+
+: <benchmark-data-pair> ( start stop -- benchmark-data-pair )
+ \ benchmark-data-pair <struct>
+ swap >>stop
+ swap >>start ; inline
+
+: with-benchmarking ( ... quot -- ... benchmark-data-pair )
+ <benchmark-data>
+ [ call ] dip
+ <benchmark-data> <benchmark-data-pair> ; inline
+
--- /dev/null
+Joe Groff
+Doug Coleman
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: accessors arrays assocs calendar calendar.format
+combinators combinators.short-circuit fry io io.backend
+io.directories io.encodings.binary io.encodings.detect
+io.encodings.utf8 io.files io.files.info io.files.types
+io.files.unique io.launcher io.pathnames kernel locals math
+math.parser namespaces sequences sorting strings system
+unicode.categories xml.syntax xml.writer xmode.catalog
+xmode.marker xmode.tokens ;
+IN: codebook
+
+! Usage: "my/source/tree" codebook
+! Writes tree.opf, tree.ncx, and tree.html to a temporary directory
+! Writes tree.mobi to resource:codebooks
+! Requires kindlegen to compile tree.mobi for Kindle
+
+CONSTANT: codebook-style
+ {
+ { COMMENT1 [ [XML <i><font color="#555555"><-></font></i> XML] ] }
+ { COMMENT2 [ [XML <i><font color="#555555"><-></font></i> XML] ] }
+ { COMMENT3 [ [XML <i><font color="#555555"><-></font></i> XML] ] }
+ { COMMENT4 [ [XML <i><font color="#555555"><-></font></i> XML] ] }
+ { DIGIT [ [XML <font color="#333333"><-></font> XML] ] }
+ { FUNCTION [ [XML <b><font color="#111111"><-></font></b> XML] ] }
+ { KEYWORD1 [ [XML <b><font color="#111111"><-></font></b> XML] ] }
+ { KEYWORD2 [ [XML <b><font color="#111111"><-></font></b> XML] ] }
+ { KEYWORD3 [ [XML <b><font color="#111111"><-></font></b> XML] ] }
+ { KEYWORD4 [ [XML <b><font color="#111111"><-></font></b> XML] ] }
+ { LABEL [ [XML <b><font color="#333333"><-></font></b> XML] ] }
+ { LITERAL1 [ [XML <font color="#333333"><-></font> XML] ] }
+ { LITERAL2 [ [XML <font color="#333333"><-></font> XML] ] }
+ { LITERAL3 [ [XML <font color="#333333"><-></font> XML] ] }
+ { LITERAL4 [ [XML <font color="#333333"><-></font> XML] ] }
+ { MARKUP [ [XML <b><font color="#333333"><-></font></b> XML] ] }
+ { OPERATOR [ [XML <b><font color="#111111"><-></font></b> XML] ] }
+ [ drop ]
+ }
+
+: first-line ( filename encoding -- line )
+ [ readln ] with-file-reader ;
+
+TUPLE: code-file
+ name encoding mode ;
+
+: include-file-name? ( name -- ? )
+ {
+ [ path-components [ "." head? ] any? not ]
+ [ link-info type>> +regular-file+ = ]
+ } 1&& ;
+
+: code-files ( dir -- files )
+ '[
+ [ include-file-name? ] filter [
+ dup detect-file dup binary?
+ [ f ] [ 2dup dupd first-line find-mode ] if
+ code-file boa
+ ] map [ mode>> ] filter [ name>> ] sort-with
+ ] with-directory-tree-files ;
+
+: html-name-char ( char -- str )
+ {
+ { [ dup alpha? ] [ 1string ] }
+ { [ dup digit? ] [ 1string ] }
+ [ >hex 6 CHAR: 0 pad-head "_" "_" surround ]
+ } cond ;
+
+: file-html-name ( name -- name )
+ [ html-name-char ] { } map-as concat ".html" append ;
+
+: toc-list ( files -- list )
+ [ name>> ] map natural-sort [
+ [ file-html-name ] keep
+ [XML <li><a href=<->><-></a></li> XML]
+ ] map ;
+
+! insert zero-width non-joiner between all characters so words can wrap anywhere
+: zwnj ( string -- s|t|r|i|n|g )
+ [ CHAR: \u00200c "" 2sequence ] { } map-as concat ;
+
+! We wrap every line in <tt> because Kindle tends to forget the font when
+! moving back pages
+: htmlize-tokens ( tokens line# -- html-tokens )
+ swap [
+ [ str>> zwnj ] [ id>> ] bi codebook-style case
+ ] map [XML <tt><font size="-2" color="#666666"><-></font> <-></tt> XML]
+ "\n" 2array ;
+
+: line#>string ( i line#len -- i-string )
+ [ number>string ] [ CHAR: \s pad-head ] bi* ;
+
+:: code>html ( dir file -- page )
+ file name>> :> name
+ "Generating HTML for " write name write "..." print flush
+ dir [ file [ name>> ] [ encoding>> ] bi file-lines ] with-directory :> lines
+ lines length 1 + number>string length :> line#len
+ file mode>> load-mode :> rules
+ f lines [| l i | l rules tokenize-line i 1 + line#len line#>string htmlize-tokens ]
+ map-index concat nip :> html-lines
+ <XML <html>
+ <head>
+ <title><-name-></title>
+ <meta http-equiv="Content-type" content="text/html; charset=utf-8" />
+ </head>
+ <body>
+ <h2><-name-></h2>
+ <pre><-html-lines-></pre>
+ <mbp:pagebreak xmlns:mbp="http://www.mobipocket.com/mbp" />
+ </body>
+ </html> XML> ;
+
+:: code>toc-html ( dir name files -- html )
+ "Generating HTML table of contents" print flush
+
+ now timestamp>rfc822 :> timestamp
+ dir absolute-path :> source
+ dir [
+ files toc-list :> toc
+
+ <XML <html>
+ <head>
+ <title><-name-></title>
+ <meta http-equiv="Content-type" content="text/html; charset=utf-8" />
+ </head>
+ <body>
+ <h1><-name-></h1>
+ <font size="-2">Generated from<br/>
+ <b><tt><-source-></tt></b><br/>
+ at <-timestamp-></font><br/>
+ <br/>
+ <ul><-toc-></ul>
+ <mbp:pagebreak xmlns:mbp="http://www.mobipocket.com/mbp" />
+ </body>
+ </html> XML>
+ ] with-directory ;
+
+:: code>ncx ( dir name files -- xml )
+ "Generating NCX table of contents" print flush
+
+ files [| file i |
+ file name>> :> name
+ name file-html-name :> filename
+ i 2 + number>string :> istr
+
+ [XML <navPoint class="book" id=<-filename-> playOrder=<-istr->>
+ <navLabel><text><-name-></text></navLabel>
+ <content src=<-filename-> />
+ </navPoint> XML]
+ ] map-index :> file-nav-points
+
+ <XML <?xml version="1.0" encoding="UTF-8" ?>
+ <ncx version="2005-1" xmlns="http://www.daisy.org/z3986/2005/ncx/">
+ <navMap>
+ <navPoint class="book" id="toc" playOrder="1">
+ <navLabel><text>Table of Contents</text></navLabel>
+ <content src="_toc.html" />
+ </navPoint>
+ <-file-nav-points->
+ </navMap>
+ </ncx> XML> ;
+
+:: code>opf ( dir name files -- xml )
+ "Generating OPF manifest" print flush
+ name ".ncx" append :> ncx-name
+
+ files [
+ name>> file-html-name dup
+ [XML <item id=<-> href=<-> media-type="text/html" /> XML]
+ ] map :> html-manifest
+
+ files [ name>> file-html-name [XML <itemref idref=<-> /> XML] ] map :> html-spine
+
+ <XML <?xml version="1.0" encoding="UTF-8" ?>
+ <package
+ version="2.0"
+ xmlns="http://www.idpf.org/2007/opf"
+ unique-identifier=<-name->>
+ <metadata xmlns:dc="http://purl.org/dc/elements/1.1/">
+ <dc:title><-name-></dc:title>
+ <dc:language>en</dc:language>
+ <meta name="cover" content="my-cover-image" />
+ </metadata>
+ <manifest>
+ <item href="cover.jpg" id="my-cover-image" media-type="image/jpeg" />
+ <item id="html-toc" href="_toc.html" media-type="text/html" />
+ <-html-manifest->
+ <item id="toc" href=<-ncx-name-> media-type="application/x-dtbncx+xml" />
+ </manifest>
+ <spine toc="toc">
+ <itemref idref="html-toc" />
+ <-html-spine->
+ </spine>
+ <guide>
+ <reference type="toc" title="Table of Contents" href="_toc.html" />
+ </guide>
+ </package> XML> ;
+
+: write-dest-file ( xml dest-dir name ext -- )
+ append append-path utf8 [ write-xml ] with-file-writer ;
+
+SYMBOL: kindlegen-path
+kindlegen-path [ "kindlegen" ] initialize
+
+SYMBOL: codebook-output-path
+codebook-output-path [ "resource:codebooks" ] initialize
+
+: kindlegen ( path -- )
+ [ kindlegen-path get "-unicode" ] dip 3array try-process ;
+
+: kindle-path ( directory name extension -- path )
+ [ append-path ] dip append ;
+
+:: codebook ( src-dir -- )
+ codebook-output-path get normalize-path :> dest-dir
+
+ "Generating ebook for " write src-dir write " in " write dest-dir print flush
+
+ dest-dir make-directories
+ [
+ current-temporary-directory get :> temp-dir
+ src-dir file-name :> name
+ src-dir code-files :> files
+
+ src-dir name files code>opf
+ temp-dir name ".opf" write-dest-file
+
+ "vocab:codebook/cover.jpg" temp-dir copy-file-into
+
+ src-dir name files code>ncx
+ temp-dir name ".ncx" write-dest-file
+
+ src-dir name files code>toc-html
+ temp-dir "_toc.html" "" write-dest-file
+
+ files [| file |
+ src-dir file code>html
+ temp-dir file name>> file-html-name "" write-dest-file
+ ] each
+
+ temp-dir name ".opf" kindle-path kindlegen
+ temp-dir name ".mobi" kindle-path dest-dir copy-file-into
+
+ dest-dir name ".mobi" kindle-path :> mobi-path
+
+ "Job's finished: " write mobi-path print flush
+ ] cleanup-unique-working-directory ;
] float-array{ } make
mvp-matrix draw-debug-points
- "Frame: " world frame-number>> number>string append
+ "Frame: " world frame#>> number>string append
COLOR: purple { 5 5 } world dim>> draw-text
- world [ 1 + ] change-frame-number drop ;
+ world [ 1 + ] change-frame# drop ;
TUPLE: tests-world < wasd-world frame-number ;
M: tests-world draw-world* draw-debug-tests ;
USING: ui ui.gadgets sequences kernel arrays math colors
colors.constants ui.render ui.pens.polygon ui.pens.solid math.vectors
accessors fry ui.gadgets.packs game.input ui.gadgets.labels
-ui.gadgets.borders alarms calendar locals strings ui.gadgets.buttons
+ui.gadgets.borders timers calendar locals strings ui.gadgets.buttons
combinators math.parser assocs threads ;
IN: game.input.demos.joysticks
COLOR: red <indicator-gadget> [ >>indicator ] [ add-gadget ] bi
dup [ 0.0 0.0 0.0 move-axis ] [ f move-pov ] bi ;
-TUPLE: joystick-demo-gadget < pack axis raxis controller buttons alarm ;
+TUPLE: joystick-demo-gadget < pack axis raxis controller buttons timer ;
: add-gadget-with-border ( parent child -- parent )
{ 2 2 } <border> COLOR: gray <solid> >>boundary add-gadget ;
: kill-update-axes ( gadget -- )
COLOR: gray <solid> >>interior
- [ [ stop-alarm ] when* f ] change-alarm
+ [ [ stop-timer ] when* f ] change-timer
relayout-1 ;
: (update-axes) ( gadget controller-state -- )
[ (update-axes) ] [ kill-update-axes ] if* ;
M: joystick-demo-gadget graft*
- dup '[ _ update-axes ] FREQUENCY every >>alarm
+ dup '[ _ update-axes ] FREQUENCY every >>timer
drop ;
M: joystick-demo-gadget ungraft*
- alarm>> [ stop-alarm ] when* ;
+ timer>> [ stop-timer ] when* ;
: joystick-window ( controller -- )
[ <joystick-demo-gadget> ] [ product-string ] bi
USING: game.input game.input.scancodes
kernel ui.gadgets ui.gadgets.buttons sequences accessors
-words arrays assocs math calendar fry alarms ui
+words arrays assocs math calendar fry timers ui
ui.gadgets.borders ui.gestures literals ;
IN: game.input.demos.key-caps
CONSTANT: KEYBOARD-SIZE { 230 65 }
CONSTANT: FREQUENCY $[ 1/30 seconds ]
-TUPLE: key-caps-gadget < gadget keys alarm ;
+TUPLE: key-caps-gadget < gadget keys timer ;
: make-key-gadget ( scancode dim array -- )
[
M: key-caps-gadget graft*
open-game-input
- dup '[ _ update-key-caps-state ] FREQUENCY every >>alarm
+ dup '[ _ update-key-caps-state ] FREQUENCY every >>timer
drop ;
M: key-caps-gadget ungraft*
- alarm>> [ stop-alarm ] when*
+ timer>> [ stop-timer ] when*
close-game-input ;
M: key-caps-gadget handle-gesture
{ <game-loop> <game-loop*> } related-words
-HELP: benchmark-frames-per-second
-{ $values
- { "loop" game-loop }
- { "n" float }
-}
-{ $description "Returns the average number of times per second the game loop has called " { $link draw* } " on its delegate since the game loop was started with " { $link start-loop } " or since the benchmark counters have been reset with " { $link reset-loop-benchmark } "." } ;
-
-HELP: benchmark-ticks-per-second
-{ $values
- { "loop" game-loop }
- { "n" float }
-}
-{ $description "Returns the average number of times per second the game loop has called " { $link tick* } " on its tick delegate since the game loop was started with " { $link start-loop } " or since the benchmark counters have been reset with " { $link reset-loop-benchmark } "." } ;
-
-{ reset-loop-benchmark benchmark-frames-per-second benchmark-ticks-per-second } related-words
-
HELP: draw*
{ $values
{ "tick-slice" float } { "delegate" "a " { $link "game.loop-delegates" } }
}
{ $description "If an uncaught error is thrown from inside a game loop delegate's " { $link tick* } " or " { $link draw* } ", the game loop will catch the error, stop the game loop, and rethrow an error of this class." } ;
-HELP: reset-loop-benchmark
-{ $values
- { "loop" game-loop }
-}
-{ $description "Resets the benchmark counters on a " { $link game-loop } ". Subsequent calls to " { $link benchmark-frames-per-second } " and " { $link benchmark-ticks-per-second } " will measure their values from the point " { $snippet "reset-loop-benchmark" } " was called." } ;
-
HELP: start-loop
{ $values
{ "loop" game-loop }
start-loop
stop-loop
}
-"The game loop maintains performance counters:"
-{ $subsections
- reset-loop-benchmark
- benchmark-frames-per-second
- benchmark-ticks-per-second
-}
"The game loop catches errors that occur in the delegate's methods during the course of the game loop:"
{ $subsections
game-loop-error
! (c)2009 Joe Groff bsd license
-USING: accessors alarms calendar continuations destructors fry
-kernel math math.order namespaces system ui ui.gadgets.worlds ;
+USING: accessors timers alien.c-types calendar classes.struct
+continuations destructors fry kernel math math.order memory
+namespaces sequences specialized-vectors system
+tools.memory ui ui.gadgets.worlds vm vocabs.loader arrays
+benchmark.struct locals ;
IN: game.loop
TUPLE: game-loop
{ tick-interval-nanos integer read-only }
tick-delegate
draw-delegate
- { last-tick integer }
{ running? boolean }
- { tick-number integer }
- { frame-number integer }
- { benchmark-time integer }
- { benchmark-tick-number integer }
- { benchmark-frame-number integer }
- alarm ;
+ { tick# integer }
+ { frame# integer }
+ tick-timer
+ draw-timer
+ benchmark-data ;
-GENERIC: tick* ( delegate -- )
-GENERIC: draw* ( tick-slice delegate -- )
-
-SYMBOL: game-loop
+STRUCT: game-loop-benchmark
+ { benchmark-data-pair benchmark-data-pair }
+ { tick# ulonglong }
+ { frame# ulonglong } ;
-: since-last-tick ( loop -- nanos )
- last-tick>> nano-count swap - ;
+SPECIALIZED-VECTOR: game-loop-benchmark
-: tick-slice ( loop -- slice )
- [ since-last-tick ] [ tick-interval-nanos>> ] bi /f 1.0 min ;
+: <game-loop-benchmark> ( benchmark-data-pair tick frame -- obj )
+ \ game-loop-benchmark <struct>
+ swap >>frame#
+ swap >>tick#
+ swap >>benchmark-data-pair ; inline
-CONSTANT: MAX-FRAMES-TO-SKIP 5
+GENERIC: tick* ( delegate -- )
+GENERIC: draw* ( tick-slice delegate -- )
DEFER: stop-loop
[ drop stop-loop ] [ \ game-loop-error boa ?ui-error ] 2bi ;
: fps ( fps -- nanos )
- 1,000,000,000 swap /i ; inline
+ [ 1,000,000,000 ] dip /i ; inline
<PRIVATE
+: record-benchmarking ( benchark-data-pair loop -- )
+ [ tick#>> ]
+ [ frame#>> <game-loop-benchmark> ]
+ [ benchmark-data>> ] tri push ;
+
+: last-tick-percent-offset ( loop -- float )
+ [ draw-timer>> iteration-start-nanos>> nano-count swap - ]
+ [ tick-interval-nanos>> ] bi /f 1.0 min ;
+
: redraw ( loop -- )
- [ 1 + ] change-frame-number
- [ tick-slice ] [ draw-delegate>> ] bi draw* ;
+ [ 1 + ] change-frame#
+ [
+ [ last-tick-percent-offset ] [ draw-delegate>> ] bi
+ [ draw* ] with-benchmarking
+ ] keep record-benchmarking ;
: tick ( loop -- )
- tick-delegate>> tick* ;
+ [
+ [ tick-delegate>> tick* ] with-benchmarking
+ ] keep record-benchmarking ;
: increment-tick ( loop -- )
- [ 1 + ] change-tick-number
- dup tick-interval-nanos>> [ + ] curry change-last-tick
+ [ 1 + ] change-tick#
drop ;
-: ?tick ( loop count -- )
- [ nano-count >>last-tick drop ] [
- over [ since-last-tick ] [ tick-interval-nanos>> ] bi >=
- [ [ drop increment-tick ] [ drop tick ] [ 1 - ?tick ] 2tri ]
- [ 2drop ] if
- ] if-zero ;
+PRIVATE>
-: benchmark-nanos ( loop -- nanos )
- nano-count swap benchmark-time>> - ;
+:: when-running ( loop quot -- )
+ [
+ loop
+ dup running?>> quot [ drop ] if
+ ] [
+ loop game-loop-error
+ ] recover ; inline
-PRIVATE>
+: tick-iteration ( loop -- )
+ [ [ tick ] [ increment-tick ] bi ] when-running ;
-: reset-loop-benchmark ( loop -- loop )
- nano-count >>benchmark-time
- dup tick-number>> >>benchmark-tick-number
- dup frame-number>> >>benchmark-frame-number ;
-
-: benchmark-ticks-per-second ( loop -- n )
- [ tick-number>> ] [ benchmark-tick-number>> - ] [ benchmark-nanos ] tri /f ;
-: benchmark-frames-per-second ( loop -- n )
- [ frame-number>> ] [ benchmark-frame-number>> - ] [ benchmark-nanos ] tri /f ;
-
-: (game-tick) ( loop -- )
- dup running?>>
- [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] bi ]
- [ drop ] if ;
-
-: game-tick ( loop -- )
- dup game-loop [
- [ (game-tick) ] [ game-loop-error ] recover
- ] with-variable ;
+: frame-iteration ( loop -- )
+ [ redraw ] when-running ;
: start-loop ( loop -- )
- nano-count >>last-tick
t >>running?
- reset-loop-benchmark
- [
- [ '[ _ game-tick ] f ]
- [ tick-interval-nanos>> nanoseconds ] bi
- <alarm>
- ] keep [ alarm<< ] [ drop start-alarm ] 2bi ;
+
+ dup
+ [ '[ _ tick-iteration ] f ]
+ [ tick-interval-nanos>> nanoseconds ] bi <timer> >>tick-timer
+
+ dup '[ _ frame-iteration ] f 1 milliseconds <timer> >>draw-timer
+
+ [ tick-timer>> ] [ draw-timer>> ] bi [ start-timer ] bi@ ;
: stop-loop ( loop -- )
f >>running?
- alarm>> stop-alarm ;
+ [ tick-timer>> ] [ draw-timer>> ] bi [ stop-timer ] bi@ ;
: <game-loop*> ( tick-interval-nanos tick-delegate draw-delegate -- loop )
- nano-count f 0 0 nano-count 0 0 f
+ f 0 0 f f
+ game-loop-benchmark-vector{ } clone
game-loop boa ;
: <game-loop> ( tick-interval-nanos delegate -- loop )
M: game-loop dispose
stop-loop ;
-USE: vocabs.loader
-
{ "game.loop" "prettyprint" } "game.loop.prettyprint" require-when
! (c)2009 Joe Groff bsd license
-USING: accessors combinators fry game.input game.loop generic kernel math
-parser sequences ui ui.gadgets ui.gadgets.worlds ui.gestures threads
-words audio.engine destructors ;
+USING: accessors audio.engine combinators concurrency.promises
+destructors fry game.input game.loop generic kernel math parser
+sequences threads ui ui.gadgets ui.gadgets.worlds ui.gestures
+words words.constant ;
IN: game.worlds
TUPLE: game-world < world
[ >>game-loop begin-game-world ] keep start-loop ;
M: game-world end-world
- [ [ stop-loop ] when* f ] change-game-loop
+ dup game-loop>> [ stop-loop ] when*
[ end-game-world ]
[ audio-engine>> [ dispose ] when* ]
[ use-game-input?>> [ close-game-input ] when ] tri ;
[ call-next-method ]
} cleave ;
+: start-game ( attributes -- game-world )
+ f swap open-window* ;
+
+: wait-game ( attributes -- game-world )
+ f swap open-window* dup promise>> ?promise drop ;
+
+: define-attributes-word ( word tuple -- )
+ [ name>> "-attributes" append create-in ] dip define-constant ;
+
SYNTAX: GAME:
CREATE
game-attributes parse-main-window-attributes
+ 2dup define-attributes-word
parse-definition
define-main-window ;
--- /dev/null
+Dmitry Shubin
--- /dev/null
+Dmitry Shubin
--- /dev/null
+! Copyright (C) 2010 Dmitry Shubin.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.libraries alien.syntax classes.struct
+combinators system ;
+IN: gdbm.ffi
+
+<< "libgdbm" os {
+ { [ unix? ] [ "libgdbm.so" ] }
+ { [ winnt? ] [ "gdbm.dll" ] }
+ { [ macosx? ] [ "libgdbm.dylib" ] }
+} cond cdecl add-library >>
+
+LIBRARY: libgdbm
+
+C-GLOBAL: c-string gdbm_version
+
+CONSTANT: GDBM_SYNC HEX: 20
+CONSTANT: GDBM_NOLOCK HEX: 40
+
+CONSTANT: GDBM_INSERT 0
+CONSTANT: GDBM_REPLACE 1
+
+CONSTANT: GDBM_CACHESIZE 1
+CONSTANT: GDBM_SYNCMODE 3
+CONSTANT: GDBM_CENTFREE 4
+CONSTANT: GDBM_COALESCEBLKS 5
+
+STRUCT: datum { dptr char* } { dsize int } ;
+
+C-TYPE: _GDBM_FILE
+TYPEDEF: _GDBM_FILE* GDBM_FILE
+
+CALLBACK: void fatal_func_cb ;
+FUNCTION: GDBM_FILE gdbm_open ( c-string name, int block_size, int read_write, int mode, fatal_func_cb fatal_func ) ;
+FUNCTION-ALIAS: gdbm-close void gdbm_close ( GDBM_FILE dbf ) ;
+FUNCTION: int gdbm_store ( GDBM_FILE dbf, datum key, datum content, int flag ) ;
+FUNCTION: datum gdbm_fetch ( GDBM_FILE dbf, datum key ) ;
+FUNCTION: int gdbm_delete ( GDBM_FILE dbf, datum key ) ;
+FUNCTION: datum gdbm_firstkey ( GDBM_FILE dbf ) ;
+FUNCTION: datum gdbm_nextkey ( GDBM_FILE dbf, datum key ) ;
+FUNCTION: int gdbm_reorganize ( GDBM_FILE dbf ) ;
+FUNCTION: void gdbm_sync ( GDBM_FILE dbf ) ;
+FUNCTION: int gdbm_exists ( GDBM_FILE dbf, datum key ) ;
+FUNCTION: int gdbm_setopt ( GDBM_FILE dbf, int option, int* value, int size ) ;
+FUNCTION: int gdbm_fdesc ( GDBM_FILE dbf ) ;
+
+C-GLOBAL: int gdbm_errno
+
+FUNCTION: c-string gdbm_strerror ( int errno ) ;
--- /dev/null
+! Copyright (C) 2010 Dmitry Shubin.
+! See http://factorcode.org/license.txt for BSD license.
+USING: gdbm.ffi gdbm.private help.markup help.syntax kernel math
+quotations strings ;
+IN: gdbm
+
+HELP: gdbm
+{ $class-description "Instance of this class is used as database configuration object. It has following slots:"
+
+ { $table
+ { { $slot "name" } "The file name of the database." }
+ { { $slot "block-size" } "The size of a single transfer from disk to memory. If the value is less than 512, the file system blocksize is used (this is default)." }
+ { { $slot "role" } "Determines what kind of access the user wants to obtain (see below)." }
+ { { $slot "sync" } { "Being set to " { $link t } " causes all database operations to be synchronized to the disk." } }
+ { { $slot "nolock" } { "Being set to " { $link t } " prevents gdbm from performing any locking on the database file." } }
+ { { $slot "mode" } "An integer representing standard UNIX access permissions." }
+ }
+ "The " { $slot "role" } " can be set to one of the folowing values:"
+ { $table
+ { { $snippet "reader" } "The user can only read from existing database." }
+ { { $snippet "writer" } "The user can access existing database as reader and writer." }
+ { { $snippet "wrcreat" } "Open the database for reading and writing if it exists and create new one otherwise." }
+ { { $snippet "newdb" } "Create empty database even if there is already one with the same name." }
+ }
+} ;
+
+HELP: <gdbm>
+{ $values { "gdbm" gdbm } }
+{ $description "Creates database configuration object with all slots set to their default values. See " { $link gdbm } " for complete slots description." } ;
+
+HELP: gdbm-info
+{ $values { "str" string } }
+{ $description "Returns version number and build date." } ;
+
+HELP: delete
+{ $values { "key" object } }
+{ $description "Removes the keyed item from the database." } ;
+
+HELP: gdbm-error-message
+{ $values { "error" gdbm-error } { "msg" string } }
+{ $description "Returns error message in human readable format." } ;
+
+HELP: exists?
+{ $values { "key" object } { "?" boolean } }
+{ $description "Searches for a particular key without retreiving it." } ;
+
+HELP: each-key
+{ $values { "quot" quotation } }
+{ $description "Applies the quotation to the each key in the database." } ;
+
+HELP: each-value
+{ $values { "quot" quotation } }
+{ $description "Applies the quotation to the each value in the database." } ;
+
+HELP: each-record
+{ $values { "quot" quotation } }
+{ $description "Applies the quotation to the each key-value pair in the database." } ;
+
+HELP: gdbm-file-descriptor
+{ $values { "desc" integer } }
+{ $description "Returns the file descriptor of the database. This is used for manual database locking if it was opened with " { $snippet "nolock" } " flag set to " { $link t } "." } ;
+
+HELP: fetch
+{ $values
+ { "key" object }
+ { "content/f" { "the value associated with " { $snippet "key" } " or " { $link f } " if there is no such key" } }
+}
+{ $description "Looks up a given key and returns value associated with it. This word makes no distinction between a missing value and a value set to " { $link f } "." } ;
+
+HELP: fetch*
+{ $values { "key" object } { "content" object } { "?" boolean } }
+{ $description "Looks up a given key and returns value associated with it. The boolean flag can decide between the case of a missing value, and a value of " { $link f } "." } ;
+
+HELP: first-key
+{ $values { "key/f" object } }
+{ $description "Returns first key in the database. This word makes no distinction between an empty database case and a case of a first value set to " { $link f } "." } ;
+
+HELP: first-key*
+{ $values { "key" object } { "?" boolean } }
+{ $description "Returns first key in the database. The boolean flag can decide between the case of an empty database and a case of a first value set to " { $link f } "." } ;
+
+HELP: insert
+{ $values { "key" object } { "content" object } }
+{ $description "Inserts record into the database. Throws an error if the key already exists." } ;
+
+HELP: next-key
+{ $values { "key" object } { "key/f" object } }
+{ $description "Given a key returns next key in the database. This word makes no distinction between reaching the end of the database case and a case of a next value set to " { $link f } "." } ;
+
+HELP: next-key*
+{ $values { "key" object } { "next-key" object } { "?" boolean } }
+{ $description "Given a key returns next key in the database. The boolean flag can decide between the case of reaching the end of the database and a case of a next value set to " { $link f } "." } ;
+
+HELP: reorganize
+{ $description "Reorganisation is a process of shinking the space used by gdbm. This requires creating a new file and moving all elements from old gdbm file to new one." } ;
+
+HELP: replace
+{ $values { "key" object } { "content" object } }
+{ $description "Inserts record into the database replacing old value with the new one if the key already exists." } ;
+
+HELP: set-block-merging
+{ $values { "?" boolean } }
+{ $description "If set, this option causes adjacent free blocks to be merged. The default is " { $link f } "." } ;
+
+HELP: set-block-pool
+{ $values { "?" boolean } }
+{ $description "If set, this option causes all subsequent free blocks to be placed in the global pool. The default is " { $link f } "." } ;
+
+HELP: set-cache-size
+{ $values { "size" integer } }
+{ $description "Sets the size of the internal bucket cache. The default value is 100. This option may only be set once." } ;
+
+HELP: set-sync-mode
+{ $values { "?" boolean } }
+{ $description "Turns on or off file system synchronization. The default is " { $link f } "." } ;
+
+HELP: synchronize
+{ $description "Performs database synchronization: make sure the disk version of the database has been completely updated." } ;
+
+HELP: with-gdbm
+{ $values
+ { "gdbm" "a database configuration object" } { "quot" quotation }
+}
+{ $description "Calls the quotation with a database bound to " { $link current-dbf } " symbol." } ;
+
+
+ARTICLE: "gdbm" "GNU Database Manager"
+"The " { $vocab-link "gdbm" } " vocabulary provides an interface to GNU DataBase Manager. This is a GNU implementation of the standard Unix dbm library, originally developed at Berkeley."
+
+$nl
+"This is a very brief manual. For a more detailed description consult the official gdbm documentation."
+
+{ $heading "Basics" }
+"All interaction with gdbm database should be realized using special combinator which automates all work for database initialisation and cleanup. All initialisation options are passed to combinator with a database configuration object."
+{ $subsections gdbm <gdbm> with-gdbm }
+"For actual record manipulation the following words are used:"
+{ $subsections insert exists? fetch delete }
+
+{ $heading "Sequential access" }
+"It is possible to iterate through all records in the database with"
+{ $subsections first-key next-key }
+"The following combinators, however, provide more convenient way to do that:"
+{ $subsections each-key each-value each-record }
+"The order in which records are accessed has nothing to do with the order in which records have been stored. Note that these words can only be used in read-only algorithms since delete operation re-arranges the hash table."
+;
+
+ABOUT: "gdbm"
--- /dev/null
+! Copyright (C) 2010 Dmitry Shubin.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays continuations gdbm io.directories
+io.files.temp kernel sequences sets tools.test ;
+IN: gdbm.tests
+
+: db-path ( -- filename ) "test.db" temp-file ;
+
+: CLEANUP ( -- ) [ db-path delete-file ] ignore-errors ;
+
+: test.db ( -- gdbm ) <gdbm> db-path >>name ;
+
+: with-test.db ( quot -- ) test.db swap with-gdbm ; inline
+
+
+CLEANUP
+
+
+[
+ test.db reader >>role [ ] with-gdbm
+] [ gdbm-file-open-error = ] must-fail-with
+
+[ f ] [ [ "foo" exists? ] with-test.db ] unit-test
+
+[ ] [ [ "foo" 41 insert ] with-test.db ] unit-test
+
+[
+ db-path [ "foo" 42 insert ] with-gdbm-writer
+] [ gdbm-cannot-replace = ] must-fail-with
+
+[ ]
+[
+ [
+ "foo" 42 replace
+ "bar" 43 replace
+ "baz" 44 replace
+ ] with-test.db
+] unit-test
+
+[ 42 t ] [ db-path [ "foo" fetch* ] with-gdbm-reader ] unit-test
+
+[ f f ] [ [ "unknown" fetch* ] with-test.db ] unit-test
+
+[
+ [
+ 300 set-cache-size 300 set-cache-size
+ ] with-test.db
+] [ gdbm-option-already-set = ] must-fail-with
+
+[ t ]
+[
+ V{ } [ [ 2array append ] each-record ] with-test.db
+ V{ "foo" "bar" "baz" 42 43 44 } set=
+
+] unit-test
+
+[ f ]
+[
+ test.db newdb >>role [ "foo" exists? ] with-gdbm
+] unit-test
+
+
+CLEANUP
--- /dev/null
+! Copyright (C) 2010 Dmitry Shubin.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.data alien.destructors
+alien.enums alien.syntax classes.struct combinators destructors
+gdbm.ffi io.backend kernel libc locals math namespaces sequences
+serialize strings ;
+IN: gdbm
+
+ENUM: gdbm-role reader writer wrcreat newdb ;
+
+TUPLE: gdbm
+ { name string }
+ { block-size integer }
+ { role initial: wrcreat }
+ { sync boolean }
+ { nolock boolean }
+ { mode integer initial: OCT: 644 } ;
+
+: <gdbm> ( -- gdbm ) gdbm new ;
+
+ENUM: gdbm-error
+ gdbm-no-error
+ gdbm-malloc-error
+ gdbm-block-size-error
+ gdbm-file-open-error
+ gdbm-file-write-error
+ gdbm-file-seek-error
+ gdbm-file-read-error
+ gdbm-bad-magic-number
+ gdbm-empty-database
+ gdbm-cant-be-reader
+ gdbm-cant-be-writer
+ gdbm-reader-cant-delete
+ gdbm-reader-cant-store
+ gdbm-reader-cant-reorganize
+ gdbm-unknown-update
+ gdbm-item-not-found
+ gdbm-reorganize-failed
+ gdbm-cannot-replace
+ gdbm-illegal-data
+ gdbm-option-already-set
+ gdbm-illegal-option ;
+
+
+<PRIVATE
+
+: gdbm-throw ( -- * ) gdbm_errno gdbm-error number>enum throw ;
+
+: check-error ( ret -- ) 0 = [ gdbm-throw ] unless ;
+
+SYMBOL: current-dbf
+
+: dbf ( -- dbf ) current-dbf get ;
+
+: get-flag ( gdbm -- n )
+ [ role>> enum>number ]
+ [ sync>> GDBM_SYNC 0 ? ]
+ [ nolock>> GDBM_NOLOCK 0 ? ]
+ tri bitor bitor ;
+
+: gdbm-open ( gdbm -- dbf )
+ {
+ [ name>> normalize-path ]
+ [ block-size>> ] [ get-flag ] [ mode>> ]
+ } cleave f gdbm_open [ gdbm-throw ] unless* ;
+
+DESTRUCTOR: gdbm-close
+
+: object>datum ( obj -- datum )
+ object>bytes [ malloc-byte-array &free ] [ length ] bi
+ datum <struct-boa> ;
+
+: datum>object* ( datum -- obj ? )
+ [ dptr>> ] [ dsize>> ] bi over
+ [ memory>byte-array bytes>object t ] [ drop f ] if ;
+
+: gdbm-store ( key content flag -- )
+ [
+ { [ dbf ] [ object>datum ] [ object>datum ] [ ] } spread
+ gdbm_store check-error
+ ] with-destructors ;
+
+:: (setopt) ( value option -- )
+ [
+ int heap-size dup malloc &free :> ( size ptr )
+ value ptr 0 int set-alien-value
+ dbf option ptr size gdbm_setopt check-error
+ ] with-destructors ;
+
+: setopt ( value option -- )
+ [ GDBM_CACHESIZE = [ >c-bool ] unless ] keep (setopt) ;
+
+PRIVATE>
+
+
+: gdbm-info ( -- str ) gdbm_version ;
+
+: gdbm-error-message ( error -- msg )
+ enum>number gdbm_strerror ;
+
+: replace ( key content -- ) GDBM_REPLACE gdbm-store ;
+: insert ( key content -- ) GDBM_INSERT gdbm-store ;
+
+: delete ( key -- )
+ [ dbf swap object>datum gdbm_delete check-error ]
+ with-destructors ;
+
+: fetch* ( key -- content ? )
+ [ dbf swap object>datum gdbm_fetch datum>object* ]
+ with-destructors ;
+
+: first-key* ( -- key ? )
+ [ dbf gdbm_firstkey datum>object* ] with-destructors ;
+
+: next-key* ( key -- next-key ? )
+ [ dbf swap object>datum gdbm_nextkey datum>object* ]
+ with-destructors ;
+
+: fetch ( key -- content/f ) fetch* drop ;
+: first-key ( -- key/f ) first-key* drop ;
+: next-key ( key -- key/f ) next-key* drop ;
+
+:: each-key ( ... quot: ( ... key -- ... ) -- ... )
+ first-key*
+ [ [ next-key* ] [ quot keep ] do while ] when drop ; inline
+
+: each-value ( ... quot: ( ... value -- ... ) -- ... )
+ [ fetch ] prepose each-key ; inline
+
+: each-record ( ... quot: ( ... key value -- ... ) -- ... )
+ [ dup fetch ] prepose each-key ; inline
+
+: reorganize ( -- ) dbf gdbm_reorganize check-error ;
+
+: synchronize ( -- ) dbf gdbm_sync ;
+
+: exists? ( key -- ? )
+ [ dbf swap object>datum gdbm_exists c-bool> ]
+ with-destructors ;
+
+: set-cache-size ( size -- ) GDBM_CACHESIZE setopt ;
+: set-sync-mode ( ? -- ) GDBM_SYNCMODE setopt ;
+: set-block-pool ( ? -- ) GDBM_CENTFREE setopt ;
+: set-block-merging ( ? -- ) GDBM_COALESCEBLKS setopt ;
+
+: gdbm-file-descriptor ( -- desc ) dbf gdbm_fdesc ;
+
+: with-gdbm ( gdbm quot -- )
+ [ gdbm-open &gdbm-close current-dbf set ] prepose curry
+ [ with-scope ] curry with-destructors ; inline
+
+:: with-gdbm-role ( name role quot -- )
+ <gdbm> name >>name role >>role quot with-gdbm ; inline
+
+: with-gdbm-reader ( name quot -- )
+ reader swap with-gdbm-role ; inline
+
+: with-gdbm-writer ( name quot -- )
+ writer swap with-gdbm-role ; inline
+
--- /dev/null
+GNU DataBase Manager
--- /dev/null
+bindings
+database
CONSTANT: fov 0.7
+: wasd-fov-vector ( world -- fov )
+ dim>> dup first2 min >float v/n fov v*n ; inline
+
:: generate-p-matrix ( world -- matrix )
world wasd-near-plane :> near-plane
world wasd-far-plane :> far-plane
- world dim>> dup first2 min >float v/n fov v*n near-plane v*n
+ world wasd-fov-vector near-plane v*n
near-plane far-plane frustum-matrix4 ;
+:: wasd-pixel-ray ( world loc -- direction )
+ loc world dim>> [ /f 0.5 - 2.0 * ] 2map
+ world wasd-fov-vector v*
+ first2 neg -1.0 0.0 4array
+ world wasd-mv-inv-matrix swap m.v ;
+
: set-wasd-view ( world location yaw pitch -- world )
[ >>location ] [ >>yaw ] [ >>pitch ] tri* ;
+++ /dev/null
-Joe Groff\r
+++ /dev/null
-! (c)2010 Joe Groff bsd license\r
-USING: assocs hashtables.identity kernel literals tools.test ;\r
-IN: hashtables.identity.tests\r
-\r
-CONSTANT: the-real-slim-shady "marshall mathers"\r
-\r
-CONSTANT: will\r
- IH{\r
- { $ the-real-slim-shady t }\r
- { "marshall mathers" f }\r
- }\r
-\r
-: please-stand-up ( assoc key -- value )\r
- swap at ;\r
-\r
-[ t ] [ will the-real-slim-shady please-stand-up ] unit-test\r
-[ t ] [ will clone the-real-slim-shady please-stand-up ] unit-test\r
-\r
-[ 2 ] [ will assoc-size ] unit-test\r
-[ { { "marshall mathers" f } } ] [\r
- the-real-slim-shady will clone\r
- [ delete-at ] [ >alist ] bi\r
-] unit-test\r
-[ t ] [\r
- t the-real-slim-shady identity-associate\r
- t the-real-slim-shady identity-associate =\r
-] unit-test\r
-[ f ] [\r
- t the-real-slim-shady identity-associate\r
- t "marshall mathers" identity-associate =\r
-] unit-test\r
+++ /dev/null
-! (c)2010 Joe Groff bsd license\r
-USING: accessors arrays assocs fry hashtables kernel parser\r
-sequences vocabs.loader ;\r
-IN: hashtables.identity\r
-\r
-TUPLE: identity-wrapper\r
- { underlying read-only } ;\r
-C: <identity-wrapper> identity-wrapper\r
-\r
-M: identity-wrapper equal?\r
- over identity-wrapper?\r
- [ [ underlying>> ] bi@ eq? ]\r
- [ 2drop f ] if ; inline\r
-\r
-M: identity-wrapper hashcode*\r
- nip underlying>> identity-hashcode ; inline\r
-\r
-TUPLE: identity-hashtable\r
- { underlying hashtable read-only } ;\r
-\r
-: <identity-hashtable> ( n -- ihash )\r
- <hashtable> identity-hashtable boa ; inline\r
-\r
-<PRIVATE\r
-: identity@ ( key ihash -- ikey hash )\r
- [ <identity-wrapper> ] [ underlying>> ] bi* ; inline\r
-PRIVATE>\r
-\r
-M: identity-hashtable at*\r
- identity@ at* ; inline\r
-\r
-M: identity-hashtable clear-assoc\r
- underlying>> clear-assoc ; inline\r
-\r
-M: identity-hashtable delete-at\r
- identity@ delete-at ; inline\r
-\r
-M: identity-hashtable assoc-size\r
- underlying>> assoc-size ; inline\r
-\r
-M: identity-hashtable set-at\r
- identity@ set-at ; inline\r
-\r
-: identity-associate ( value key -- hash )\r
- 2 <identity-hashtable> [ set-at ] keep ; inline\r
-\r
-M: identity-hashtable >alist\r
- underlying>> >alist [ [ first underlying>> ] [ second ] bi 2array ] map ;\r
- \r
-M: identity-hashtable clone\r
- underlying>> clone identity-hashtable boa ; inline\r
-\r
-M: identity-hashtable equal?\r
- over identity-hashtable? [ [ underlying>> ] bi@ = ] [ 2drop f ] if ;\r
-\r
-: >identity-hashtable ( assoc -- ihashtable )\r
- dup assoc-size <identity-hashtable> [ '[ swap _ set-at ] assoc-each ] keep ;\r
-\r
-SYNTAX: IH{ \ } [ >identity-hashtable ] parse-literal ;\r
-\r
-{ "hashtables.identity" "prettyprint" } "hashtables.identity.prettyprint" require-when\r
-{ "hashtables.identity" "mirrors" } "hashtables.identity.mirrors" require-when\r
+++ /dev/null
-USING: hashtables.identity mirrors ;\r
-IN: hashtables.identity.mirrors\r
-\r
-M: identity-hashtable make-mirror ;\r
+++ /dev/null
-! (c)2010 Joe Groff bsd license\r
-USING: assocs continuations hashtables.identity kernel\r
-namespaces prettyprint.backend prettyprint.config\r
-prettyprint.custom ;\r
-IN: hashtables.identity.prettyprint\r
-\r
-M: identity-hashtable >pprint-sequence >alist ;\r
-M: identity-hashtable pprint-delims drop \ IH{ \ } ;\r
-\r
-M: identity-hashtable pprint*\r
- nesting-limit inc\r
- [ pprint-object ] [ nesting-limit dec ] [ ] cleanup ;\r
+++ /dev/null
-Hashtables keyed by object identity (eq?) rather than by logical value (=)\r
! See http://factorcode.org/license.txt for BSD license.
USING: fry irc.client irc.client.chats kernel namespaces
sequences threads io.launcher io splitting
-make mason.common mason.updates calendar math alarms
+make mason.common mason.updates calendar math timers
io.encodings.8-bit.latin1 debugger ;
IN: irc.gitbot
! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alarms bit-arrays calendar game.input io
+USING: accessors timers bit-arrays calendar game.input io
io.binary io.encodings.binary io.files kernel literals math
namespaces system threads ;
IN: key-logger
] unless ;
: stop-key-logger ( -- )
- key-logger get-global [ stop-alarm ] when*
+ key-logger get-global [ stop-timer ] when*
f key-logger set-global
close-game-input ;
--- /dev/null
+Niklas Waern
--- /dev/null
+! Copyright (C) 2010 Niklas Waern.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.libraries alien.syntax
+fry kernel sequences unix.types ;
+IN: libudev
+
+<< "libudev" "libudev.so" cdecl add-library >>
+
+LIBRARY: libudev
+
+C-TYPE: udev
+
+FUNCTION: udev* udev_ref (
+ udev* udev ) ;
+
+
+
+FUNCTION: void udev_unref (
+ udev* udev ) ;
+
+
+
+FUNCTION: udev* udev_new ( ) ;
+
+
+
+CALLBACK: void udev_set_log_fn_callback (
+ udev* udev
+ int priority,
+ c-string file,
+ int line,
+ c-string fn,
+ c-string format ) ;
+ ! va_list args ) ;
+FUNCTION: void udev_set_log_fn (
+ udev* udev,
+ udev_set_log_fn_callback log_fn ) ;
+
+
+
+FUNCTION: int udev_get_log_priority (
+ udev* udev ) ;
+
+
+
+FUNCTION: void udev_set_log_priority (
+ udev* udev,
+ int priority ) ;
+
+
+
+FUNCTION: c-string udev_get_sys_path (
+ udev* udev ) ;
+
+
+
+FUNCTION: c-string udev_get_dev_path (
+ udev* udev ) ;
+
+
+
+FUNCTION: void* udev_get_userdata (
+ udev* udev ) ;
+
+
+
+FUNCTION: void udev_set_userdata (
+ udev* udev,
+ void* userdata ) ;
+
+
+
+C-TYPE: udev_list_entry
+
+FUNCTION: udev_list_entry* udev_list_entry_get_next (
+ udev_list_entry* list_entry ) ;
+
+
+
+FUNCTION: udev_list_entry* udev_list_entry_get_by_name (
+ udev_list_entry* list_entry,
+ c-string name ) ;
+
+
+
+FUNCTION: c-string udev_list_entry_get_name (
+ udev_list_entry* list_entry ) ;
+
+
+
+FUNCTION: c-string udev_list_entry_get_value (
+ udev_list_entry* list_entry ) ;
+
+
+
+! Helper to iterate over all entries of a list.
+: udev_list_entry_foreach ( ... first_entry quot: ( ... x -- ... ) -- ... )
+ [ [ dup ] ] dip '[ [ @ ] keep udev_list_entry_get_next ]
+ while drop ; inline
+
+! Get all list entries _as_ a list
+: udev-list-entries ( first_entry -- seq )
+ [ ] collector [ udev_list_entry_foreach ] dip ;
+
+
+
+C-TYPE: udev_device
+
+FUNCTION: udev_device* udev_device_ref (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: void udev_device_unref (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: udev* udev_device_get_udev (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: udev_device* udev_device_new_from_syspath (
+ udev* udev,
+ c-string syspath ) ;
+
+
+
+FUNCTION: udev_device* udev_device_new_from_devnum (
+ udev* udev,
+ char type,
+ dev_t devnum ) ;
+
+
+
+FUNCTION: udev_device* udev_device_new_from_subsystem_sysname (
+ udev* udev,
+ c-string subsystem,
+ c-string sysname ) ;
+
+
+
+FUNCTION: udev_device* udev_device_get_parent (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: udev_device* udev_device_get_parent_with_subsystem_devtype (
+ udev_device* udev_device,
+ c-string subsystem,
+ c-string devtype ) ;
+
+
+
+FUNCTION: c-string udev_device_get_devpath (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: c-string udev_device_get_subsystem (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: c-string udev_device_get_devtype (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: c-string udev_device_get_syspath (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: c-string udev_device_get_sysname (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: c-string udev_device_get_sysnum (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: c-string udev_device_get_devnode (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: udev_list_entry* udev_device_get_devlinks_list_entry (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: udev_list_entry* udev_device_get_properties_list_entry (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: c-string udev_device_get_property_value (
+ udev_device* udev_device,
+ c-string key ) ;
+
+
+
+FUNCTION: c-string udev_device_get_driver (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: dev_t udev_device_get_devnum (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: c-string udev_device_get_action (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: ulonglong udev_device_get_seqnum (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: c-string udev_device_get_sysattr_value (
+ udev_device* udev_device,
+ c-string sysattr ) ;
+
+
+
+C-TYPE: udev_monitor
+
+FUNCTION: udev_monitor* udev_monitor_ref (
+ udev_monitor* udev_monitor ) ;
+
+
+
+FUNCTION: void udev_monitor_unref (
+ udev_monitor* udev_monitor ) ;
+
+
+
+FUNCTION: udev* udev_monitor_get_udev (
+ udev_monitor* udev_monitor ) ;
+
+
+
+FUNCTION: udev_monitor* udev_monitor_new_from_netlink (
+ udev* udev,
+ c-string name ) ;
+
+
+
+FUNCTION: udev_monitor* udev_monitor_new_from_socket (
+ udev* udev,
+ c-string socket_path ) ;
+
+
+
+FUNCTION: int udev_monitor_enable_receiving (
+ udev_monitor* udev_monitor ) ;
+
+
+
+FUNCTION: int udev_monitor_set_receive_buffer_size (
+ udev_monitor* udev_monitor,
+ int size ) ;
+
+
+
+FUNCTION: int udev_monitor_get_fd (
+ udev_monitor* udev_monitor ) ;
+
+
+
+FUNCTION: udev_device* udev_monitor_receive_device (
+ udev_monitor* udev_monitor ) ;
+
+
+
+FUNCTION: int udev_monitor_filter_add_match_subsystem_devtype (
+ udev_monitor* udev_monitor,
+ c-string subsystem,
+ c-string devtype ) ;
+
+
+
+FUNCTION: int udev_monitor_filter_update (
+ udev_monitor* udev_monitor ) ;
+
+
+
+FUNCTION: int udev_monitor_filter_remove (
+ udev_monitor* udev_monitor ) ;
+
+
+
+C-TYPE: udev_enumerate
+
+FUNCTION: udev_enumerate* udev_enumerate_ref (
+ udev_enumerate* udev_enumerate ) ;
+
+
+
+FUNCTION: void udev_enumerate_unref (
+ udev_enumerate* udev_enumerate ) ;
+
+
+
+FUNCTION: udev* udev_enumerate_get_udev (
+ udev_enumerate* udev_enumerate ) ;
+
+
+
+FUNCTION: udev_enumerate* udev_enumerate_new (
+ udev* udev ) ;
+
+
+
+FUNCTION: int udev_enumerate_add_match_subsystem (
+ udev_enumerate* udev_enumerate,
+ c-string subsystem ) ;
+
+
+
+FUNCTION: int udev_enumerate_add_nomatch_subsystem (
+ udev_enumerate* udev_enumerate,
+ c-string subsystem ) ;
+
+
+
+FUNCTION: int udev_enumerate_add_match_sysattr (
+ udev_enumerate* udev_enumerate,
+ c-string sysattr,
+ c-string value ) ;
+
+
+
+FUNCTION: int udev_enumerate_add_nomatch_sysattr (
+ udev_enumerate* udev_enumerate,
+ c-string sysattr,
+ c-string value ) ;
+
+
+
+FUNCTION: int udev_enumerate_add_match_property (
+ udev_enumerate* udev_enumerate,
+ c-string property,
+ c-string value ) ;
+
+
+
+FUNCTION: int udev_enumerate_add_match_sysname (
+ udev_enumerate* udev_enumerate,
+ c-string sysname ) ;
+
+
+
+FUNCTION: int udev_enumerate_add_syspath (
+ udev_enumerate* udev_enumerate,
+ c-string syspath ) ;
+
+
+
+FUNCTION: int udev_enumerate_scan_devices (
+ udev_enumerate* udev_enumerate ) ;
+
+
+
+FUNCTION: int udev_enumerate_scan_subsystems (
+ udev_enumerate* udev_enumerate ) ;
+
+
+
+FUNCTION: udev_list_entry* udev_enumerate_get_list_entry (
+ udev_enumerate* udev_enumerate ) ;
+
+
+
+C-TYPE: udev_queue
+
+FUNCTION: udev_queue* udev_queue_ref (
+ udev_queue* udev_queue ) ;
+
+
+
+FUNCTION: void udev_queue_unref (
+ udev_queue* udev_queue ) ;
+
+
+
+FUNCTION: udev* udev_queue_get_udev (
+ udev_queue* udev_queue ) ;
+
+
+
+FUNCTION: udev_queue* udev_queue_new (
+ udev* udev ) ;
+
+
+
+FUNCTION: ulonglong udev_queue_get_kernel_seqnum (
+ udev_queue* udev_queue ) ;
+
+
+
+FUNCTION: ulonglong udev_queue_get_udev_seqnum (
+ udev_queue* udev_queue ) ;
+
+
+
+FUNCTION: int udev_queue_get_udev_is_active (
+ udev_queue* udev_queue ) ;
+
+
+
+FUNCTION: int udev_queue_get_queue_is_empty (
+ udev_queue* udev_queue ) ;
+
+
+
+FUNCTION: int udev_queue_get_seqnum_is_finished (
+ udev_queue* udev_queue,
+ ulonglong seqnum ) ;
+
+
+
+FUNCTION: int udev_queue_get_seqnum_sequence_is_finished (
+ udev_queue* udev_queue,
+ ulonglong start,
+ ulonglong end ) ;
+
+
+
+FUNCTION: udev_list_entry* udev_queue_get_queued_list_entry (
+ udev_queue* udev_queue ) ;
+
+
+
+FUNCTION: udev_list_entry* udev_queue_get_failed_list_entry (
+ udev_queue* udev_queue ) ;
+
+
+
--- /dev/null
+Bindings to libudev
IN: mason.common.tests
USING: prettyprint mason.common mason.config
-namespaces calendar tools.test io.files io.files.temp io.encodings.utf8 ;
+namespaces calendar tools.test io.files
+io.files.temp io.encodings.utf8 sequences ;
[ "00:01:02" ] [ 62,000,000,000 nanos>time ] unit-test
] with-scope
] unit-test
-[ "/home/bobby/builds/2008-09-11-12-23" ] [
+[ t ] [
[
"/home/bobby/builds" builds-dir set
T{ timestamp
} datestamp stamp set
build-dir
] with-scope
+ "/home/bobby/builds/2008-09-11-12-23" head?
] unit-test
[ ] [ "empty-test" temp-file utf8 [ ] with-file-writer ] unit-test
! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel io.launcher bootstrap.image.download
-mason.common mason.platform ;
+USING: bootstrap.image.download io.directories io.launcher
+kernel mason.common mason.platform ;
IN: mason.updates
: git-pull-cmd ( -- cmd )
boot-image-name maybe-download-image ;
: new-code-available? ( -- ? )
- updates-available?
- new-image-available?
- or ;
\ No newline at end of file
+ updates-available? new-image-available? or ;
: remote-directory ( string -- string' )
[ upload-directory get ] dip "/" glue ;
+SLOT: os
+SLOT: cpu
+
: platform ( builder -- string )
[ os>> ] [ cpu>> ] bi (platform) ;
: make-source-release ( version git-id -- path )
"Creating source release..." print flush
- unique-directory
[
clone-factor prepare-source (make-source-release)
"Package created: " write absolute-path dup print
- ] with-directory ;
+ ] with-unique-directory drop ;
: upload-source-release ( package version -- )
"Uploading source release..." print flush
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alarms arrays calendar combinators
+USING: accessors timers arrays calendar combinators
combinators.smart continuations debugger http.client fry
init io.streams.string kernel locals math math.parser db
namespaces sequences site-watcher.db site-watcher.email ;
] unless ;
: stop-site-watcher ( -- )
- running-site-watcher get [ stop-alarm ] when* ;
+ running-site-watcher get [ stop-timer ] when* ;
: sync-frame ( micros -- micros )
#! Sleep until the time for the next frame arrives.
- 1000 60 / >fixnum + system:system-micros - dup 0 >
- [ milliseconds threads:sleep ] [ drop threads:yield ] if system:system-micros ;
+ 1000 60 / >fixnum + gmt timestamp>micros - dup 0 >
+ [ milliseconds threads:sleep ] [ drop threads:yield ] if gmt timestamp>micros ;
: invaders-process ( micros gadget -- )
#! Run a space invaders gadget inside a
M: invaders-gadget graft* ( gadget -- )
dup cpu>> init-sounds
f over quit?<<
- [ system:system-micros swap invaders-process ] curry
+ [ gmt timestamp>micros swap invaders-process ] curry
"Space invaders" threads:spawn drop ;
M: invaders-gadget ungraft* ( gadget -- )
--- /dev/null
+! Copyright (C) 2009, 2010 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: words kernel locals accessors compiler.tree.propagation.info
+sequences kernel.private assocs fry parser math quotations
+effects arrays definitions compiler.units namespaces
+compiler.tree.debugger generalizations stack-checker ;
+IN: specialized
+
+: in-compilation-unit? ( -- ? )
+ changed-definitions get >boolean ;
+
+: define-temp-in-unit ( quot effect -- word )
+ in-compilation-unit?
+ [ [ define-temp ] with-nested-compilation-unit ]
+ [ [ define-temp ] with-compilation-unit ]
+ if ;
+
+: final-info-quot ( word -- quot )
+ [ stack-effect in>> length '[ _ ndrop ] ]
+ [ def>> [ final-info ] with-scope >quotation ] bi
+ compose ;
+
+ERROR: bad-outputs word quot ;
+
+: define-outputs ( word quot -- )
+ 2dup [ stack-effect ] [ infer ] bi* effect<=
+ [ "outputs" set-word-prop ] [ bad-outputs ] if ;
+
+: record-final-info ( word -- )
+ dup final-info-quot define-outputs ;
+
+:: lookup-specialized ( #call word n -- special-word/f )
+ #call in-d>> n tail* >array [ value-info class>> ] map
+ dup [ object = ] all? [ drop f ] [
+ word "specialized-defs" word-prop [
+ [ declare ] curry word def>> compose
+ word stack-effect define-temp-in-unit
+ dup record-final-info
+ 1quotation
+ ] cache
+ ] if ;
+
+: specialized-quot ( word n -- quot )
+ '[ _ _ lookup-specialized ] ;
+
+: make-specialized ( word n -- )
+ [ drop H{ } clone "specialized-defs" set-word-prop ]
+ [ dupd specialized-quot "custom-inlining" set-word-prop ] 2bi ;
+
+SYNTAX: specialized
+ word dup stack-effect in>> length make-specialized ;
+
+PREDICATE: specialized-word < word
+ "specialized-defs" word-prop >boolean ;
+
GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP_TO_EDGE glTexParameteri ;
: sky-gradient ( world -- t )
- game-loop>> tick-number>> SKY-PERIOD mod SKY-PERIOD /f ;
+ game-loop>> tick#>> SKY-PERIOD mod SKY-PERIOD /f ;
: sky-theta ( world -- theta )
- game-loop>> tick-number>> SKY-SPEED * ;
+ game-loop>> tick#>> SKY-SPEED * ;
M: terrain-world begin-game-world
"2.0" { "GL_ARB_vertex_buffer_object" "GL_ARB_shader_objects" }
rows>> 1 + 10 / ceiling ;
: update-interval ( tetris -- interval )
- level>> 1 - 60 * 1000000 swap - ;
+ level>> 1 - 60 * 1,000,000,000 swap - ;
: add-block ( tetris block -- )
over [ board>> ] 2dip current-piece tetromino>> colour>> set-block ;
dup { 0 1 } tetris-move [ move-drop ] [ lock-piece ] if ;
: update ( tetris -- )
- system-micros over last-update>> -
+ nano-count over last-update>> -
over update-interval > [
dup move-down
- system-micros >>last-update
+ nano-count >>last-update
] when drop ;
: ?update ( tetris -- )
! Copyright (C) 2006, 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alarms arrays calendar kernel make math math.rectangles math.parser namespaces sequences system tetris.game tetris.gl ui.gadgets ui.gadgets.labels ui.gadgets.worlds ui.gadgets.status-bar ui.gestures ui.render ui ;
+USING: accessors timers arrays calendar kernel make math math.rectangles
+math.parser namespaces sequences system tetris.game tetris.gl ui.gadgets
+ui.gadgets.labels ui.gadgets.worlds ui.gadgets.status-bar ui.gestures
+ui.render ui ;
FROM: tetris.game => level>> ;
IN: tetris
-TUPLE: tetris-gadget < gadget { tetris tetris } { alarm } ;
+TUPLE: tetris-gadget < gadget { tetris tetris } { timer } ;
: <tetris-gadget> ( tetris -- gadget )
tetris-gadget new swap >>tetris ;
[ tetris>> ?update ] [ relayout-1 ] bi ;
M: tetris-gadget graft* ( gadget -- )
- [ [ tick ] curry 100 milliseconds every ] keep alarm<< ;
+ [ [ tick ] curry 100 milliseconds every ] keep timer<< ;
M: tetris-gadget ungraft* ( gadget -- )
- [ stop-alarm f ] change-alarm drop ;
+ [ stop-timer f ] change-timer drop ;
: tetris-window ( -- )
[
--- /dev/null
+Doug Coleman
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.data calendar calendar.unix classes.struct
+io.files.info.unix.private kernel system time unix unix.time ;
+IN: time.macosx
+
+M: macosx adjust-time-monotonic
+ timestamp>timeval
+ \ timeval <struct>
+ [ adjtime io-error ] keep dup binary-zero? [
+ drop instant
+ ] [
+ timeval>duration since-1970 now time-
+ ] if ;
+
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators kernel system vocabs.loader ;
+IN: time
+
+HOOK: set-time os ( timestamp -- )
+HOOK: adjust-time-monotonic os ( timestamp -- seconds )
+
+os {
+ { [ dup macosx? ] [ drop "time.macosx" require ] }
+ { [ dup windows? ] [ drop "time.windows" require ] }
+ { [ dup unix? ] [ drop "time.unix" require ] }
+ [ drop ]
+} cond
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors calendar classes.struct kernel math system time
+unix unix.time ;
+IN: time.unix
+
+: timestamp>timezone ( timestamp -- timezone )
+ gmt-offset>> duration>minutes 1 \ timezone <struct-boa> ; inline
+
+M: unix set-time
+ [ unix-1970 time- duration>microseconds >integer make-timeval ]
+ [ timestamp>timezone ] bi
+ settimeofday io-error ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: calendar.windows system time windows.errors
+windows.kernel32 kernel classes.struct calendar ;
+IN: time.windows
+
+M: windows set-time
+ >gmt
+ timestamp>SYSTEMTIME SetSystemTime win32-error=0/f ;
--- /dev/null
+USING: accessors continuations fry http.client images.loader
+images.loader.private images.viewer io io.styles kernel memoize
+prettyprint sequences twitter ;
+IN: twitter.prettyprint
+
+MEMO: load-http-image ( url -- image/f )
+ '[ _
+ [ http-get [ check-response drop ] dip ]
+ [ image-class ] bi load-image*
+ ] [ drop f ] recover ;
+
+: user-image ( user -- image/f )
+ profile-image-url>> load-http-image ;
+
+CONSTANT: tweet-table-style
+ H{ { table-gap { 5 5 } } }
+
+CONSTANT: tweet-username-style
+ H{
+ { font-style bold }
+ }
+
+CONSTANT: tweet-text-style
+ H{
+ { font-name "sans-serif" }
+ { font-size 16 }
+ { wrap-margin 500 }
+ }
+
+CONSTANT: tweet-metadata-style
+ H{
+ { font-size 10 }
+ }
+
+: tweet. ( status -- )
+ tweet-table-style [
+ [
+ [ dup user>> user-image [ image. ] when* ] with-cell
+ [
+ H{ { wrap-margin 600 } } [
+ tweet-text-style [
+ tweet-username-style [
+ dup user>> screen-name>> write
+ ] with-style
+ " " write dup text>> print
+
+ tweet-metadata-style [
+ dup created-at>> write
+ " via " write
+ dup source>> write
+ ] with-style
+ ] with-style
+ ] with-nesting
+ ] with-cell
+ ] with-row
+ ] tabular-output nl
+ drop ;
+
+: friends-timeline. ( -- ) friends-timeline [ tweet. ] each ;
+: public-timeline. ( -- ) public-timeline [ tweet. ] each ;
+: user-timeline. ( user -- ) user-timeline [ tweet. ] each ;
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences sorting math math.order
-calendar alarms logging concurrency.combinators namespaces
+calendar timers logging concurrency.combinators namespaces
db.types db.tuples db fry locals hashtables
syndication urls xml.writer validators
html.forms
if(p->image_path == NULL)
p->image_path = default_image_path();
- srand((unsigned int)system_micros());
+ srand((unsigned int)nano_count());
init_ffi();
init_contexts(p->datastack_size,p->retainstack_size,p->callstack_size);
init_callbacks(p->callback_size);
static void *null_dll;
-u64 system_micros()
-{
- struct timeval t;
- gettimeofday(&t,NULL);
- return (u64)t.tv_sec * 1000000 + t.tv_usec;
-}
-
void sleep_nanos(u64 nsec)
{
timespec ts;
void signal_handler(int signal, siginfo_t* siginfo, void* uap);
void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap);
-u64 system_micros();
u64 nano_count();
void sleep_nanos(u64 nsec);
void open_console();
namespace factor
{
-u64 system_micros()
-{
- SYSTEMTIME st;
- FILETIME ft;
- GetSystemTime(&st);
- SystemTimeToFileTime(&st, &ft);
- return (((s64)ft.dwLowDateTime
- | (s64)ft.dwHighDateTime<<32) - EPOCH_OFFSET) / 10;
-}
-
char *strerror(int err)
{
/* strerror() is not defined on WinCE */
#define snprintf _snprintf
#define snwprintf _snwprintf
-u64 system_micros();
void c_to_factor_toplevel(cell quot);
void open_console();
return (void *)CreateThread(NULL, 0, (LPTHREAD_START_ROUTINE)start_routine, args, 0, 0);
}
-u64 system_micros()
-{
- FILETIME t;
- GetSystemTimeAsFileTime(&t);
- return (((u64)t.dwLowDateTime | (u64)t.dwHighDateTime<<32)
- - EPOCH_OFFSET) / 10;
-}
-
u64 nano_count()
{
static double scale_factor;
inline static void early_init() {}
-u64 system_micros();
u64 nano_count();
void sleep_nanos(u64 nsec);
long getpagesize();
_(special_object) \
_(string) \
_(strip_stack_traces) \
- _(system_micros) \
_(tuple) \
_(tuple_boa) \
_(unimplemented) \
exit((int)to_fixnum(ctx->pop()));
}
-void factor_vm::primitive_system_micros()
-{
- ctx->push(from_unsigned_8(system_micros()));
-}
-
void factor_vm::primitive_nano_count()
{
u64 nanos = nano_count();
.386\r
.model flat\r
-exception_handler proto\r
+exception_handler proto c\r
.safeseh exception_handler\r
end\r
// run
void primitive_exit();
- void primitive_system_micros();
void primitive_nano_count();
void primitive_sleep();
void primitive_set_slot();
projects / factor.git / commitdiff
