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

Merge branch 'master' of git://github.com/erg/factor

db4
Slava Pestov 2010-06-22 04:13:39 -04:00
parent dc58b75eab 796aca7a4e
commit 75d2635c05
13 changed files with 32 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
basis/calendar/calendar-tests.factor
View File

@ -140,7 +140,6 @@ IN: calendar.tests
[ +gt+ ] [ 2005 1 1 12 30 0 instant <timestamp> [ +gt+ ] [ 2005 1 1 12 30 0 instant <timestamp>
2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test 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 ] [ 0 micros>timestamp unix-1970 = ] unit-test
[ t ] [ 123456789000000 [ micros>timestamp timestamp>micros ] keep = ] unit-test [ t ] [ 123456789000000 [ micros>timestamp timestamp>micros ] keep = ] unit-test
[ t ] [ 123456789123456000 [ micros>timestamp timestamp>micros ] keep = ] unit-test [ t ] [ 123456789123456000 [ micros>timestamp timestamp>micros ] keep = ] unit-test

10
basis/calendar/unix/unix.factor
View File

@ -29,6 +29,12 @@ IN: calendar.unix
M: unix gmt-offset ( -- hours minutes seconds ) M: unix gmt-offset ( -- hours minutes seconds )
get-time gmtoff>> 3600 /mod 60 /mod ; 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 M: unix gmt
timeval <struct> f [ gettimeofday io-error ] 2keep drop current-timeval timeval>unix-time ;
timeval>unix-time ;

12
basis/core-foundation/run-loop/run-loop.factor
View File

@ -1,10 +1,12 @@
! Copyright (C) 2008, 2010 Slava Pestov ! Copyright (C) 2008, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.syntax kernel math USING: accessors alien alien.c-types alien.syntax calendar
namespaces sequences destructors combinators threads heaps classes.struct combinators core-foundation
deques calendar system core-foundation core-foundation.strings core-foundation.file-descriptors core-foundation.strings
core-foundation.file-descriptors core-foundation.timers core-foundation.time core-foundation.timers deques destructors
core-foundation.time ; heaps kernel math namespaces sequences system threads unix
unix.time ;
FROM: calendar.unix => system-micros ;
IN: core-foundation.run-loop IN: core-foundation.run-loop
CONSTANT: kCFRunLoopRunFinished 1 CONSTANT: kCFRunLoopRunFinished 1

2
basis/core-foundation/timers/timers.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008, 2010 Slava Pestov. ! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.syntax system math kernel calendar 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 IN: core-foundation.timers
TYPEDEF: void* CFRunLoopTimerRef TYPEDEF: void* CFRunLoopTimerRef

2
basis/furnace/cache/cache.factor vendored
View File

@ -22,7 +22,7 @@ server-state f
: expire-state ( class -- ) : expire-state ( class -- )
new new
-1/0. system-micros [a,b] >>expires -1/0. gmt timestamp>micros [a,b] >>expires
delete-tuples ; delete-tuples ;
TUPLE: server-state-manager < filter-responder timeout ; TUPLE: server-state-manager < filter-responder timeout ;

2
basis/smtp/smtp.factor
View File

@ -188,7 +188,7 @@ ERROR: invalid-header-string string ;
"<" % "<" %
64 random-bits # 64 random-bits #
"-" % "-" %
system-micros # gmt timestamp>micros #
"@" % "@" %
smtp-domain get [ host-name ] unless* % smtp-domain get [ host-name ] unless* %
">" % ">" %

1
basis/stack-checker/known-words/known-words.factor
View File

@ -459,7 +459,6 @@ M: bad-executable summary
\ special-object { fixnum } { object } define-primitive \ special-object make-flushable \ special-object { fixnum } { object } define-primitive \ special-object make-flushable
\ string-nth-fast { fixnum string } { fixnum } define-primitive \ string-nth-fast make-flushable \ string-nth-fast { fixnum string } { fixnum } define-primitive \ string-nth-fast make-flushable
\ strip-stack-traces { } { } define-primitive \ strip-stack-traces { } { } define-primitive
\ system-micros { } { integer } define-primitive \ system-micros make-flushable
\ tag { object } { fixnum } define-primitive \ tag make-foldable \ tag { object } { fixnum } define-primitive \ tag make-foldable
\ unimplemented { } { } define-primitive \ unimplemented { } { } define-primitive
\ word-code { word } { integer integer } define-primitive \ word-code make-flushable \ word-code { word } { integer integer } define-primitive \ word-code make-flushable

2
basis/tools/time/time-docs.factor
View File

@ -24,7 +24,7 @@ HELP: time
{ $values { "quot" quotation } } { $values { "quot" quotation } }
{ $description "Runs a quotation, gathering statistics about method dispatch and garbage collection, and then prints the total run time." } ; { $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 HELP: collect-gc-events
{ $values { "quot" quotation } { "gc-events" "a sequence of " { $link gc-event } " instances" } } { $values { "quot" quotation } { "gc-events" "a sequence of " { $link gc-event } " instances" } }

2
basis/ui/gestures/gestures-docs.factor
View File

@ -174,7 +174,7 @@ HELP: hand-last-button
{ $var-description "Global variable. The mouse button most recently pressed." } ; { $var-description "Global variable. The mouse button most recently pressed." } ;
HELP: hand-last-time 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 HELP: hand-buttons
{ $var-description "Global variable. A vector of mouse buttons currently held down." } ; { $var-description "Global variable. A vector of mouse buttons currently held down." } ;

9
basis/uuid/uuid.factor
View File

@ -1,9 +1,8 @@
! Copyright (C) 2008 John Benediktsson ! Copyright (C) 2008 John Benediktsson
! See http://factorcode.org/license.txt for BSD license ! See http://factorcode.org/license.txt for BSD license
USING: byte-arrays checksums checksums.md5 checksums.sha USING: byte-arrays calendar checksums checksums.md5
kernel math math.parser math.ranges random unicode.case checksums.sha io.binary kernel math math.parser math.ranges
sequences strings system io.binary ; random sequences strings system unicode.case ;
IN: uuid IN: uuid
<PRIVATE <PRIVATE
@ -12,7 +11,7 @@ IN: uuid
! 0x01b21dd213814000L is the number of 100-ns intervals ! 0x01b21dd213814000L is the number of 100-ns intervals
! between the UUID epoch 1582-10-15 00:00:00 and the ! between the UUID epoch 1582-10-15 00:00:00 and the
! Unix epoch 1970-01-01 00:00:00. ! Unix epoch 1970-01-01 00:00:00.
system-micros 10 * HEX: 01b21dd213814000 + gmt timestamp>micros 10 * HEX: 01b21dd213814000 +
[ -48 shift HEX: 0fff bitand ] [ -48 shift HEX: 0fff bitand ]
[ -32 shift HEX: ffff bitand ] [ -32 shift HEX: ffff bitand ]
[ HEX: ffffffff bitand ] [ HEX: ffffffff bitand ]

11
core/system/system-docs.factor
View File

@ -14,10 +14,6 @@ ARTICLE: "system" "System interface"
vm vm
image image
} }
"Getting the current time:"
{ $subsections
system-micros
}
"Getting a monotonically increasing nanosecond count:" "Getting a monotonically increasing nanosecond count:"
{ $subsections nano-count } { $subsections nano-count }
"Exiting the Factor VM:" "Exiting the Factor VM:"
@ -78,15 +74,10 @@ HELP: exit ( n -- )
{ $values { "n" "an integer exit code" } } { $values { "n" "an integer exit code" } }
{ $description "Exits the Factor process." } ; { $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 ) HELP: nano-count ( -- ns )
{ $values { "ns" integer } } { $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." } { $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 HELP: image
{ $values { "path" "a pathname string" } } { $values { "path" "a pathname string" } }

6
extra/space-invaders/space-invaders.factor
View File

@ -359,8 +359,8 @@ M: space-invaders update-video ( value addr cpu -- )
: sync-frame ( micros -- micros ) : sync-frame ( micros -- micros )
#! Sleep until the time for the next frame arrives. #! Sleep until the time for the next frame arrives.
1000 60 / >fixnum + system:system-micros - dup 0 > 1000 60 / >fixnum + gmt timestamp>micros - dup 0 >
[ milliseconds threads:sleep ] [ drop threads:yield ] if system:system-micros ; [ milliseconds threads:sleep ] [ drop threads:yield ] if gmt timestamp>micros ;
: invaders-process ( micros gadget -- ) : invaders-process ( micros gadget -- )
#! Run a space invaders gadget inside a #! Run a space invaders gadget inside a
@ -378,7 +378,7 @@ M: space-invaders update-video ( value addr cpu -- )
M: invaders-gadget graft* ( gadget -- ) M: invaders-gadget graft* ( gadget -- )
dup cpu>> init-sounds dup cpu>> init-sounds
f over quit?<< f over quit?<<
[ system:system-micros swap invaders-process ] curry [ gmt timestamp>micros swap invaders-process ] curry
"Space invaders" threads:spawn drop ; "Space invaders" threads:spawn drop ;
M: invaders-gadget ungraft* ( gadget -- ) M: invaders-gadget ungraft* ( gadget -- )

6
extra/tetris/game/game.factor
View File

@ -35,7 +35,7 @@ CONSTANT: default-height 20
rows>> 1 + 10 / ceiling ; rows>> 1 + 10 / ceiling ;
: update-interval ( tetris -- interval ) : update-interval ( tetris -- interval )
level>> 1 - 60 * 1000000 swap - ; level>> 1 - 60 * 1,000,000,000 swap - ;
: add-block ( tetris block -- ) : add-block ( tetris block -- )
over [ board>> ] 2dip current-piece tetromino>> colour>> set-block ; over [ board>> ] 2dip current-piece tetromino>> colour>> set-block ;
@ -104,10 +104,10 @@ CONSTANT: default-height 20
dup { 0 1 } tetris-move [ move-drop ] [ lock-piece ] if ; dup { 0 1 } tetris-move [ move-drop ] [ lock-piece ] if ;
: update ( tetris -- ) : update ( tetris -- )
system-micros over last-update>> - nano-count over last-update>> -
over update-interval > [ over update-interval > [
dup move-down dup move-down
system-micros >>last-update nano-count >>last-update
] when drop ; ] when drop ;
: ?update ( tetris -- ) : ?update ( tetris -- )